and end * tag into any member name (your choice) * in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile. * Example copy command (if you named member A in step 1) * CPYF FROMFILE(mylib/JCRCMDS) TOFILE(mylib/JCRCMDS) FROMMBR(a) + * TOMBR(parser) MBROPT(*REPLACE) FROMRCD(385) TORCD(690) * * 3. Call install program (or execute XMLPREVIEW) passing 3 Parms. * 'your-member-name you uploaded this text into' * 'your-source-file-name member is in' * 'your-library-name source file is in' * * Various source members will be extracted and objects required * for application will be created in your-library-name. * * Members in this install: (to view or manually extract members, scan 0; //error occurred 2b if ApiErrDS.ErrMsgId = 'CPF9810'; //lib not found Msgtxt = '0000 Library ' + %trimr(p_UploadSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; //src file not found Msgtxt = '0000 Source file ' + %trimr(p_UploadSrcFil) + ' was not found in ' + %trimr(p_UploadSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; //member not found Msgtxt = '0000 Member ' + %trimr(p_UploadMbr) + ' was not found in ' + %trimr(p_UploadSrcLib) + '/' + %trimr(p_UploadSrcFil); 2x else; Msgtxt = '0000 Unexpected message ' + ApiErrDS.ErrMsgId + ' received. '; 2e endif; // send message Msgid = 'CPD0006'; Msgtyp = '*DIAG'; Msgq = '*CTLBDY'; exsr srSndMessage; Msgtxt = *blanks; Msgid = 'CPF0002'; Msgtyp = '*ESCAPE'; exsr srSndMessage; *inlr = *on; return; 1e endif; //--------------------------------------------------------- // Set user selected library *first for remainder of program bldexc = 'RMVLIBLE LIB(' + %trimr(p_UploadSrcLib) + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDLIBLE LIB(' + %trimr(p_UploadSrcLib) + ') POSITION(*FIRST)'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); // Override Input file to uploaded text file extIfile = %trimr(p_UploadSrcLib) + '/' + p_UploadSrcFil; open xmlinput; read xmlinput; 1b dow not %eof; // write records to outfile if flag is on 2b if IsWrite; 3b if xmltag2 <> ''; srcSeqno += .01; // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. 4b if %parms = 4; UpSlash = %xlate(lo: up: SlashCopy); 5b if UpSlash = '/COPY' or UpSlash = '/INCL'; Start = 12; 6b if UpSlash = '/INCL'; Start = 15; 6e endif; aa = %scan(',': xmlcode: Start); //find start of member 6b if aa = 0; aa = %check(' ': xmlcode: Start) - 1; 6e endif; xmlcode = %subst(xmlcode: 1: Start) + %trimr(p_UploadSrcLib) + '/' + %trimr(p_OvrSrcFile) + ',' + %subst(xmlcode: (aa + 1)); 5e endif; 4e endif; except write_one; 3x else; IsWrite = *off; close MBRSRC; 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 = p_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 = 'srcccsid='; srcccsid = %subst(xmlcode: 13: 5); // Start of data to copy. Create source files/mbrs as required. 2x elseif xmltag1 = ''; bldexc = 'CRTSRCPF FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') RCDLEN(' + srclen + ') CCSID(' + srcccsid + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') SRCTYPE(' + %trimr(mbrtype) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); 3b if %error; bldexc = 'CHGPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'CLRPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); 3e endif; // override to outfile mbr extOfile = %trimr(p_UploadSrcLib) + '/' + srcfile; clear srcSeqno; open MBRSRC; IsWrite = *on; //--------------------------------------------------------- // Compile statement. Read next record and execute it. // Subroutine srTolibToken will replace &tolib with // library user has selected at run time. 2x elseif xmltag1 = ''; 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 = ''; clear bldexc; aa = 1; read xmlinput; 3b dow xmltag2 <> ''; %subst(bldexc: aa: 100) = xmlcode; 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 // read record and get single line of message text. 2x elseif xmltag1 = ' 0; bldexc = %replace(%trimr(p_UploadSrcLib): 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; bb = %scan(')': bldexc: aa); bldexc = %replace(%trimr(p_OvrSrcFile): bldexc: aa + 1: bb-(aa + 1)); 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srSndMessage; callp QMHSNDPM( Msgid: 'QCPFMSG *LIBL ': Msgtxt: %size(Msgtxt): Msgtyp: Msgq: 1: ' ': ApiErrDS); endsr; /end-free OMBRSRC e write_one O srcSeqno 6 O 12 '000000' O xmlcode 112 * /// END OF INSTALL PGM HERE /// do not copy past this point ********** /// ]]> v5r4 //--------------------------------------------------------- // JCRAMORT - Amortization schedule display // Formula found in OLD RPGII text book to calculate payments. // Added option to allow you to pick desired payments to see how much you can borrow. //--------------------------------------------------------- // Note: There is some interesting cursor stuff in here as I was trying to come up with // neat way to get around no position cursor hex value (PC) with field-name attribute. The // easiest way would have been to hard code row/column of various fields, but that would // not have been flexible if display file was recompiled. Use list fields API to // retrieve row/columns, use CURFLD to look up row/column of that field. Slick. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRAMORTD cf e workstn sfile(SBFDTA1: rrn) infds(infds) F indds(Ind) FJCRAMORTP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D xx s 5i 0 D bott s 15p 9 D first s 15p 9 D ii s 9p 9 D in s 15p 9 D left s 3p 2 D mid s 15p 9 D PrincipleSave s 9p 2 D MaxPaySave s 9p 2 D top s 15p 9 D pIntRate s 4p 4 D ForCount s 5u 0 D Rrn s 5u 0 D ToRrn s 5u 0 //--*COPY DEFINES------------------------------------------ /Define Sds /Define Ind /Define Infds /Define Dspatr /Define FunctionKeys /Define f_OvrPrtf /Define f_DltOvr /Define f_RmvSflMsg /Define f_SndSflMsg /Define f_GetRowColumn /Define f_DspLastSplf /Define f_qmhrcvpm /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- /free f_RmvSflMsg(ProgId); aBegPrif = %bitor(Green:UL); aInRatef = %bitor(Green:UL); aDurationf = %bitor(Green:UL); aPaymentf = %bitor(Green:UL); aMaxLoanf = ND; rrn = 0; evalr scDow = %trimr(f_GetDayName()); 1b dow not (InfdsFkey = f03); sBegPrinci = PrincipleSave; sPayment = MaxPaySave; //--------------------------------------------------------- // display amortization schedule. Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f12 or InfdsFkey = f03; *inlr = *on; return; 2x elseif InfdsFkey = f06; //Print f_OvrPrtf('JCRAMORTP': *OMIT: 'JCRAMORT'); open JCRAMORTP; 3b if sBegPrinci > 0; sLoanAmt = sBegPrinci; 3x else; sLoanAmt = sMaxLoan; 3e endif; write PrtHead1; write PrtHead2; ToRrn = Rrn; 3b for ForCount = 1 to ToRrn; chain ForCount SBFDTA1; 4b if IsOverFlow; write PrtHead1; IsOverFlow = *off; 4e endif; write PrtDetail; 3e endfor; close JCRAMORTP; f_DltOvr('JCRAMORTP '); // Send print completed message f_DspLastSplf(ProgId: '*PRINT '); f_SndSflMsg(ProgId: f_qmhrcvpm(3)); 1i iter; 2e endif; f_RmvSflMsg(ProgId); aBegPrif = %bitor(Green:UL); aInRatef = %bitor(Green:UL); aDurationf = %bitor(Green:UL); aPaymentf = %bitor(Green:UL); aMaxLoanf = ND; PrincipleSave = sBegPrinci; MaxPaySave = sPayment; 2b if sBegPrinci = 0 and sPayment = 0 or (sBegPrinci > 0 and sPayment > 0); CsrRowColDS = f_GetRowColumn('SBEGPRINCI':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter Loan Amount or Max Payments.'); aBegPrif = %bitor(White: RI); aPaymentf = %bitor(White: RI); 1i iter; 2x elseif sDuration = 0; CsrRowColDS = f_GetRowColumn('SDURATION':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter valid Number Of Months.'); aDurationf = %bitor(White: RI); 1i iter; 2x elseif sIntRate = 0; CsrRowColDS = f_GetRowColumn('SINTRATE':InfdsFile:InfdsLib:InfdsRcdfmt); f_SndSflMsg(ProgId: 'Please enter valid Interest Rate.'); aInRatef = %bitor(White: RI); 1i iter; 2e endif; //--------------------------------------------------------- Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; //--------------------------------------------------------- // calculate amortization schedule. pIntRate = sIntRate/100; 2b if sPayment > 0; aMaxLoanf = %bitor(White:ul); //--------------------------------------------------------- // calculates maximum loan value based on payment. eval(h) ii = pIntRate/12; xx = sDuration - 1; first = 1 + ii; bott = first; 3b for ForCount = 1 to xx; eval(h) first *= bott; 3e endfor; top = first - 1; eval(h) mid = top/first; eval(h) in = mid/ii; sBegPrinci = in * sPayment; 2e endif; //--------------------------------------------------------- sMaxLoan = sBegPrinci; eval(h) ii = pIntRate/12; xx = sDuration - 1; first = 1 + ii; bott = first; 2b for ForCount = 1 to xx; eval(h) first *= bott; 2e endfor; top = first - 1; eval(h) mid = top/first; eval(h) in = mid/ii; sPayment = sBegPrinci/in; sMonthCnt = 0; 2b for ForCount = 1 to sDuration; eval(h) sIntresPay = sBegPrinci * ii; sMonthCnt += 1; sPrinciPay = sPayment - sIntresPay; 3b if sDuration = sMonthCnt; left = sPrinciPay - sBegPrinci; sPayment -= left; sPrinciPay = sPayment - sIntresPay; 3e endif; sNewPrinci = sBegPrinci - sPrinciPay; rrn += 1; write SBFDTA1; sBegPrinci = sNewPrinci; 2e endfor; 1e enddo; ]]> v5r4 *---------------------------------------------------------------- * JCRAMORTD - Amortization schedule display - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 CF06 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SMONTHCNT 5Y 0O 7 3EDTCDE(4) A SBEGPRINCI 9Y 2O 7 10EDTCDE(4) A SPAYMENT 9Y 2O 7 23EDTCDE(4) DSPATR(UL) A SINTRESPAY 9Y 2O 7 36EDTCDE(4) A SPRINCIPAY 9Y 2O 7 49EDTCDE(4) A SNEWPRINCI 9Y 2O 7 62EDTCDE(4) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(15) SFLSIZ(360) A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A ABEGPRIF 1A P A AINRATEF 1A P A ADURATIONF 1A P A APAYMENTF 1A P A AMAXLOANF 1A P A 1 3'JCRAMORT' COLOR(BLU) A 1 27'Amortization Schedule' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 3'Loan Amount:' A SBEGPRINCI 9Y 2B 2 16EDTCDE(4) DSPATR(&ABEGPRIF) A CHECK(FE RB) A 2 28'OR Desired Max Monthly Payment:' A SPAYMENT 9Y 2B 2 60EDTCDE(4) DSPATR(&APAYMENTF) A CHECK(FE RB) A 2 72SYSNAME COLOR(BLU) A 3 3'Number of months:' A SDURATION 3Y 0B 3 23EDTCDE(4) DSPATR(&ADURATIONF) A CHECK(FE RB) A 3 43'Max Loan Amount:' A DSPATR(&AMAXLOANF) A SMAXLOAN 9Y 2O 3 60EDTCDE(4) DSPATR(&AMAXLOANF) A 4 3'Interest rate:' A SINTRATE 4Y 2B 4 21EDTCDE(4) DSPATR(&AINRATEF) A CHECK(FE RB) A 4 28'(Key 12.5% as 12.5)' A 4 51'Name:' A SCUSTNAME 20A B 4 57CHECK(LC) A 5 11'Beginning' DSPATR(HI) A 5 25'Payment' DSPATR(HI) A 5 38'Interest' DSPATR(HI) A 5 50'Principal' DSPATR(HI) A 5 65'New' DSPATR(HI) A 6 3'Month' DSPATR(HI) A 6 11'Principal' DSPATR(HI) A 6 25'Amounts' DSPATR(HI) A 6 38'Payments' DSPATR(HI) A 6 50'Payments' DSPATR(HI) A 6 63'Principal' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 23 2'F3=Exit' COLOR(BLU) A 23 13'F6=Print' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 *---------------------------------------------------------------- * JCRAMORTP- Amortization schedule display - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD1 SKIPB(1) SPACEA(2) A 2'JCRAMORT' A 18'Amortization Schedule' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) *--- A 2'CLIENT' A 23'INTEREST' A 34'LOAN' A 52'BEGINNING' A 78'INTEREST' A 91'PRINCIPAL' A 103'NEW' SPACEA(1) *--- A 2'NAME' A 23'RATE' A 34'AMOUNT' A 43'MONTH' A 52'PRINCIPAL' A 66'PAYMENTS' A 78'DUE' A 91'PAYMENT' A 103'PRINCIPAL' *---------------------------------------------------------------- A R PRTHEAD2 SPACEB(1) A SCUSTNAME 20A O 2 A PINTRATE 4 4O 23EDTCDE(1) A SLOANAMT 9 2O 30EDTCDE(1) *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SMONTHCNT 5 0O 43EDTCDE(Z) A SBEGPRINCI 9 2O 49EDTCDE(1) A SPAYMENT 9 2O 62EDTCDE(1) A SINTRESPAY 9 2O 75EDTCDE(1) A SPRINCIPAY 9 2O 88EDTCDE(1) A SNEWPRINCI 9 2O 101EDTCDE(1) ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRANZD - DSPF screen layout with field names report - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print DSPF Field Layout') PARM KWD(DSPF) TYPE(DSPF) MIN(1) PGM(*YES) PROMPT('DSPF Object Name:') DSPF: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*FILE ') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRANZD'.Print DSPF Field Layout (JCRANZD) - Help .* Craig Rutledge .*-------------------------------------------------------------------- :P.This JCR command uses insanely complicated QDFRTVFD Retrieve display file description API to generate layout report with field names printed under the data psoitions. :P.If field or constant is wrap-around (longer than line in DSPF), it will be truncated to fit on one line. :P.Numeric fields longer than 14 will be edited with Z edit code due to restrictions of Float numbers. :P.Record formats are listed in sequence they appear in source member.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZD/DSPF'.DSPF Object Name - Help :XH3.DSPF Object Name (DSPF) :P.Display file and library to be analyzed.:EHELP. :HELP name='JCRANZD/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRANZDP - DSPF screen layout with field names report - DSPF * also used as print file for ospec and prtf layout reports *---------------------------------------------------------------- *--- PAGESIZE(66 198) A R PRTHEAD SKIPB(1) SPACEA(2) A SCOBJHEAD 105A 2 A SCDOW 9A O 110 A 120DATE EDTCDE(Y) *---------------------------------------------------------------- A R PRTLINE SPACEA(1) A LAYOUT 198A 1 ]]> v5r4 //--------------------------------------------------------- // JCRANZDR - DSPF screen layout with field names report // Buggy API, Pointers to pointers to pointers, Difficult documentation. Retrieve display // file info API (QDFRTVFD) is WAY too much trouble to fool with. The code will be // impossible to follow without looking at 97 pages of API documentation at the same time. It // may be impossible to follow with documentation:-) I will admit this is first time // I ran down 27 related pointers and offsets to get edit codes!! // There is a bug in API. If character value starts in position 1, the API // returns (row-1) with (col = Display size + 1). Beats the heck outta me. // // Receiver variable returned by this API can be larger than largest allowed field // size of RPG variable. Going to have to do 'allocate memory size and point to it' // then call again so all data will fit. // Note: numeric fields longer than 14 digits exceed max Float Size so I have to load // all 9's for those fields instead of showing edited. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRANZDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D dd s 5u 0 D zz s 5u 0 D rr s 3u 0 D FillChar s 3000a D FieldNam s 10a D Row s 3u 0 D PrintRow s 3u 0 D Col s 3u 0 D MaxCol s 3u 0 D NumberDec s 3u 0 D NameSpace s 3u 0 D pConst s 132a D ReceiverVar s 256a D ReceiverVarLen s 10i 0 D EditMask s 256a D Alpha63 s 63a D CharParm s 256a D EditMaskLen s 10i 0 D ZeroSuppress s 1a D ProgramLen s 10i 0 D FldNameRowArry s 132a dim(6) D IsEdit s n //--*COPY DEFINES------------------------------------------ /Define ApiErrds /Define Constants /Define Tstbts /Define Cvthc /Define f_OvrPrtf /Define GetAllocSizeDS /Define f_BuildString /Define f_DspLastSplf /Define f_DltOvr /Define f_Qusrobjd /Define atof /Define f_GetDayName /Define f_SndEscapeMsg /Define f_RtvMsgAPI /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_CvtHexToInt PR 3u 0 D 1a Const D Qecedt PR extpgm('QECEDT') Apply Edit Mask D 256a Receiver D 10i 0 Mask Length D 256a To Be Edited D 10a const Type D 10i 0 const Field Length D 256a Edit Mask D 10i 0 Mask Length D 1a const 0 Balance File Db like(ApiErrDS) Error Parm D qxxdtop PR extproc('QXXDTOP') Floating to Packed D * value Pointer d 10i 0 value Digits D 10i 0 value Fraction D 8f value Double //--*DATA STRUCTURES--------------------------------------- // Base File Section D QDFFBASEds ds based(QDFFBASEptr) qualified D OffsetToQDFFINFO... D 5i 0 overlay(QDFFBASEds:9) D NumRecFmts 5i 0 overlay(QDFFBASEds:11) D NumScreenSizes 5i 0 overlay(QDFFBASEds:14) // Screen Size Table D QDFFSCRAds ds based(QDFFSCRAptr) qualified D ScreenID 1a overlay(QDFFSCRAds:1) // Display Device Dependent Section D QDFFINFOds ds based(QDFFINFOptr) qualified D LengthFileHeaderSection... D 10i 0 overlay(QDFFINFOds:1) D OffsetToQDFWFLEI... D 10i 0 overlay(QDFFINFOds:5) // Displacement to Record Format Table D QDFARFTEds ds based(QDFARFTEptr) qualified D RcdFmtName 10a overlay(QDFARFTEds:1) D OffsetToQDFFRINF... D 10i 0 overlay(QDFARFTEds:13) // Record Header Section D QDFFRINFds ds based(QDFFRINFptr) qualified D LengthRecordHeaderSection... D 10i 0 overlay(QDFFRINFds:1) D OffsetToQDFFFITB... D 10i 0 overlay(QDFFRINFds:5) D NumFields 5i 0 overlay(QDFFRINFds:17) D OffsetToQDFFRDPD... D 5i 0 overlay(QDFFRINFds:29) // Fields Indexing Table D QDFFFITBds ds based(QDFFFITBptr) qualified D OffsetToQDFFFINF... D 10i 0 overlay(QDFFFITBds:1) D DisplayLength 5i 0 overlay(QDFFFITBds:7) // Field Header D QDFFFINFds ds based(QDFFFINFptr) qualified D FieldAttribut 1a overlay(QDFFFINFds:3) D DateTimeBits 1a overlay(QDFFFINFds:4) D SystemUserBits 1a overlay(QDFFFINFds:5) // Named Field Header D QDFFFNAMds ds based(QDFFFNAMptr) qualified D ProgramLen 5i 0 overlay(QDFFFNAMds:5) D NumberDec 1a overlay(QDFFFNAMds:7) D DataType 1a overlay(QDFFFNAMds:8) D NamedOffsetToQDFFFDPD... D 5i 0 overlay(QDFFFNAMds:11) // Constant Header D QDFFFCONds ds based(QDFFFCONptr) qualified D ConstantOffsetToQDFFFDPD... D 5i 0 overlay(QDFFFCONds:3) // Record Level Device Dependent Section D QDFFRDPDds ds based(QDFFRDPDptr) qualified D OffsetToQDFFRCTB... D 10i 0 overlay(QDFFRDPDds:1) // Row Column Table D QDFFRCTBds ds based(QDFFRCTBptr) qualified D QDFFRCTEds 2a overlay(QDFFRCTBds:7) dim(1000) // Where Used File D QDFWFLEIds ds based(QDFWFLEIptr) qualified D OffsetToQDFWRCDI... D 5i 0 overlay(QDFWFLEIds:1) D OffsetToQDFFNTBL... D 10i 0 overlay(QDFWFLEIds:9) // Where Used Record D QDFWRCDIds ds based(QDFWRCDIptr) qualified D OffsetToQDFWFLDI... D 5i 0 overlay(QDFWRCDIds:1) D LengthOfWhereUsedSectionForThisRecord... D 10i 0 overlay(QDFWRCDIds:5) // Where Used Field D QDFWFLDIds ds based(QDFWFLDIptr) qualified D LengthOfWhereUsedsectionForThisField... D 5i 0 overlay(QDFWFLDIds:1) D IndexOfFieldNameTable... D 10i 0 overlay(QDFWFLDIds:7) D FieldLength 5i 0 overlay(QDFWFLDIds:11) // Field Name Table D QDFFNTBLds ds based(QDFFNTBLptr) qualified D NumberOfEntries... D 10i 0 overlay(QDFFNTBLds:1) D FieldNameArry 10a overlay(QDFFNTBLds:5) dim(1000) // Device Field Dependent D QDFFFDPDds ds based(QDFFFDPDptr) qualified D OffsetToQDFFCOSA... D 5i 0 overlay(QDFFFDPDds:5) // Constant Keywords D QDFFCOSAds ds based(QDFFCOSAptr) qualified D NumberEntries 5i 0 overlay(QDFFCOSAds:1) // Keyword Entries D QDFFCCOAds ds based(QDFFCCOAptr) qualified D Category 1a overlay(QDFFCCOAds:1) D OffsetToCategory... D 5i 0 overlay(QDFFCCOAds:2) // Keyword 24 structure D QDFKEDTRds ds based(QDFKEDTRptr) qualified D NumberOfKeys 5i 0 overlay(QDFKEDTRds:1) // Keyword Parameters D QDFKEDTPds ds based(QDFKEDTPptr) qualified D KeyWord 1a overlay(QDFKEDTPds:1) D ZeroSuppress 1a overlay(QDFKEDTPds:2) D LenEditMask 5i 0 overlay(QDFKEDTPds:3) D EditMask 256a overlay(QDFKEDTPds:6) // Keyword 23 structure D QDFKDFTds ds based(QDFKDFTptr) qualified D NumberOfKeys 5i 0 overlay(QDFKDFTds:1) // Keword Parameters D QDFKDFPMds ds based(QDFKDFPMptr) qualified D LengthOfData 5i 0 overlay(QDFKDFPMds:5) D MscgonData 4000a overlay(QDFKDFPMds:7) //--*CALL PROTOTYPES--------------------------------------- D QDFRTVFD PR extpgm('QDFRTVFD') Rtv DSPF description D 8a options(*varsize) Receiver D 10i 0 const Receiver Length D 8a const Api Format D 20a const Qualified File Name Db like(ApiErrds) Error Parm //--*ENTRY PARMS------------------------------------------- D p_JCRANZDR PR extpgm('JCRANZDR') D 20a D 10a D 8a D p_JCRANZDR PI D p_FileQual 20a D p_ObjTyp 10a D p_Output 8a //--------------------------------------------------------- /free // Print headings. Load print position 'rulers' f_OvrPrtf('JCRANZDP ': *OMIT: %subst(p_FileQual: 1: 10)); open JCRANZDP; evalr scDow = %trimr(f_GetDayName()); QusrObjDS = f_QUSROBJD(p_FileQual: '*FILE ': 'OBJD0200'); %subst(p_FileQual: 11: 10) = QusrObjDS.ReturnLib; scObjHead = f_BuildString('& File: & & &': 'JCRANZDR': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: QusrObjDS.Text); write PrtHead; // load ruler to show output positions 1b for dd = 1 to 13; %subst(LayOut:dd*10:1) = %subst(%editc(dd: '3'): 5: 1); 1e endfor; write PrtLine; %subst(LayOut:1:132) = *all'1234567890'; write PrtLine; //--------------------------------------------------------- // retrieve display file callp QDFRTVFD( GetAllocSizeDS: %len(GetAllocSizeDS): 'DSPF0100': p_FileQual: ApiErrds); 1b if ApiErrDS.BytesReturned > 0; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; QDFFBASEptr = %alloc(GetAllocSizeDS.SizeReturned); callp QDFRTVFD( QDFFBASEds: GetAllocSizeDS.SizeReturned: 'DSPF0100': p_FileQual: ApiErrds); // set pointer to Screen Size IDs QDFFSCRAptr = QDFFBASEptr + 19; // screen sizes ID 1b if QDFFSCRAds.ScreenID = x'03'; MaxCol = 80; 1x else; MaxCol = 132; 1e endif; // set pointer to File Header Section QDFFINFOds QDFFINFOptr = %addr(QDFFBASEds) + QDFFBASEds.OffsetToQDFFINFO; // Where Used File Information pointer QDFWFLEIptr = QDFFINFOptr + QDFFINFOds.OffsetToQDFWFLEI; // Field Name table pointer QDFFNTBLptr = QDFWFLEIptr + QDFWFLEIds.OffsetToQDFFNTBL; // Where Used Record information starting pointer QDFWRCDIptr = QDFWFLEIptr + QDFWFLEIds.OffsetToQDFWRCDI; //--------------------------------------------------------- // Spin through record formats, ignoring any internally generated formats // set pointer to record format section QDFARFTEds QDFARFTEptr = QDFFINFOptr + QDFFINFOds.LengthFileHeaderSection; 1b for bb = 1 to QDFFBASEds.NumRecFmts; 2b if %subst(QDFARFTEds.RcdFmtName:1 :1) <> '*'; 3b if bb > 1; // Next record format exsr srPrintLine; 3e endif; LayOut = *blanks; %subst(LayOut:1:80) = *all'-'; %subst(LayOut:1:13) = '-R-' + %xlate(' ':'-':QDFARFTEds.RcdFmtName); write PrtLine; LayOut = *blanks; //--------------------------------------------------------- // Get Fields for Record Format. // The deal here is there are WHOLE bunch of arrays in // WHOLE bunch of different sections. The trick is to // keep track of all different pointers as you spin through // these multiple arrays. // set pointer to record header section QDFFRINF to get number of fields //--------------------------------------------------------- QDFFRINFptr = QDFFINFOptr + QDFARFTEds.OffsetToQDFFRINF; // set pointer to Field Indexing Table QDFFFITBptr = QDFFRINFptr + QDFFRINFds.OffsetToQDFFFITB; // set pointer to Field Header QDFFFINF // set pointer to named field and constant headers QDFFFINFptr = QDFFRINFptr + QDFFFITBds.OffsetToQDFFFINF; QDFFFNAMptr = QDFFFINFptr + 6; QDFFFCONptr = QDFFFINFptr + 6; // set pointer to Record Level Device Dependent Section QDFFRDPD QDFFRDPDptr = QDFFRINFptr + QDFFRINFds.OffsetToQDFFRDPD; // set pointer to Row Column Table QDFFRCTB QDFFRCTBptr = QDFFRINFptr + QDFFRDPDds.OffsetToQDFFRCTB; // set offset to Where Used Field Information QDFWFLDIptr = QDFWRCDIptr + QDFWRCDIds.OffsetToQDFWFLDI; 3b for cc = 1 to QDFFRINFds.NumFields; FieldNam = *blanks; 4b if QDFFFINFds.FieldAttribut = x'06' // hidden or QDFFFINFds.FieldAttribut = x'07'; // program communication 4x else; row = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(cc):1:1)); col = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(cc):2:1)); col += 1; // goofy API. 5b if col > MaxCol; Col -= MaxCol; Row += 1; 5e endif; //--------------------------------------------------------- // If Row number changes, print current buffers and start // loading buffers for next row 5b if cc = 1; PrintRow = Row; 5e endif; 5b if PrintRow <> Row; // new row exsr srPrintLine; PrintRow = Row; 5e endif; //--------------------------------------------------------- // CONSTANTS 5b if QDFFFINFds.FieldAttribut = x'01'; FieldNam = *blanks; 6b if tstbts(QDFFFINFds.DateTimeBits: 0) = 1 or tstbts(QDFFFINFds.DateTimeBits: 1) = 1; FieldNam = 'DATE '; pConst = 'DD/DD/DD'; 6x elseif tstbts(QDFFFINFds.DateTimeBits: 2) = 1; FieldNam = 'TIME '; pConst = 'TT:TT:TT'; 6x elseif tstbts(QDFFFINFds.SystemUserBits: 4) = 1; FieldNam = 'USER '; pConst = 'UUUUUUUUUU'; 6x elseif tstbts(QDFFFINFds.SystemUserBits: 5) = 1; FieldNam = 'SYSNAME'; pConst = 'SSSSSSSS'; 6x else; QDFFFDPDptr = QDFFFINFptr + QDFFFCONds.ConstantOffsetToQDFFFDPD; exsr srCategoryKeys; 6e endif; 6b if Col < 133; %subst(Layout:Col) = pConst; 7b if FieldNam > *blanks; exsr srStagger; 7e endif; 6e endif; 5x else; //--------------------------------------------------------- // FIELDS ProgramLen = QDFFFNAMds.ProgramLen; NumberDec = f_CvtHexToInt(QDFFFNAMds.NumberDec); 6b if QDFWFLDIds.IndexOfFieldNameTable > 0; FieldNam = QDFFNTBLds.FieldNameArry(QDFWFLDIds.IndexOfFieldNameTable); QDFFFDPDptr = QDFFFINFptr + QDFFFNAMds.NamedOffsetToQDFFFDPD; //--------------------------------------------------------- // if field has edit code or edit word then it will have keywords // Note: Float numbers will only work for 14 or less length numeric, so // if field is longer than that, give it Z edit code 7b if QDFFFNAMds.DataType = x'00' or QDFFFNAMds.DataType = x'01'; // Alpha FillChar = *all'X'; 7x else; FillChar = *all'9'; 8b if QDFFFDPDds.OffsetToQDFFCOSA > 0 and ProgramLen < 15; IsEdit = *off; exsr srCategoryKeys; 9b if IsEdit; FillChar = ReceiverVar; 9e endif; 8e endif; 7e endif; 7b if Col < 133; %subst(Layout:Col) = %subst(FillChar:1:QDFFFITBds.DisplayLength); 8b if FieldNam > *blanks; exsr srStagger; 8e endif; 7e endif; 6e endif; 5e endif; 4e endif; 4b if cc < QDFFRINFds.NumFields; QDFWFLDIptr += QDFWFLDIds.LengthOfWhereUsedsectionForThisField; QDFFFITBptr += %len(QDFFFITBds); // next Field Index Table QDFFFINFptr = QDFFRINFptr + QDFFFITBds.OffsetToQDFFFINF; QDFFFNAMptr = QDFFFINFptr + 6; QDFFFCONptr = QDFFFINFptr + 6; 4e endif; 3e endfor; // set offset to next Where Used Record Information QDFWRCDIptr += QDFWRCDIds.LengthOfWhereUsedSectionForThisRecord; 2e endif; QDFARFTEptr += %len(QDFARFTEds); 1e endfor; exsr srPrintLine; %subst(LayOut:1:132) = *all'-'; write PrtLine; dealloc QDFFBASEptr; close JCRANZDP; f_DltOvr('JCRANZDP '); f_DspLastSplf('JCRANZDR ': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Print display line and field names. begsr srPrintLine; write PrtLine; 1b for rr = 1 to 6; 2b if FldNameRowArry(rr) > *blanks; LayOut = FldNameRowArry(rr); write PrtLine; 2e endif; 1e endfor; Layout = *blanks; FldNameRowArry(*) = *blanks; endsr; //--------------------------------------------------------- // Stagger field names if short length fields. // 9 99 666 // Fieldname1 // Fieldname2 // Fieldname3 begsr srStagger; NameSpace = Col; // no contiguous names Field1Field2 1b if Col = 1; NameSpace = 2; 1e endif; 1b for rr = 1 to 6; 2b if %subst(FldNameRowArry(rr): NameSpace - 1: 1) = *blanks; %subst(FldNameRowArry(rr): Col) = FieldNam; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr srCategoryKeys; 1b if QDFFFDPDds.OffsetToQDFFCOSA > 0; // has keywords // Get Keyword Category Displacement String (QDFFCOSA) QDFFCOSAptr = QDFFFINFptr + QDFFFDPDds.OffsetToQDFFCOSA; QDFFCCOAptr = QDFFCOSAptr + 2; 2b for zz = 1 to QDFFCOSAds.NumberEntries; // Get editing for field. 3b if QDFFCCOAds.Category = x'24'; IsEdit = *on; QDFKEDTRptr = QDFFFINFptr + QDFFCCOAds.OffsetToCategory; QDFKEDTPptr = QDFKEDTRptr + 2; ZeroSuppress = QDFKEDTPds.ZeroSuppress; EditMaskLen = QDFKEDTPds.LenEditMask; EditMask = %subst(QDFKEDTPds.EditMask:1:EditMaskLen); //--------------------------------------------------------- // What I have to do here is get description // of field into decimal value so the editing mask can be applied. // Way cool 'virtual decimal' number created by // Alpha to Float C++ function combined with Float to Packed C++ function. ReceiverVar = *blanks; ReceiverVarLen = %len(ReceiverVar); clear Alpha63; 4b for aa = 1 to (ProgramLen - NumberDec); %subst(Alpha63: aa : 1) = '9'; 4e endfor; 4b if NumberDec > 0; %subst(Alpha63: aa : 1) = '.'; 5b for dd = 1 to NumberDec; aa += 1; %subst(Alpha63: aa : 1) = '9'; 5e endfor; 4e endif; qxxdtop(%addr(CharParm) : ProgramLen: NumberDec: -atof(Alpha63)); callp QECEDT( ReceiverVar: ReceiverVarLen: CharParm: '*PACKED': ProgramLen: EditMask: EditMaskLen: ZeroSuppress: ApiErrDS ); 2v leave; //--------------------------------------------------------- // If constant has attributes (RI, PC , colors or stuff) // then I have to spin through Keyword Category Displacement String // until I find category 23 3x elseif QDFFCCOAds.Category = x'23'; // constant QDFKDFTptr = QDFFFINFptr + QDFFCCOAds.OffsetToCategory; QDFKDFPMptr = QDFKDFTptr + 2; 4b for zz = 1 to QDFKDFTds.NumberOfKeys; pConst = %subst(QDFKDFPMds.MscgonData:1: QDFKDFPMds.LengthOfData); QDFKDFPMptr += QDFKDFPMds.LengthOfData; 4e endfor; 2v leave; 3e endif; QDFFCCOAptr += %len(QDFFCCOAds); 2e endfor; 1e endif; endsr; /end-free //--*FUNCTIONS START HERE---------------------------------- // There is no single 'convert hex to integer' so I // have to convert hex to character, then character to integer. P f_CvtHexToInt b D f_CvtHexToInt PI 3u 0 D p_Character 1a Const D HexVal s 1a D Alpha2 s 2a D Integer s 3u 0 D cvtch PR ExtProc('cvtch') Character to Hex D * value Receiver Pointer D * value Source Pointer D 10i 0 value Length of Receiver /free HexVal = p_Character; 1b if HexVal = x'FF'; // no location return 0; 1e endif; cvthc( %addr(Alpha2): %addr(HexVal): 2); cvtch( %addr(Integer): %addr(Alpha2): %size(Integer) * 2); return Integer; /end-free P f_CvtHexToInt e ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRANZO - O spec print layout with field names report - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print OSPEC Layout Report') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('RPG source member name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(LAYOUTONLY) TYPE(*CHAR) LEN(4) RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Include rcdfmts & fld names:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRANZO'.Print OSPEC Layout Report (JCRANZO) - Help .*-------------------------------------------------------------------- :P.This JCR command reads your RPG4 source O specs to provide layout report with field names printed under the data layout. :P.The LayoutOnly keyword was added to allow printing of layout without print line data and field names. This option could be used to generate prototype layout to show user what report will look like.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZO/PGM'.PGM source member name (PGM) - Help :XH3.PGM source member name (PGM) :P.Source member for which field list is to be printed.:EHELP. :HELP name='JCRANZO/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source PGM member.:EHELP. :HELP name='JCRANZO/LAYOUTONLY'.Include Record Formats & Field Names - Help :XH3.Include Record Formats & Field Names (LAYOUTONLY) :P.Include print line names and field names on layout report.:EHELP. :HELP name='JCRANZO/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRANZOR - O spec print layout with field names report // call program to load field names & attributes into IMPORTED array // read rpg source code specs // load output arrays with positional field data and field names // note: shares common print file with jcranzdr and jcranzpr //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn FJCRANZDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D IsFoundOspec s n D AllNines s 30a inz(*all'9') build pseudo number D AllZeros s 30a inz(*all'0') D DecimalPart s 9a D EditMask s 256a D FirstTime s 2a inz('XX') D FloatDollar s 3a inz('''$''') D StaggerNam s 198a dim(15) D scDow s 9a D IPPfield s 12a D LoadNamFlg s 14a inz('Load Name Flag') D LookupName s 15a D ReceiverVar s 256a D WholePart s 21a D EditMaskLen s 10i 0 edit Mask Length D ReceiverVarLen s 10i 0 D xa s 5i 0 D xe s 5i 0 D xm s 5i 0 D DecimalPos s 1p 0 D v30_9Dec s 30p 9 D oEndPosN s 5s 0 based(oEndPtr) D ForCount s 5u 0 D StaggerDepth s 3u 0 prevent name overlap D IntegerLength s 5u 0 D LastEndPos s 5u 0 D xb s 5u 0 D xd s 3u 0 ) D xf s 3u 0 ) D xg s 3u 0 ( D xh s 3u 0 ( D xi s 5u 0 D EndPosX s 5u 0 D xk s 5u 0 D xo s 5u 0 D oEndPtr s * inz(%addr(SrcDS.oEndPos)) D IsContinuation s n inz(*off) D BuildContin s 200a varying D PlusSignVal s 5a D DimSizeVal s 5a //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define FieldsArry /Define Constants /Define FieldsAttrDS /Define Qeccvtec /Define f_Qusrmbrd /Define f_BuildString /Define Qecedt /Define SrcDS /Define f_FakeEditWord /Define f_GetQual /Define f_SndEscapeMsg /Define f_GetDayName /Define f_OvrPrtf /Define f_Dltovr /Define f_DspLastSplf /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D v30_9DS ds qualified D v30_9Zoned 30s 9 inz(0) D EditedDS ds qualified D EditedArry 1a dim(40) inz //--*ENTRY PARMS------------------------------------------- D p_JCRANZOR PR extpgm('JCRANZOR') D 10a source member D 20a source file and lib D 4a layout D 8a output D p_JCRANZOR PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_Layout 4a D p_Output 8a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 112 SrcDS //--------------------------------------------------------- /free // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFilQual: p_SrcMbr: DiagSeverity); 1b if DiagSeverity > '20'; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; extIfile = f_GetQual(p_SrcFilQual); open RPGSRC; f_OvrPrtf('JCRANZDP ': *OMIT: p_SrcMbr); open JCRANZDP; evalr scDow = %trimr(f_GetDayName()); scObjHead = f_BuildString('& Mbr: & & & &': 'JCRANZOR': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); write PrtHead; // load ruler to show output positions 1b for xa = 1 to 19; %subst(LayOut:xa*10:1) = %subst(%editc(xa: '3'): 5: 1); 1e endfor; write PrtLine; LayOut = *all'1234567890'; write PrtLine; LayOut = *all'-'; write PrtLine; //--------------------------------------------------------- IsFoundOspec = *off; read RPGSRC; 1b dow not %eof; 2b if SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c' or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'p'; 1v leave; 2e endif; SrcDS.oAndOr = %xlate(lo: up: SrcDS.oAndOr); 2b if (SrcDS.SpecType = 'O' or SrcDS.SpecType = 'o') and (not (SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/')) and (not (SrcDS.oAndOr = 'OR ' or SrcDS.oAndOr = 'AND')); IsFoundOspec = *on; //--------------------------------------------------------- // First, print field data for previous line. // Spaces are loaded with '_' then is loaded into printing array. //--------------------------------------------------------- 3b if SrcDS.oLineType > *blanks; 4b if FirstTime = 'NO'; write prtLine; 5b if p_LayOut = '*YES'; 6b for cc = 1 to StaggerDepth; LayOut = StaggerNam(cc); write PrtLine; 6e endfor; 5e endif; Layout = *blanks; StaggerDepth = 0; StaggerNam(*) = *blanks; EndPosX = 0; LastEndPos = 0; 4e endif; FirstTime = 'NO'; //--------------------------------------------------------- // Take Record Format line and replace // the spaces with underscores for printing asthetics LayOut = *blanks; 4b if p_LayOut = '*YES'; LayOut = *all'_'; %subst(Layout:2:74) = %xlate(' ':'_':SrcDS.Src80); 4e endif; write PrtLine; LayOut = *blanks; 3x else; clear IPPfield; exsr srGetFieldAttr; exsr srFieldLoad; 3e endif; 2e endif; read RPGSRC; 1e enddo; // all processed. 1b if not IsFoundOspec; LayOut = 'No Output Specifications found in source ********'; StaggerDepth = 0; 1e endif; write prtLine; 1b if p_LayOut = '*YES'; 2b for cc = 1 to StaggerDepth; LayOut = StaggerNam(cc); write PrtLine; 2e endfor; 1e endif; close RPGSRC; close JCRANZDP; f_Dltovr('JCRANZDP '); f_DspLastSplf('JCRANZOR ': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Load data into print array. begsr srFieldLoad; 1b if SrcDS.oEndPos = *blank; EndPosX = LastEndPos; 2b if EndPosX < 199; 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; 2e endif; 1x else; //--------------------------------------------------------- // end position = + and some value load from left to right // check for - in EndPosition xb = 0; xe = %scan('+': SrcDS.oEndPos: 1); 2b if xe = 0; xb = %scan('-': SrcDS.oEndPos: 1); 2e endif; 2b if xe > 0 //plus or xb > 0; //minus PlusSignVal = *blanks; 3b if xe > 0; //plus %subst(PlusSignVal: xe + 1) = %subst(SrcDS.oEndPos: xe + 1); //drop plus sign 3x else; %subst(PlusSignVal: xb + 1) = %subst(SrcDS.oEndPos: xb + 1); //drop minus sign 3e endif; 3b if PlusSignVal = *blanks; EndPosX = 0; 3x else; EndPosX = %uns(PlusSignVal); 3e endif; 3b if xe > 0; //plus EndPosX += LastEndPos; 3x else; EndPosX = LastEndPos - EndPosX; 3e endif; 3b if EndPosX < 199; 4b if IPPfield = 'Constant '; exsr srDoConstLeft; 4x elseif IPPfield = 'Alpha Field '; exsr srDoAlphaLeft; 4x elseif IPPfield = 'Num EditWord'; exsr srDoConstLeft; 4x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeLeft; 4e endif; 3e endif; 2x else; //--------------------------------------------------------- // end position is given, load from right to left 3b if SrcDS.oEndPos = *blanks; EndPosX = 0; 3x else; EndPosX = oEndPosN; 3e endif; 3b if EndPosX < 199; 4b if IPPfield = 'Constant '; exsr srDoConstRight; 4x elseif IPPfield = 'Alpha Field '; exsr srAlphaRight; 4x elseif IPPfield = 'Num EditWord'; exsr srDoConstRight; 4x elseif IPPfield = 'Num EditCode'; exsr srDoEditCodeRight; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // load edit coded field with no EndPos or + EndPos. // The EditedDS field is end result of an API edit mask apply. // Blanks and zeros are filtered out. Also, filter // decimal point '.' from zero decimal numbers. begsr srDoEditCodeLeft; exsr srGetEditCode; LoadNamFlg = 'Start FldNam'; 1b for xm = 1 to 40; 2b if (EditedDS.EditedArry(xm) > ' ' and EditedDS.EditedArry(xm) <> '0'); 3b if (DecimalPos = 0 and EditedDS.EditedArry(xm) = '.'); 3x else; EndPosX += 1; 4b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 4e endif; %subst(Layout: EndPosx:1) = EditedDS.EditedArry(xm); 3e endif; 2e endif; 2b if EndPosX = 198; 1v leave; 2e endif; 1e endfor; LastEndPos = EndPosX; //reset last end pos endsr; //--------------------------------------------------------- // load edit coded field with end positions. // Start at end position and work backwards. begsr srDoEditCodeRight; exsr srGetEditCode; LastEndPos = EndPosX; EndPosX += 1; 1b for xa = 40 downto 1; 2b if (EditedDS.EditedArry(xa) > ' ' and EditedDS.EditedArry(xa) <> '0'); 3b if (DecimalPos = 0 and EditedDS.EditedArry(xa) = '.'); 3x else; EndPosX -= 1; %subst(Layout: EndPosx:1) = EditedDS.EditedArry(xa); 3e endif; 2e endif; 1e endfor; // set variables to load field name into print arrays xi = EndPosX - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = EndPosX; 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(SrcDS.oConstant: xm: 1) = qs; 1v leave; 2e endif; EndPosX += 1; 2b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 2e endif; 2b if %subst(SrcDS.oConstant: xm: 1) = ' ' and IPPfield = 'Num EditWord'; 3b if FieldsAttrDS.DataType = 'D'; %subst(Layout: EndPosx:1) = 'D'; 3x elseif FieldsAttrDS.DataType = 'Z'; %subst(Layout: EndPosx:1) = 'Z'; 3x elseif FieldsAttrDS.DataType = 'T'; %subst(Layout: EndPosx:1) = 'T'; 3x else; 4b if EndPosX <= 198; %subst(Layout: EndPosx:1) = '9'; //load edited field 4e endif; 3e endif; 2x else; 3b if EndPosX <= 198; %subst(Layout: EndPosx:1) = %subst(SrcDS.oConstant: xm: 1); 3e endif; 2e endif; 2b if EndPosX >= 198; 1v leave; 2e endif; 1e endfor; LastEndPos = EndPosX; endsr; //--------------------------------------------------------- // Constants or Edit worded fields. // Start at end position and work backwards. // RPG output constant uses two single quotes to print single quote // Replace two single quotes with single quote before calculating length of constant. begsr srDoConstRight; LastEndPos = EndPosX; IsContinuation = *off; xe = %scan(qs + qs: SrcDS.oConstant: 2); 1b dow xe > 0; SrcDS.oConstant = %replace(qs: SrcDS.oConstant: xe: 2); xe = %scan(qs + qs: SrcDS.oConstant: xe + 1); 1e enddo; //----------------------------------------------------------------- // The idea here is load all continued lines into a long string // then load that string into the output array. For every line ending // in a + sign, need to remove all spaces but one and remove the + sign. //----------------------------------------------------------------- aa = %checkr(' ': SrcDS.oConstant); 1b if %subst(SrcDS.oConstant:aa:1) = '+'; %len(BuildContin) = 0; BuildContin = %trim(%subst(SrcDS.oConstant:2:aa-2)) + ' '; 2b dou IsContinuation = *off; read RPGSRC; aa = %checkr(' ': SrcDS.oConstant); 3b if %subst(SrcDS.oConstant:aa:1) = '+'; BuildContin = BuildContin + %trim(%subst(SrcDS.oConstant:1:aa-1)) + ' '; IsContinuation = *on; 3x else; BuildContin = BuildContin + %trim(%subst(SrcDS.oConstant:1:aa-1)); IsContinuation = *off; bb = %len(BuildContin); 4b for EndPosX = LastEndpos by 1 downto (LastEndPos - (%len(BuildContin)-1)); %subst(Layout: EndPosx:1) = %subst(BuildContin: bb: 1); bb -= 1; 4e endfor; 3e endif; 2e enddo; 1x else; //----------------------------------------------------------------- xe = %checkr(' ': SrcDS.oConstant); EndPosX += 1; 2b for xa = (xe - 1) downto 2; EndPosX -= 1; 3b if %subst(SrcDS.oConstant: xa: 1) = ' ' and IPPfield = 'Num EditWord'; 4b if FieldsAttrDS.DataType = 'D'; %subst(Layout: EndPosx:1) = 'D'; 4x elseif FieldsAttrDS.DataType = 'Z'; %subst(Layout: EndPosx:1) = 'Z'; 4x elseif FieldsAttrDS.DataType = 'T'; %subst(Layout: EndPosx:1) = 'T'; 4x else; %subst(Layout: EndPosx:1) = '9'; //load edited field 4e endif; 3x else; %subst(Layout: EndPosx:1) = %subst(SrcDS.oConstant: xa: 1); 3e endif; 2e endfor; 1e endif; // set variable to load field name. 1b if SrcDS.oEname > *blanks; xi = EndPosX - 1; 2b if xi <= 0; xi = 1; 2e endif; xk = EndPosX; exsr srStagger; 1e endif; endsr; //--------------------------------------------------------- // load edit coded field with end positions. begsr srAlphaRight; LastEndPos = EndPosX; EndPosX += 1; 1b for ForCount = 1 to FieldsAttrDS.Length; EndPosX -= 1; %subst(Layout: EndPosx:1) = 'X'; //load edited field 1e endfor; // set variables to load field name. xi = EndPosX - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = EndPosX; exsr srStagger; endsr; //--------------------------------------------------------- // Process alpha fields with no end positions or + positioning. load from front begsr srDoAlphaLeft; xk = EndPosX + 1; xi = xk - 1; 1b if xi <= 0; xi = 1; 1e endif; exsr srStagger; // Load 'X's to positionally represent alpha field. 1b for ForCount = 1 to FieldsAttrDS.Length; EndPosX += 1; 2b if EndPosX <= 198; %subst(Layout: EndPosx:1) = 'X'; 2x else; 1v leave; 2e endif; 1e endfor; LastEndPos = EndPosX; endsr; //--------------------------------------------------------- // Set values to load field name for this time variable. begsr srLoadFieldName; xi = EndPosX - 1; 1b if xi <= 0; xi = 1; 1e endif; xk = EndPosX; exsr srStagger; LoadNamFlg = 'Reset '; endsr; //--------------------------------------------------------- // Formatted2 & Formatted3 business is to stagger field names if short length fields. // 9 99 9 // Fieldname 1 // Fieldname 2 // Fieldname 3 // 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 entire field name. //--------------------------------------------------------- begsr srStagger; xo = %len(%trimr(SrcDS.oEname)); 1b if(m) (198 - (xk - 1)) < xo; xo = (198 - (xk - 1)); 1e endif; 1b for cc = 1 to 10; 2b if %subst(StaggerNam(cc): xi: xo + 1) = *blanks; 3b if xk <= 198; %subst(StaggerNam(cc): xk: xo) = SrcDS.oEname; 3e endif; 3b if cc > StaggerDepth; StaggerDepth = cc; 3e endif; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Get field name attributes. If field name, then look up array to get attributes. begsr srGetFieldAttr; 1b if SrcDS.oConstant > *blanks and SrcDS.oEname = *blanks; IPPfield = 'Constant '; 1x else; SrcDS.oEname = %xlate(lo: up: SrcDS.oEname); //--------------------------------------------------------- // There could be an indexed array name as an output field. // Do lookup with array name to get attributes. LookupName = SrcDS.oEname; xa = %scan('(': LookupName: 1); 2b if xa <> 0; LookupName = %subst(LookupName: 1: xa - 1); 2e endif; xa = %lookup(LookupName: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 2b if xa > 0; FieldsAttrDS = FieldsAttrArry(xa); 3b if FieldsAttrDS.DecimalPos = *blanks; DecimalPos = 0; 3x else; DecimalPos = FieldsAttrDS.DecimalPosN; 3e endif; //--------------------------------------------------------- // Back to array fun! It could be that an // that an un-indexed array name was coded on output. // The JCRGETFLDR program loads array definitions // in two parts. Multiply element length by num elements. xg = %scan('DIM(': FieldsAttrDS.Text: 1); 3b if xg <> 0 and LookupName = SrcDS.oEname //not indexed and %subst(LookupName:1:3) <> 'TAB'; xf = %scan(')': FieldsAttrDS.Text: xg); 4b if xf <> 0; //end of ) xd = (xf - 1) - 4; xh = (6 - xd); DimSizeVal = *blanks; %subst(DimSizeVal: xh: xd) = %subst(FieldsAttrDS.Text: 5: xd); 5b if DimSizeVal = *blanks; DimSizeVal = '00000'; 5e endif; // make numeric FieldsAttrDS.Length = FieldsAttrDS.Length * %uns(DimSizeVal); 4e endif; 3e endif; //--------------------------------------------------------- 3b if FieldsAttrDS.DataType = 'A'; IPPfield = 'Alpha Field '; //--------------------------------------------------------- // New to O specs is ability to format date, time and // and timestamp fields. I have decided best way to // handle it would be to dummy up field length // and create fake edit word based on type field and // and type formatting selected. 3x elseif FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; IPPfield = 'Num EditWord'; SrcDS.oConstant = f_FakeEditWord(SrcDS.oConstant: FieldsAttrDS.DataType); 3x else; 4b if SrcDS.oConstant > *blanks and SrcDS.oEditCode = ' '; IPPfield = 'Num EditWord'; 4x else; IPPfield = 'Num EditCode'; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Fill whole number part of number. // Number of decimals is subtracted from field length to get number // of digits in whole number. Correct amount of zeros and nines // are loaded into field // End result for 9,2 field would be 000000000000009999999 // NOTE: Y editcodes are always 99/99/99. begsr srGetEditCode; 1b if SrcDS.oEditCode = 'Y' or SrcDS.oEditCode = 'y'; EditedDS = ' 99/99/99 '; 2b if FieldsAttrDS.Length = 8; EditedDS = ' 99/99/9999 '; 2e endif; 1x else; IntegerLength = FieldsAttrDS.Length - DecimalPos; WholePart = %subst(AllZeros: 1: (%size(WholePart) - IntegerLength)) + %subst(AllNines: 1: IntegerLength); //--------------------------------------------------------- // this expression is used to load decimal part. // Number of decimal places is used to load up left side // side of field with 9's and fill out remainder with zeros. // End result for 9,2 field would be 990000000 2b if DecimalPos = 0; DecimalPart = *all'0'; 2x else; DecimalPart = %subst(AllNines: 1: DecimalPos) + %subst(AllZeros: DecimalPos + 1: %size(DecimalPart) - DecimalPos); 2e endif; //--------------------------------------------------------- // Make negative numeric so edit code application can generate max size. v30_9DS = WholePart + DecimalPart; v30_9Dec = -(v30_9DS.v30_9Zoned); //make negative packed 2b if SrcDS.oEditCode = ' '; //Use 'Z' so mapper will work SrcDS.oEditCode = 'Z'; 2x else; SrcDS.oEditCode = %xlate(lo: up: SrcDS.oEditCode); 2e endif; // Create edit mask required to apply edit code. callp QECCVTEC( ReceiverVar: EditMaskLen: ReceiverVarLen: ' ': SrcDS.oEditCode: ' ': 30 : 9 : ApiErrDS); EditMask = ReceiverVar; //--------------------------------------------------------- // Apply edit mask generated by edit code // note: if you are using leading 0 suppress in front of // constant, then you must make field length parm 1 // bigger than actual value of field. clear ReceiverVar; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec : '*PACKED': 30 : EditMask: EditMaskLen: ' ': ApiErrDS); //--------------------------------------------------------- // If API doesn't apply user defined edit codes, it returns blank. // Next 3 lines will at least load length of field // so it will show on report. 2b if ReceiverVar = *blanks; //could not apply ReceiverVar = %subst(AllNines: 2: FieldsAttrDS.Length); 2e endif; EditedDS = ReceiverVar; // Load if field has floating $ sign. 2b if SrcDS.oConstant = FloatDollar; xe = %scan('9': EditedDS: 1); 3b if xe > 1; xe -= 1; %subst(EditedDS: xe: 1) = '$'; 3e endif; 2e endif; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRANZORV - Validity checking program for lib/file/member // also check to see if internal print file is defined. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn //--*COPY DEFINES------------------------------------------ /Define Constants /Define f_GetQual /Define f_IsValidMbrType /Define f_SndEscapeMsg /Define SrcDS /COPY JCRCMDS,JCRCMDSCPY D IsPrinter s n //--*ENTRY PARMS------------------------------------------- D p_JCRANZORV PR extpgm('JCRANZORV ') D 10a D 20a D p_JCRANZORV PI D p_SrcMbr 10a D p_SrcFilQual 20a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 112 SrcDS /free 1b if not f_IsValidMbrType(p_SrcFilQual: p_SrcMbr: 'RPGLE ': 'SQLRPGLE '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(p_SrcMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; // only read F specs extIfile = f_GetQual(p_SrcFilQual); open RPGSRC; read RPGSRC; 1b dow not %eof; // finished with F specs 2b if SrcDS.SpecType = 'C' or SrcDS.SpecType = 'c' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'd' or SrcDS.SpecType = 'O' or SrcDS.SpecType = 'o' or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'p' or SrcDS.SlashComment = '/f' or SrcDS.SlashComment = '/F' or SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c'; 1v leave; 2e endif; 2b if SrcDS.SpecType = 'F' or SrcDS.SpecType = 'f'; 3b if (%xlate(lo: up: SrcDS.fEorF) = 'F' and %xlate(lo: up: SrcDS.fDevice) = 'PRINTER') or (SrcDS.fEorF3 = 'F' and SrcDS.fDevice3 = 'PRINTER'); IsPrinter = *on; 1v leave; 3e endif; 2e endif; read RPGSRC; 1e enddo; close RPGSRC; 1b if not IsPrinter; f_SndEscapeMsg('*ERROR* Member ' + %trimr(p_SrcMbr) + ' does not have internal PRINTER specification.'); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRANZP - PRTF layout with field names report - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print PRTF Field Report Layout') PARM KWD(PRTF) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('PRTF source member name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QDDSSRC) SPCVAL((QDDSSRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(LAYOUTONLY) TYPE(*CHAR) LEN(4) RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Include rcdfmts & fld names:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRANZPC - PRTF layout with field names report - CMDPGM */ /* Target prtf is compiled to get expanded section. */ /* Spooled file generated by compile is copied to data file. */ /* File is read by RPG program to generate report layout */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &FILE_LIB &LAYOUTONLY &OUTPUT) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&FILE_LIB) TYPE(*CHAR) LEN(20) DCL VAR(&LAYOUTONLY) TYPE(*CHAR) LEN(4) DCL VAR(&FILE) TYPE(*CHAR) LEN(10) DCL VAR(&LIB) TYPE(*CHAR) LEN(10) DCL VAR(&TEXT) TYPE(*CHAR) LEN(50) DCL VAR(&OUTPUT) TYPE(*CHAR) LEN(8) CHGVAR VAR(&FILE) VALUE(%SST(&FILE_LIB 1 10)) CHGVAR VAR(&LIB) VALUE(%SST(&FILE_LIB 11 10)) RTVMBRD FILE(&LIB/&FILE) MBR(&MBR) RTNLIB(&LIB) TEXT(&TEXT) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('Expanded source list generation + for ' *CAT &MBR *TCAT ' ' *CAT &LIB *TCAT + '/' *CAT &FILE *TCAT ' - in progress') + TOPGMQ(*EXT) MSGTYPE(*STATUS) DLTF FILE(QTEMP/&FILE) MONMSG MSGID(CPF0000) OVRPRTF FILE(&FILE) HOLD(*YES) CRTPRTF FILE(QTEMP/&FILE) SRCFILE(&LIB/&FILE) + SRCMBR(&MBR) PAGESIZE(66 198) CPI(15) MONMSG MSGID(CPF7302) EXEC(DO) /* NO COMPILE */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Compile + of original source code failed - Please + correct source errors') TOPGMQ(*EXT) RETURN ENDDO SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Field + Position print - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) CRTPF FILE(QTEMP/DDSLIST) RCDLEN(132) SIZE(*NOMAX) MONMSG MSGID(CPF0000) CPYSPLF FILE(&FILE) TOFILE(QTEMP/DDSLIST) SPLNBR(*LAST) MBROPT(*REPLACE) DLTSPLF FILE(&FILE) SPLNBR(*LAST) DLTOVR FILE(&FILE) CALL PGM(JCRANZPR) PARM(&MBR &FILE &LIB &TEXT &LAYOUTONLY &OUTPUT) DLTF FILE(QTEMP/&FILE) ENDPGM ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRANZP'.Print PRTF Field Report Layout (JCRANZP) - Help .*-------------------------------------------------------------------- :P.This JCR command reads your PRTF source to provide layout report with field name printed under the data positions. :P.The LayoutOnly keyword was added to allow printing of layout without print line data and field names. This is used to show user prototype layout. :P.The command generates Expanded Data listing by compiling selected source member. RPG program uses this expanded listing to generate field name report. :NT.You must have all referenced files used by print file in your library list to execute command.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRANZP/PRTF'.PRTF source member name (PRTF) - Help :XH3.PRTF source member name (PRTF) :P.PRTF for which field list is to be printed.:EHELP. :HELP name='JCRANZP/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source PRTF member.:EHELP. :HELP name='JCRANZP/LAYOUTONLY'.Include Record Formats & Field Names - Help :XH3.Exclude Record Formats & Field Names (LAYOUTONLY) :P.Include record format names and field names on generated report.:EHELP. :HELP name='JCRANZP/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRANZPR - PRTF layout with field names report // read dds extended source code listing. // extract source information from spooled file. // load output arrays with positional field data and field names. // On extended listing, all printable fields have counter number on right side of // of listing. This program uses this number OR the R (format) to determine when all // information about field has been extracted. // MSGCON support. Msgdta will be retrieved from message file and printed // as normal constant. // note: shares common print file with jcranzdr and jcranzpr //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FDDSLIST if f 132 disk extfile('QTEMP/DDSLIST') FJCRANZDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D AllNines s 30a inz(*all'9') build pseudo number D AllZeros s 30a inz(*all'0') D MsgconArry s 1a dim(288) based(BlocPtr) D BlocDta s 288a all field data D Ctl_BlkTyp s 19a inz('Record Format Block') D DecimalPart s 9a D EditMask s 256a D FieldName s 10a D FirstField s 3a inz('YES') D FirstRecFm s 23a inz('YES') D FlushBuffr s 3a inz('NO ') D StaggerNam s 198a dim(15) D StaggerDepth s 3u 0 prevent name overlap D scDow s 9a D IPPfield s 12a IPP prompt data D LoadNamFlg s 14a inz('Load Name Flag') D O_EditCode s 1a extracted edit code D PrvLineNum s 3a sav line numbr D Quote s 1a inz('''') D ReceiverVar s 256a D WholePart s 21a D MapStartPos s 3a D EditMaskLen s 10i 0 D ReceiverVarLen s 10i 0 D WholeLength s 5i 0 length of whole D xb s 5i 0 D xd s 5i 0 D EndPosX s 5i 0 D xf s 5i 0 D xg s 10i 0 D xh s 5i 0 D DecimalPos s 1p 0 D v30_9Dec s 30p 9 D aFldLenNUM s 3s 0 based(aPtr) D ForCount s 5u 0 D aPtr s * inz(%addr(aFldLen)) D BlocPtr s * inz(%addr(BlocDta)) D IsExpanded s n D IsFloatDollar s n //--*DATA STRUCTURES--------------------------------------- D v30_9DS ds qualified D v30_9Zoned 30s 9 inz(0) D EditedDS ds qualified D EditedArry 1a dim(40) inz //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define f_RtvMsgApi /Define FieldsAttrDS /Define Qeccvtec /Define Qecedt /Define f_GetDayName /Define f_BuildString /Define f_FakeEditWord /Define f_OvrPrtf /Define f_DltOvr /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- // Return attributes for DDS reserved words D f_DDsReservedWords... D PR D 288a block data D 10a field name D 10u 0 field length D 2a decimal positions D 1a data type D f_MsgCon PR 288a process MSGCON D 288a //--*ENTRY PARMS------------------------------------------- D p_JCRANZPR PR extpgm('JCRANZPR') D 10a Source Member D 10a Source File D 10a Source Lib D 50a Source Text D 4a layout D 8a output D p_JCRANZPR PI D p_Mbr 10a D p_File 10a D p_Lib 10a D p_Text 50a D p_Layout 4a D p_Output 8a //--*INPUT SPECS------------------------------------------- Iddslist ns I a 2 2 aAsterick I a 2 7 aSeqno I a 26 26 aNameType I a 26 37 sRcdFmtName I a 28 37 aFldName I a 41 43 aFldLen I a 44 44 aFldType I a 45 46 aDecimalPos I a 48 50 aLineNumb I a 51 53 aStartPos I a 54 89 aConstant I a 89 89 aMinusSgn I a 30 37 aEndOfSrc I a 42 49 aHeading I a 43 50 aExpanded I a 95 95 aCompNumb //--------------------------------------------------------- /free f_OvrPrtf('JCRANZDP ': *OMIT: p_Mbr); open JCRANZDP; // Print headings. Load print position 'rulers' evalr scDow = %trimr(f_GetDayName()); scObjHead = f_BuildString('& Mbr: & & & &': 'JCRANZPR': p_Mbr: p_File: p_Lib: p_Text); write PrtHead; // load ruler to show output positions 1b for xb = 1 to 19; %subst(LayOut:xb*10:1) = %subst(%editc(xb: '3'): 5: 1); 1e endfor; write PrtLine; LayOut = *all'1234567890'; write PrtLine; LayOut = *all'-'; write PrtLine; //--------------------------------------------------------- read ddslist; 1b dow not(%eof(ddslist)); 2b if aExpanded = 'Expanded'; IsExpanded = *on; 2e endif; 2b if IsExpanded and aHeading <> 'Data Des' and aSeqno > ' 0' and aSeqno < '999900' and aSeqno <> 'SEQNBR' and aAsterick <> '*'; //--------------------------------------------------------- // 'R' or aCompNumb determine either new record format or new // field has started. // 'R' print of previous block and start of new block 3b if aNameType = 'R'; Ctl_BlkTyp = ('Record Format Block'); FirstField = 'YES'; 4b if FirstRecFm = 'Not first record format'; FlushBuffr = 'YES'; 5b if FieldName > *blanks or BlocDta > *blanks; exsr srChkPrevBlk; //Flush existing buffer 5e endif; FlushBuffr = 'NO '; 4e endif; //--------------------------------------------------------- // print this record format name LayOut = *blanks; 4b if p_LayOut = '*YES'; LayOut = *all'_'; %subst(LayOut:2:12) = %xlate(' ':'_':sRcdFmtName); 4e endif; write PrtLine; LayOut = *blanks; FirstRecFm = 'Not first record format'; //--------------------------------------------------------- // Printable field or constant is detected if there // is value in aCompNumb. It 1) signals all records have // been read for previous field and should be processed. // 2) load field data for current field. 3x elseif aCompNumb > *blanks; 4b if FirstField = 'NO '; exsr srChkPrevBlk; 4e endif; FirstField = 'NO '; Ctl_BlkTyp = ('Field Data Block '); //reset exsr srLoadFieldData; 4b if aMinusSgn = '-'; //continuation sign %subst(aConstant: 36: 1) = ' '; //remove 4e endif; BlocDta = aConstant; 3x else; //--------------------------------------------------------- // load constant data between fields. // Multiple records can be applicable to one field. 4b if Ctl_BlkTyp = ('Field Data Block '); 5b if aMinusSgn = '-'; %subst(aConstant: 36: 1) = ' '; //remove 5e endif; 5b if FieldName > *blanks or BlocDta = 'PAGNBR ' or BlocDta = 'DATE ' or BlocDta = 'DATE(*SYS)' or BlocDta = 'DATE(*JOB)' or BlocDta = 'DATE(*YY)' or BlocDta = 'DATE(*Y)' or BlocDta = 'DATE(*SYS)' or BlocDta = 'TIME '; BlocDta = %trimr(BlocDta) + ' ' + aConstant; 5x else; BlocDta = %trimr(BlocDta) + aConstant; 5e endif; 4e endif; 3e endif; 2e endif; read ddslist; //--------------------------------------------------------- // 'E N D' signifies end of listing. Print last line. 2b if aEndOfSrc = 'E N D '; FlushBuffr = 'YES'; exsr srChkPrevBlk; 1v leave; 2e endif; 1e enddo; close JCRANZDP; f_DltOvr('JCRANZDP '); f_DspLastSplf('JCRANZPR ': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Determine if LINE SPACING event is about to occur. // If No SpaceB or SkipB, then load // field into current field line. If there is // Space/Skip before, print current // line, reset all values. Start with this field on new line. begsr srChkPrevBlk; 1b if %scan('SPACEB(': BlocDta) > 0 or %scan('SKIPB(': BlocDta) > 0; write prtLine; //print data for previous line 2b if p_LayOut = '*YES'; 3b for cc = 1 to StaggerDepth; LayOut = StaggerNam(cc); write PrtLine; 3e endfor; 2e endif; clear Layout; StaggerDepth = 0; StaggerNam(*) = *blanks; EndPosX = 0; 1e endif; // Determine what type of field. clear IPPfield; clear O_EditCode; xb = 0; // check for reserved word 1b if FieldName = *blanks; f_DDsReservedWords( BlocDta: FieldName: FieldsAttrDS.Length: FieldsAttrDS.DecimalPos: FieldsAttrDS.DataType); 1e endif; 1b if FieldName = *blanks; IPPfield = 'Constant '; xb = %scan(Quote: BlocDta); xb += 1; 1x elseif FieldsAttrDS.DataType = 'A'; IPPfield = 'Alpha Field '; 1x else; //--------------------------------------------------------- // Extract either starting position to edit word/edit code. // I have decided best way to handle date,time,stamp // type data is to create fake edit word based on type // field and type formatting selected. //--------------------------------------------------------- 2b if FieldsAttrDS.DataType = 'L' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; blocdta = 'EDTWRD(' + %trimr(f_FakeEditWord(blocdta: FieldsAttrDS.DataType)) + ')'; 2e endif; xb = %scan('EDTWRD(': BlocDta); 2b if xb > 0 ; IPPfield = 'Num EditWord'; xb = 9; 2x else; //--------------------------------------------------------- // extract edit code. Check for floating dollar sign. clear O_EditCode; IsFloatDollar = *off; xb = %scan('EDTCDE(': BlocDta); 3b if xb > 0; O_EditCode = %subst(BlocDta: xb + 7: 1); xb = %scan('$': BlocDta: xb + 8); 4b if xb > 0; IsFloatDollar = *on; 4e endif; 3e endif; IPPfield = 'Num EditCode'; 2e endif; 1e endif; //--------------------------------------------------------- // load data into print array exsr srFieldLoad; //--------------------------------------------------------- // If there is space after, print, then reset all values // Or if current Line number does not equal previous line number. 1b if FlushBuffr = 'YES' or FlushBuffr = 'NO ' AND (PrvLineNum <> aLineNumb or %scan('SPACEA(': BlocDta) > 0 or %scan('SKIPA(': BlocDta) > 0); write prtLine; 2b if p_LayOut = '*YES'; 3b for cc = 1 to StaggerDepth; LayOut = StaggerNam(cc); write PrtLine; 3e endfor; 2e endif; clear Layout; StaggerDepth = 0; StaggerNam(*) = *blanks; EndPosX = 0; 1e endif; endsr; //--------------------------------------------------------- // load field name data. begsr srLoadFieldData; clear FieldsAttrDS; clear FieldName; clear DecimalPos; 1b if aFldName > *blanks; FieldName = aFldName; FieldsAttrDS.Length = aFldLenNum; FieldsAttrDS.DecimalPos = aDecimalPos; FieldsAttrDS.DataType = aFldType; 2b if FieldsAttrDS.DecimalPos = *blanks; DecimalPos = 0; 2x else; DecimalPos = FieldsAttrDS.DecimalPosN; 2e endif; 1e endif; MapStartPos = aStartPos; PrvLineNum = aLineNumb; endsr; //--------------------------------------------------------- // load data into print array begsr srFieldLoad; 1b if MapStartPos = *blanks; EndPosX = 0; 1x else; EndPosX = %uns(MapStartPos); 1e endif; EndPosX -= 1; 1b if EndPosX < 199; 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; 1e endif; endsr; //--------------------------------------------------------- // EditedDS field is end result of API edit mask apply. // Blanks and zeros are filtered out. Also, filter // decimal point '.' from zero decimal numbers. begsr srDoEditCodeLeft; //--------------------------------------------------------- // Fill whole number part of number. // Number of decimals is subtracted from field length to get number // of digits in whole number. Correct amount of zeros and nines // are loaded into field // End result for 9,2 field would be 000000000000009999999 // NOTE: Y editcodes are always 99/99/99. 1b if O_EditCode = 'Y'; EditedDS = ' 99/99/99 '; 2b if FieldsAttrDS.Length = 8; EditedDS = ' 99/99/9999 '; 2e endif; 1x else; WholeLength = FieldsAttrDS.Length - DecimalPos; WholePart = %subst(AllZeros: 1: (%size(WholePart) - WholeLength)) + %subst(AllNines: 1: WholeLength); //--------------------------------------------------------- // this expression is used to load decimal part. // Number of decimal places is used to load up left side // side of field with 9's and fill out remainder with zeros. // End result for 9,2 field would be 990000000 2b if DecimalPos = 0; DecimalPart = *all'0'; 2x else; DecimalPart = %subst(AllNines: 1: DecimalPos) + %subst(AllZeros: DecimalPos + 1: %size(DecimalPart) - DecimalPos); 2e endif; //--------------------------------------------------------- // Make negative numeric so edit code application // can generate max size. v30_9DS = WholePart + DecimalPart; v30_9Dec = -(v30_9DS.V30_9Zoned); //make packed negative 2b if O_EditCode = ' '; //Use 'Z' so mapper will work O_EditCode = 'Z'; 2e endif; // Create edit mask required to apply edit code. callp QECCVTEC( ReceiverVar: EditMaskLen: ReceiverVarLen: ' ': O_EditCode: ' ': 30 : 9 : ApiErrDS); EditMask = ReceiverVar; //--------------------------------------------------------- // Apply edit mask generated by edit code // see programmer interface reference // note: if you are using leading 0 suppress in front of // constant, then you must make field length parm 1 // bigger than actual value of field. clear ReceiverVar; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec : '*PACKED': 30 : EditMask: EditMaskLen: ' ': ApiErrDS); //--------------------------------------------------------- // If API doesn't apply user defined edit codes, it returns blank. // Next 3 lines will at least load length of field // so it will show on report. 2b if ReceiverVar = *blanks; ReceiverVar = %subst(AllNines: 2: FieldsAttrDS.Length); 2e endif; EditedDS = ReceiverVar; //load edited field // Load if field has floating $ sign. 2b if IsFloatDollar; xb = %scan('9': EditedDS: 1); 3b if xb > 1; xb -= 1; %subst(EditedDS: xb: 1) = '$'; 3e endif; 2e endif; 1e endif; LoadNamFlg = 'Start FldNam'; 1b for xg = 1 to 40; 2b if (EditedDS.EditedArry(xg) > ' ' and EditedDS.EditedArry(xg) <> '0'); 3b if (DecimalPos = 0 and EditedDS.EditedArry(xg) = '.'); 3x else; EndPosX += 1; 4b if EndPosX > 198; EndPosX = 198; 4e endif; 4b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 4e endif; 4b if EndPosX > 0 and EndPosX < 199; %subst(Layout: EndPosx:1) = EditedDS.EditedArry(xg); 4e endif; 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Process numeric fields that have edit words or constants. // Only difference is Edtwords have ' ' replaced with '9'. begsr srDoConstLeft; LoadNamFlg = 'Start FldNam'; //--------------------------------------------------------- // Add support for MSGCON keyword. BLOCDTA could contain // MSGCON(len msgid msgf). If it does, call function to // extract message from msgf and load into MsgconArry. 1b if %subst(BlocDta: 1: 6) = 'MSGCON'; BlocDta = f_MSGCON(BlocDta); xb = 1; 1e endif; 1b for xg = xb to 198; 2b if MsgconArry(xg) = Quote; //end of edit word 1v leave; 2e endif; EndPosX += 1; 2b if EndPosX > 198; EndPosX = 198; 2e endif; 2b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 2e endif; 2b if MsgconArry(xg) = ' ' and IPPfield = 'Num EditWord'; 3b if FieldsAttrDS.DataType = 'L'; %subst(Layout: EndPosx:1) = 'D'; 3x elseif FieldsAttrDS.DataType = 'Z'; %subst(Layout: EndPosx:1) = 'Z'; 3x elseif FieldsAttrDS.DataType = 'T'; %subst(Layout: EndPosx:1) = 'T'; 3x else; %subst(Layout: EndPosx:1) = '9'; //load edited field 3e endif; 2x else; %subst(Layout: EndPosx:1) = MsgconArry(xg); 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Process alpha fields with no end positions or + positioning. begsr srDoAlphaLeft; xh = EndPosX - 1; 1b if xh <= 0; xh = 1; 1e endif; xf = EndPosX + 1; exsr srStagger; // Load 'X's to positionally represent alpha field. 1b for ForCount = 1 to FieldsAttrDS.Length; EndPosX += 1; 2b if EndPosX < 1 or EndPosX > 198; 1v leave; 2e endif; %subst(Layout: EndPosx:1) = 'X'; 1e endfor; endsr; //--------------------------------------------------------- // Load field names under data representations. begsr srLoadFieldName; xh = EndPosX - 1; 1b if xh <= 0; xh = 1; 1e endif; xf = EndPosX; exsr srStagger; LoadNamFlg = 'Reset '; endsr; //--------------------------------------------------------- // 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 132. // example: Field a123456789 is in position 131, there is not // enough room to load entire field name. begsr srStagger; xd = %len(%trimr(FieldName)); 1b if xf <= 0; xf = 1; 1e endif; 1b if(m) (198 - (xf - 1)) < xd; xd = (198 - (xf - 1)); 1e endif; 1b for cc = 1 to 10; 2b if %subst(StaggerNam(cc): xh: xd + 1) = *blanks; 3b if xf <= 198; %subst(StaggerNam(cc): xf: xd) = FieldName; 3e endif; 3b if cc > StaggerDepth; StaggerDepth = cc; 3e endif; 1v leave; 2e endif; 1e endfor; endsr; /end-free //--------------------------------------------------------- // Changes parms to match attributes of DDS reserved field names P f_DDsReservedWords... P B export D f_DDsReservedWords... D PI D BlocDta 288a block data D FieldName 10a field name D MapFldLength 10u 0 field length D MapDecPos 2a decimal positions D MapDtaTyp 1a data type D QuotePos1 s 5u 0 D QuotePos2 s 5u 0 D xg s 10i 0 D Quote c const('''') single Quote //--------------------------------------------------------- // I don't know why IBM did not make reserved words // (PAGE DATE PAGNBR) to be field names. It makes them difficult to // extract. Real problem is when words are part of constant. // ('Work DATE') // Method I used is to see if either reserved word is in // first position or not between two ' '. /free 1b if %subst(BlocDta: 1: 7) = 'PAGNBR '; FieldName = 'PAGNBR '; MapFldLength = 4; MapDecPos = '00'; MapDtaTyp = 'S'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 5) = 'USER '; FieldName = 'USER '; MapFldLength = 10; MapDecPos = '00'; MapDtaTyp = 'S'; 1x elseif %subst(BlocDta: 1: 8) = 'SYSNAME '; FieldName = 'SYSNAME'; MapFldLength = 8; MapDecPos = '00'; MapDtaTyp = 'S'; 1x elseif %subst(BlocDta: 1: 5) = 'DATE ' or %subst(BlocDta: 1: 10) = 'DATE(*SYS)' or %subst(BlocDta: 1: 10) = 'DATE(*JOB)' or %subst(BlocDta: 1: 8) = 'DATE(*Y)'; FieldName = 'DATE '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 9) = 'DATE(*YY)'; FieldName = 'DATE '; MapFldLength = 8; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x elseif %subst(BlocDta: 1: 5) = 'TIME '; FieldName = 'TIME '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; exsr srMoveEditWord; 1x else; //--------------------------------------------------------- // Find position of Quotes (if any) QuotePos2 = 0; QuotePos1 = %scan(Quote: BlocDta); 2b if QuotePos1 > 0; QuotePos2 = %scan(Quote: BlocDta: QuotePos1 + 1); 2e endif; xg = %scan(' PAGNBR ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'PAGNBR '; MapFldLength = 4; MapDecPos = '00'; MapDtaTyp = 'S'; 3e endif; 2e endif; xg = %scan(' TIME ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'TIME '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; 3e endif; 2e endif; xg = %scan(' DATE ': BlocDta); 2b if xg > 0; 3b if (QuotePos1 = 0 and QuotePos2 = 0) OR (xg < QuotePos1 or xg > QuotePos2); FieldName = 'DATE '; MapFldLength = 6; MapDecPos = '00'; MapDtaTyp = 'P'; 3e endif; 2e endif; 1e endif; return; //--------------------------------------------------------- begsr srMoveEditWord; xg = %scan(' ': BlocDta: 5); 1b if xg > 0; BlocDta = %subst(BlocDta: xg + 1); 1e endif; endsr; /End-Free P f_DDsReservedWords... P E //--------------------------------------------------------- // Returns text from dds MSGCON keyword. p f_MsgCon B D f_MsgCon PI 288a D p_BlockOfData 288a // variables for processing MSGCON keywords. D mWork s like(p_BlockOfData) D xx s 10i 0 numeric work field D yy s 10i 0 numeric work field D Msgid s 7a D MsgFile s 10a D MsgLib s 10a D replacement s 112a D MsgLengthDS ds qualified D MsgLength 7s 0 inz(0) /free //--------------------------------------------------------- // p_BlockOfData could contain MSGCON(len msgid msgf) // I assume all msgcon data will be on one line. // get Length. skip MSGCON( section and compress out spaces // placed after ( and before number starts. // Extract value and right justify it into MsgLengthDS. mWork = %triml(%subst(p_BlockOfData: 8)); //left justify xx = %scan(' ': mWork: 1); //find 1st blank %subst(MsgLengthDS: 7-(xx - 2): xx - 1) = %subst(mWork: 1: xx - 1); 1b if MsgLengthDS = *blanks; MsgLengthDS.MsgLength = 0; 1e endif; 1b if MsgLengthDS.MsgLength > 130; //force validity MsgLengthDS.MsgLength = 130; 1e endif; //--------------------------------------------------------- // get MSGID. Use where LEN ends as starting place to extract MSGID. // This will fairly easy as ID is 7 long. mWork = %triml(%subst(mWork: xx)); Msgid = %subst(mWork: 1: 7); //--------------------------------------------------------- // get MSGF. Msgf could be qualified LIB/MSGF or not. // Start where MSGID ends and compress over to MSGF value. // // Determine where string ends. It could be either // MSGF) and it would end at ) or // MSGF ) and it would end at first ' '. // yy (end string) is set to where MSGF actually ends. mWork = %triml(%subst(mWork: 8)); //start at msgf yy = %scan(')': mWork); //find closing ) xx = %scan(' ': (%subst(mWork: 1: yy))); //find last ' ' 1b if xx <> 0; //didn't find one 2b if xx < yy; //find lowest yy = xx; 2e endif; 1e endif; yy -= 1; //last pos of string //--------------------------------------------------------- // Now determine if string is qualified (lib/File) name // or just msgf name. xx = %scan('/': mWork); //qualified? 1b if xx = 0; //is not qualified MsgFile = %subst(mWork: 1: yy); MsgLib = '*LIBL'; 1x else; // if it is Qualified, extract qualified (lib/file) names. MsgFile = %subst(mWork: xx + 1: yy - xx); MsgLib = %subst(mWork: 1: xx - 1); 1e endif; return %trimr(f_RtvMsgApi(Msgid: Replacement: MsgFile + MsgLib)) + qs; /end-free p f_MsgCon E ]]> v5r4 //--------------------------------------------------------- // JCRANZPRV - Validity checking program for lib/file/member //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_IsValidMbrType /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRANZPRV PR extpgm('JCRANZPRV ') D 10a D 20a D p_JCRANZPRV PI D p_SrcMbr 10a D p_SrcFilQual 20a //--------------------------------------------------------- /free 1b if not f_IsValidMbrType(p_SrcFilQual: p_SrcMbr: 'PRTF '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(p_SrcMbr) + ' is not type PRTF.'); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRBND - Procedure names list - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Procedure Names List') PARM KWD(BINDING) TYPE(BINDING) MIN(1) PROMPT('Binding Object:') BINDING: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(*BNDDIR) VALUES(*BNDDIR *SRVPGM + *MODULE) MIN(0) PGM(*YES) PROMPT('Object type:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(*PRINT *OUTFILE *) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) PROMPT('Output member options:') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or add records') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) NBRTRUE(*EQ 1) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRBND'.Procedure Names List (JCRBND) - Help .*-------------------------------------------------------------------- :P.This JCR command outputs list of procedures/symbols that are exported by selected *BNDDIR, *SRVPGM, or *MODULE.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRBND/BINDING'.Binding Object - Help :XH3.Binding Object (BINDING) :P.Name/generic*/*ALL and library of binding object (binding directory, service program, or module) for which procedures are to be listed.:EHELP. :HELP name='JCRBND/OBJTYPE'.Object Type - Help :XH3.Object Type (OBJTYPE) :P.Object type of binding object selected.:EHELP. :HELP name='JCRBND/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print results or load into outfile or * display the spooled file.:EHELP. :HELP name='JCRBND/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library where procedure names are to be loaded.:EHELP. :HELP name='JCRBND/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.Database file member that receives output of command. :P.The possible name values are: :P.:PARML.:PT.:PK def.*FIRST:EPK. :PD.The first member in file receives output. If it does not exist, system creates member with name of file specified in :HP2.File to receive output:EHP2. prompt (OUTFILE parameter). :PT.member-name:PD.Specify name of file member that receives output. If it does not exist, the system creates it.:EPARML. :P.The possible values for how information is stored are: :P.:PARML.:PT.:PK def.*REPLACE:EPK. :PD.The system clears existing member and adds new records. :PT.*ADD:PD.The system adds new records to end of the existing records.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRBNDPF - Procedure names list - PF *---------------------------------------------------------------- A R JCRBNDPFR TEXT('Procedure Names List') A JCRBNDDIR 10A COLHDG('Binding Object') A JCRBNDDIRL 10A COLHDG('Binding Lib') A JCRSRVPGM 10A COLHDG('Service Pgm') A JCRSRVPGML 10A COLHDG('Service Lib') A JCRMODULE 10A COLHDG('Module') A JCRMODULEL 10A COLHDG('Module lib') A JCRPROC 256A COLHDG('Procedure Name') ]]> v5r4 //--------------------------------------------------------- // JCRBNDR - Procedure names list from bnddir/svcpgm/mod // determine type selected on input (bnddir,svcpgm, or module). // call list object API to load object names to user space. // call Qbnlspgm API to extract proc exports from service programs. // call Qbnlmodi API to extract symbols from modules information. // // If object is BNDDIR, must execute CL command dspbnddir to outfile to get info. // Wish there was API for that! //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRBNDPFB if e disk usropn FJCRBNDPF o e disk extfile(extOfile) extmbr(ExtOmbr) F usropn FJCRBNDRP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D extOmbr s 10a D LibObjQual s 21a D ListSpace s 20a inz('JCRBNDLST QTEMP ') D ModuleSpace s 20a inz('JCRMODULE QTEMP ') D SrvPgmSpace s 20a inz('JCRSRVPGM QTEMP ') //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Qbnlspgm /Define Quslobj /Define Qusptrus /Define UserSpaceHeaderDS /Define f_BuildString /Define f_GetQual /Define f_OvrPrtf /Define f_Dltovr /Define f_Quscrtus /Define f_Qusrobjd /Define f_SndCompMsg /Define f_SndStatMsg /Define f_System /Define f_DspLastSplf /Define f_GetDayName /Define p_JCRBNDR /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_GetBndDir PR D 10a Object D 10a Lib D f_GetSrvPgm PR D 10a Object D 10a Lib D f_GetModule PR D 10a Object D 10a Lib D f_PutPrint PR D 10a Binding Directory D 10a Lib D 10a Service Program D 10a Lib D 10a Module D 10a Lib D 256a Procedure Name D Qbnlmodi PR extpgm('QBNLMODI') list module info D 20a user space D 8a const api format D 20a const object and lib Db like(ApiErrDS) //--*ENTRY PARMS------------------------------------------- D p_JCRBNDR PI D p_ObjQual 20a D p_ObjTyp 10a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free QusrObjDS = f_QUSROBJD(p_ObjQual: p_ObjTyp: 'OBJD0200'); %subst(p_ObjQual: 11: 10) = QusrObjDS.ReturnLib; LibObjQual = f_GetQual(p_ObjQual); f_SndStatMsg(f_BuildString( 'List procedures for & type & - in progress': LibObjQual: p_ObjTyp)); // depending on output selection 1b if p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRbndpf; 1x else; f_OvrPrtf('JCRBNDRP ': *OMIT: %subst(p_ObjQual: 1: 10)); open JCRbndrp ; evalr scDow = %trimr(f_GetDayName()); scObjHead = f_BuildString('& & & &': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: p_ObjTyp: QusrObjDS.Text); 2b if p_ObjTyp = '*BNDDIR'; HeadVar = 'Bnddir Srv Pgm Lib Module ' + ' Lib Procedure Name'; 2x elseif p_ObjTyp = '*SRVPGM'; HeadVar = 'Srv Pgm Procedure Name'; 2x elseif p_ObjTyp = '*MODULE'; HeadVar = 'Module Procedure Name'; 2e endif; write PrtHead; 1e endif; GenericHeaderPtr = f_Quscrtus(ListSpace); f_Quscrtus(ModuleSpace); f_Quscrtus(SrvPgmSpace); // load object names into user space. callp QUSLOBJ( ListSpace: 'OBJL0100': p_ObjQual: p_ObjTyp: ApiErrDS); // Process objects in user space by moving pointer. QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if QuslobjDS.ObjTyp = '*BNDDIR'; f_GetBndDir(QuslobjDS.ObjNam: QuslobjDS.ObjLib); 2x elseif QuslobjDS.ObjTyp = '*SRVPGM'; f_GetSrvPgm(QuslobjDS.ObjNam: QuslobjDS.ObjLib); 2x elseif QuslobjDS.ObjTyp = '*MODULE'; f_GetModule(QuslobjDS.ObjNam: QuslobjDS.ObjLib); 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; f_System('CLRPFM JCRBNDPF'); 1b if p_Output = '*PRINT ' or p_Output = '* '; close JCRBNDRP; f_Dltovr('JCRBNDRP '); f_DspLastSplf('JCRBNDR ': p_Output); 1x elseif p_Output = '*OUTFILE'; f_SndCompMsg('File ' +%trimr(extOfile) + ' member ' + %trimr(ExtOmbr) + ' generated by JCRBND.'); 1e endif; *inlr = *on; return; /end-free //--------------------------------------------------------- // There is no system API to get bind directory // entries. (I can't imagine why not!) Anyway, // execute DSPBNDDIR command to *OUTFILE // then process outfile. P f_GetBndDir B D f_GetBndDir PI D p_ObjName 10a D p_ObjLib 10a D CmdString s 160a varying /free CmdString = 'DSPBNDDIR BNDDIR(' + %trimr(f_GetQual(p_ObjName + p_ObjLib)) + ') OUTPUT(*OUTFILE) ' + ' OUTFILE(JCRBNDPFB) OUTMBR(*FIRST *REPLACE)'; f_System(CmdString); JCRBndDir = p_ObjName; JCRBndDirL = p_ObjLib; open JCRBNDPFB; read JCRBNDPFB; 1b dow not %eof; 2b if bnobtp = '*SRVPGM'; f_GetSrvPgm(bnobnm: bnolnm); 2x elseif bnobtp = '*MODULE'; f_GetModule(bnobnm: bnolnm); 2e endif; read JCRBNDPFB; 1e enddo; close JCRBNDPFB; return; /end-free P f_GetBndDir E //--------------------------------------------------------- P f_GetSrvPgm B D f_GetSrvPgm PI D p_ObjName 10a D p_ObjLib 10a D GenericHeaderPtr... D s * inz(*null) D ForCount s 10i 0 D GenericHeader ds qualified based(GenericHeaderPtr) D OffSetToList 10i 0 overlay(GenericHeader: 125) D ListEntryCount 10i 0 overlay(GenericHeader: 133) D ListEntrySize 10i 0 overlay(GenericHeader: 137) D ListEntryDS ds qualified based(ListEntryPtr) D LengthOfName 10i 0 overlay(ListEntryDS:25) D BigProcName 256a overlay(ListEntryDS:29) /free JCRSrvPgm = p_ObjName; JCRSrvPgmL = p_ObjLib; JCRModule = *blanks; JCRModuleL = *blanks; callp QUSPTRUS( SrvPgmSpace: GenericHeaderPtr: ApiErrDS); callp QBNLSPGM( SrvPgmSpace: 'SPGL0600': p_ObjName + p_ObjLib: ApiErrDS); ListEntryPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; JCRProc = %subst(ListEntryDS.BigProcName: 1: ListEntryDS.LengthOfName); f_PutPrint( JCRBNDDIR: JCRBNDDIRL: JCRSRVPGM: JCRSRVPGML: JCRMODULE: JCRMODULEL: JCRPROC); ListEntryPtr += GenericHeader.ListEntrySize; 1e endfor; JCRSrvPgm = *blanks; JCRSrvPgmL = *blanks; return; /end-free P f_GetSrvPgm E //--------------------------------------------------------- P f_GetModule B D f_GetModule PI D p_ObjName 10a D p_ObjLib 10a D ForCount s 10i 0 D ProcNameRaw s 256a based(RawNamePtr) D GenericHeader ds qualified based(mhPtr) D OffSetToList 10i 0 overlay(GenericHeader: 125) offset to list D ListEntryCount 10i 0 overlay(GenericHeader: 133) number list entries D ListEntrySize 10i 0 overlay(GenericHeader: 137) list entry size D ListEntryDS ds qualified based(ListEntryPtr) D SizeOfThisEnt 10i 0 overlay(ListEntryDS: 1) D OffsetToProc 10i 0 overlay(ListEntryDS:29) D LengthOfName 10i 0 overlay(ListEntryDS:33) /free JCRModule = p_ObjName; JCRModuleL = p_ObjLib; callp QBNLMODI( ModuleSpace: 'MODL0300': p_ObjName + p_ObjLib: ApiErrDS); callp QUSPTRUS(ModuleSpace: mHPtr: ApiErrDS); ListEntryPtr = mHPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if ListEntryDS.LengthOfName > %size(JCRProc); ListEntryDS.LengthOfName = %size(JCRProc); 2e endif; RawNamePtr = mHPtr + ListEntryDS.OffsetToProc; JCRProc = %subst(procNameRaw: 1: ListEntryDS.LengthOfName); 2b if %subst(JCRProc: 1: 2) <> '_Q'; f_PutPrint( JCRBNDDIR: JCRBNDDIRL: JCRSRVPGM: JCRSRVPGML: JCRMODULE: JCRMODULEL: JCRPROC); 2e endif; ListEntryPtr += ListEntryDS.SizeOfThisEnt; 1e endfor; JCRModule = *blanks; JCRModuleL = *blanks; return; /end-free P f_GetModule E //--------------------------------------------------------- P f_PutPrint B D f_PutPrint PI D JCRBNDDIR 10a D JCRBNDDIRL 10a D JCRSRVPGM 10a D JCRSRVPGML 10a D JCRMODULE 10a D JCRMODULEL 10a D JCRPROC 256a /free 1b if p_Output = '*PRINT ' or p_Output = '* '; 2b if QuslobjDS.ObjTyp = '*BNDDIR'; DetailVar = JCRBNDDIR + ' ' + JCRSRVPGM + ' ' + JCRSRVPGML + ' ' + JCRMODULE + ' ' + JCRMODULEL + ' ' + JCRPROC; 2x elseif QuslobjDS.ObjTyp = '*SRVPGM'; DetailVar = JCRSRVPGM + ' ' + JCRPROC; 2x elseif QuslobjDS.ObjTyp = '*MODULE'; DetailVar = JCRMODULE + ' ' + JCRProc; 2e endif; write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; 1x elseif p_Output = '*OUTFILE'; write JCRbndpfr; 1e endif; /end-free P f_PutPrint E ]]> v5r4 *---------------------------------------------------------------- * JCRBNDRP - Procedure names list - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRBNDR' A 22'Procedure Names List' A SCDOW 9A O 110 A 120DATE EDTWRD(' / / ') A 130TIME EDTWRD(' : : ') A 140'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) A SCOBJHEAD 100A O 2SPACEA(2) A HEADVAR 195A O 2 *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A DETAILVAR 195A O 2 ]]> v5r4 //--------------------------------------------------------- // JCRBNDRV - Object validity checking program with create outfile //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /Define f_OutFileCrtDupObj /Define p_JCRBNDR /Define p_JCRBNDRV /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRBNDRV PI D p_ObjQual 20a D p_ObjTyp 10a D p_Output 8a D p_OutFileQual 20a D p_MbrOpt 22a //--------------------------------------------------------- /free f_CheckObj(p_ObjQual: p_ObjTyp); 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_MbrOpt: 'JCRBNDPF '); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRCALL - Command prompt entry parms - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Command Prompt Entry Parms') PARM KWD(PGM) TYPE(PGM) MIN(1) KEYPARM(*YES) PROMPT('Program to call:') PGM: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(SRCFIL) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source File:') PARM KWD(SRCLIB) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source Lib:') PARM KWD(SRCMBR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source Mbr:') PARM KWD(PGMATR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Program Attribute:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRCALL'.Command Prompt Entry Parms (JCRCALL) - Help .*-------------------------------------------------------------------- :P.This JCR command generates/prompts command definition created from entry field names and attributes required by selected program. :P.The generated command designates selected program as the command processing program, so you can enter parm values and execute the program if you wish. :P.After execution, generated command source is available in QTEMP/CMDSRC member JCRCALLX. :P.Conditions::UL COMPACT. :LI.Called program source code must be available for compile into QTEMP.:EUL. :P.The command uses a prompt override program (pop) to retrieve where source code was that compiled your program. The command reads a compile listing of your source code and builds command in QTEMP with keywords matching parms in your program and specifies your program as command processing program. :P.The generated command is executed, allowing you to key input parameters in command format. :NT.You must prompt JCRCALL command for POP to work properly.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRCALL/PGM'.Program to call - Help :XH3.Program to call (PGM) :P.Program and library to be called.:EHELP. :HELP name='JCRCALL/SRCFIL'.Source file - Help :XH3.Source file (SRCFIL) :P.Source file containing source.:EHELP. :HELP name='JCRCALL/SRCLIB'.Source Library - Help :XH3.Source library (SRCLIB) :P.Library where source file is located.:EHELP. :HELP name='JCRCALL/SRCMBR'.Source Member - Help :XH3.Source Member (SRCMBR) :P.Source member.:EHELP. :HELP name='JCRCALL/PGMATR'.Program attribute - Help :XH3.Program Attribute (PGMATR) :P.Type of program object.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRCALLR - Generate CMD to provide parms to called program // Generate and optionally execute command that will prompt for parms in RPG or CL program // Get program attributes from prompt override program. // A command will be created with selected program as Command Processing Pgm //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGETFLDFif f 132 disk extfile('QTEMP/JCRGETFLDF') usropn FCMDSRC o f 112 disk extfile('QTEMP/CMDSRC') F extmbr('JCRCALLX') usropn //--*STAND ALONE------------------------------------------- D p_DiagSeverity s 2a inz('00') D p_Lib s 10a D p_CPPname s 10a D SrcOut s 85a D ArryOfClParms s 11a dim(500) D WorkField s 11a D Seqnum s 6p 0 D WorkType s 5a D IsFoundVar s n D dFieldNameSav s like(SrcDS.dFieldName) D ExtendedName s like(SrcDS.Src57) D Alpha6 s 6a D ExtractTypeFlg s 6a D IsAllDone s n D IsExtractParm s n D IsProcIntFace s n //--*DATA STRUCTURES--------------------------------------- D SrcDS DS qualified inz D dFieldName 9 23a D Src57 9 65a D Asterisk 9 9a D SpecType 8 8a D EndOfSource 20 44a D ProtoProcedur 25 28a D SourceListing 27 53a D OpCode 28 37a D ResultField 52 65a D dKeyWord 46 82a D Factor1 14 27a //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define FieldsAttrDS /Define ApiErrDS /Define Constants /Define f_GetQual /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_System /Define p_JCRCALLR /Define p_JCRGETFLDR /Define p_JCRGETCLPR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRCALLR PI D p_PgmQual 20a D p_SrcFil 10a D p_SrcLib 10a D p_SrcMbr 10a D p_Pgmatr 10a //--*INPUT SPECS------------------------------------------- IJCRGETFLDFns I a 1 112 SrcDS //--------------------------------------------------------- /free p_CPPname = %subst(p_PgmQual: 1: 10); p_Lib = %subst(p_PgmQual: 11: 10); // clear create source file for temp command member f_System('DLTF FILE(QTEMP/CMDSRC)'); f_System('CRTSRCPF FILE(QTEMP/CMDSRC) MBR(JCRCALLX) RCDLEN(112)'); open CMDSRC; SrcOut = 'CMD PROMPT(' + qs + 'Entry Parms - ' + %triml(p_CPPname) + qs + ')'; Seqnum += 10; except WriteCode; 1b if %subst(p_Pgmatr: 1: 2) = 'CL'; exsr srCL; 1x elseif p_Pgmatr = 'RPGLE ' or p_Pgmatr = 'SQLRPGLE '; exsr srRPG; 1e endif; close JCRGETFLDF; close CMDSRC; // create command object and execute f_System('DLTCMD CMD(QTEMP/JCRCALLX)'); f_System('CRTCMD CMD(QTEMP/JCRCALLX) ' + 'PGM(' + f_GetQual(p_CPPname + p_Lib) + ') SRCFILE(QTEMP/CMDSRC) SRCMBR(JCRCALLX)' ); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('CrtCmd Failed. Check source JCRCALLX + in QTEMP/CMDSRC.'); 1e endif; f_System('?QTEMP/JCRCALLX'); f_SndCompMsg('JCRCALL parm processing for ' + %trimr(f_GetQual(p_CPPname + p_Lib)) + ' - completed'); *inlr = *on; return; //--------------------------------------------------------- // Get field attributes from JCRGETFLDR // Read compile listing generated by called program. // Find *ENTRY factor 1 or MAIN procedure // Extract parm field names and get attributes from imported arrays // Generate CMD source code //--------------------------------------------------------- begsr srRPG; // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity); 1b if DiagSeverity > '20'; *inlr = *on; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; //--------------------------------------------------------- open JCRGETFLDF; 1b dou SrcDS.SourceListing = 'S o u r c e L i s t i n g'; read JCRGETFLDF; 1e enddo; read JCRGETFLDF; 1b dow not %eof; 2b if not(SrcDS.Asterisk = '/' //or SrcDS.Asterisk = '+' or SrcDS.Asterisk = '*'); SrcDS = %xlate(lo: up: SrcDS); // Check for conditions that indicate all parms are processed. IsAllDone = *off; // compile time array or 1st Ospec will exit program. 3b if SrcDS.EndOfSource = 'E N D O F S O U R C E' or SrcDS.SpecType = 'O'; IsAllDone = *on; 3e endif; 3b if ExtractTypeFlg = 'MAIN ' and (SrcDS.SpecType = 'C' or SrcDS.SpecType = 'I' or (SrcDS.SpecType = 'D ' and SrcDS.ProtoProcedur > *blanks)); IsAllDone = *on; 3e endif; 3b if ExtractTypeFlg = '*ENTRY' and ((SrcDS.SpecType = 'C' and SrcDS.OpCode <> 'PARM ') or SrcDS.SpecType = 'O '); IsAllDone = *on; 3e endif; 3b if IsAllDone; 1v leave; 3e endif; 3b if not IsExtractParm; exsr srDeterminePEP; 3x else; exsr srDoParmFields; 3e endif; 2e endif; read JCRGETFLDF; 1e enddo; endsr; //--------------------------------------------------------- begsr srDoParmFields; 1b if ExtractTypeFlg = 'MAIN ' and SrcDS.SpecType = 'D'; aa = %scan(' ': %triml(SrcDS.Src57): 1); SrcDS.ResultField = %subst(%triml(SrcDS.Src57): 1: aa - 1); SrcDS.OpCode = 'PARM '; 1e endif; 1b if SrcDS.OpCode = 'PARM '; aa = %lookup(SrcDS.ResultField: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 2b if aa = 0; p_DiagSeverity = '99'; close JCRGETFLDF; *inlr = *on; return; 2e endif; FieldsAttrDS = FieldsAttrArry(aa); //--------------------------------------------------------- // write out command source SrcOut = 'PARM KWD(' + %subst(SrcDS.ResultField: 1: 10) + ') TYPE('; 2b if FieldsAttrDS.DecimalPos > ' '; SrcOut = %trimr(SrcOut) + '*DEC) LEN('; 2x else; SrcOut = %trimr(SrcOut) + '*CHAR) LEN('; 2e endif; SrcOut = %trimr(SrcOut) + %char(FieldsAttrDS.Length) + FieldsAttrDS.DecimalPos + ') + '; Seqnum += 10; except WriteCode; // Generate PROMPT text. SrcOut = 'PROMPT(' + qs + SrcDS.ResultField + ' ' + %char(FieldsAttrDS.Length); 2b if FieldsAttrDS.DecimalPos > ' '; SrcOut = %trimr(SrcOut) + ',' + FieldsAttrDS.DecimalPos; 2e endif; SrcOut = %trimr(SrcOut) + qs + ')'; Seqnum += 10; except WriteCode; 1e endif; endsr; //--------------------------------------------------------- // Determine PEP or Procedure Entry Point. // 1. Check for *ENTRY or // 2. Prototype with same EXTPGM name as program // 3. Prototype with same name as program. begsr srDeterminePEP; 1b if SrcDS.SpecType = 'D'; IsProcIntFace = *off; aa = %scan('...': SrcDS.Src57); 2b if aa > 0; %subst(SrcDS.Src57: aa + 3) = *blanks; ExtendedName = %triml(SrcDS.Src57); // see if same as program name aa = %scan('...': Extendedname); 3b if aa > 0 and %triml(%subst(ExtendedName: 1: aa - 1)) = p_SrcMbr; IsProcIntFace = *on; 3e endif; read JCRGETFLDF; SrcDS = %xlate(lo: up: SrcDS); 2x else; 3b if %triml(SrcDS.dFieldName) = p_SrcMbr; IsProcIntFace = *on; dFieldNameSav = %triml(SrcDS.dFieldName); 3e endif; 2e endif; Alpha6 = %triml(SrcDS.dKeyWord); 2b if Alpha6 = 'EXTPGM'; aa = %scan(qs: SrcDS.dKeyWord); bb = %scan(qs: SrcDS.dKeyWord: aa + 1); 3b if p_SrcMbr = %subst(SrcDS.dKeyWord: aa + 1: bb - (aa + 1)); IsProcIntFace = *on; dFieldNameSav = %triml(SrcDS.dFieldName); 3e endif; 2e endif; 2b if IsProcIntFace; // read through source until find // a PI procedure interface with same name as Prototype read JCRGETFLDF; 3b dow not %eof; SrcDS = %xlate(lo: up: SrcDS); aa = %scan('...': SrcDS.Src57); //drop trailing ... 4b if aa > 0; %subst(SrcDS.Src57: aa + 3) = *blanks; 4e endif; 4b if %triml(SrcDS.dFieldName) = dFieldNameSav or ExtendedName = %triml(SrcDS.Src57); 5b if SrcDS.ProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 5x else; read JCRGETFLDF; SrcDS = %xlate(lo: up: SrcDS); 6b if SrcDS.ProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 6e endif; 5e endif; 4e endif; read JCRGETFLDF; 3e enddo; 2e endif; 1x elseif SrcDS.SpecType = 'C' and SrcDS.Factor1 = '*ENTRY '; IsExtractParm = *on; ExtractTypeFlg = '*ENTRY'; 1e endif; endsr; //--------------------------------------------------------- // For CL program types, call program to return parm fields begsr srCL; callp p_JCRGETCLPR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity); 1b if p_DiagSeverity > '20'; *inlr = *on; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + p_DiagSeverity + '. Please check listing for errors.'); 1e endif; 1b for aa = 1 to FieldsArry_NumberOfEntries; Seqnum += 10; FieldsAttrDS = FieldsAttrArry(aa); 2b if FieldsAttrDS.DataType = 'D'; WorkType = '*DEC'; 2x elseif FieldsAttrDS.DataType = 'C'; WorkType = '*CHAR'; 2x elseif FieldsAttrDS.DataType = 'L'; WorkType = '*LGL'; 2x elseif FieldsAttrDS.DataType = 'I'; WorkType = '*INT4'; 2x elseif FieldsAttrDS.DataType = 'U'; WorkType = '*UINT4'; 2e endif; WorkField = %subst(FieldsNameArry(aa) : 2: 10); SrcOut = 'PARM KWD(' + %trimr(WorkField) + ') TYPE(' + %trimr(WorkType) + ') LEN(' + %char(FieldsAttrDS.Length) + ' ' + FieldsAttrDS.DecimalPos + ') PROMPT(' + WorkField + ')'; except WriteCode; 1e endfor; endsr; /end-free OcmdSrc e WriteCode O Seqnum 6 O SrcOut 100 ]]> v5r4 //--------------------------------------------------------- // JCRCALLRO - prompt override program // Use object parm to call APIs Qclrpgmi-Retrieve Pgm Info or Qbnlpgmi-List ILE Pgm Info // to retrieve where Src file was located when program was compiled. Original Source // File, Lib and Mbr are returned to command. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define Qbnlpgmi /Define Qclrpgmi /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D QclrpgmiDS ds 528 qualified D SrcAttrb 10a overlay(QclrpgmiDS:39) D SrcFile 10a overlay(QclrpgmiDS:62) D SrcLib 10a overlay(QclrpgmiDS:72) D SrcMbr 10a overlay(QclrpgmiDS:82) D QbnlpgmiDS ds qualified based(QbnlpgmiPTR) D SrcFile 10a overlay(QbnlpgmiDS:41) D SrcLib 10a overlay(QbnlpgmiDS:51) D SrcMbr 10a overlay(QbnlpgmiDS:61) D SrcAttrb 10a overlay(QbnlpgmiDS:71) D AlphaBin ds qualified D ShortBin 1 2b 0 inz(5700) //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRO PR extpgm('JCRCALLRO') D 20a Command Name and Lib D 20a Program Name and Lib D 5700a Return String D p_JCRCALLRO PI D p_CmdQual 20a D p_PgmQual 20a D p_RtnString 5700a //--------------------------------------------------------- /free // call retrieve program information API to get attribute callp QCLRPGMI( QclrpgmiDS: 528: 'PGMI0100': p_PgmQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; QclrpgmiDS.SrcFile = 'OBJECTxxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; 1x else; // If ILE, create / get pointer ILE user space 2b if QclrpgmiDS.SrcAttrb = 'RPGLE ' or QclrpgmiDS.SrcAttrb = 'SQLRPGLE ' or QclrpgmiDS.SrcAttrb = 'CLLE '; GenericHeaderPtr2 = f_Quscrtus(UserSpaceName2); // if ILE, call API to get Src callp QBNLPGMI( UserSpaceName2: 'PGML0100': p_PgmQual: ApiErrDS); 3b if ApiErrDS.BytesReturned > 0; //Src not available QclrpgmiDS.SrcFile = 'SOURCExxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; 3x else; QbnlpgmiPTR = GenericHeaderPtr2 + GenericHeader2.OffsetToList; QclrpgmiDS.SrcFile = QbnlpgmiDS.SrcFile; QclrpgmiDS.SrcLib = QbnlpgmiDS.SrcLib; QclrpgmiDS.SrcMbr = QbnlpgmiDS.SrcMbr; QclrpgmiDS.SrcAttrb = QbnlpgmiDS.SrcAttrb; 3e endif; 2e endif; 1e endif; // build prompt string to return to command p_RtnString = AlphaBin + '??SRCFIL(' + %trimr(QclrpgmiDS.SrcFile) + ')' + ' ??SRCLIB(' + %trimr(QclrpgmiDS.SrcLib) + ')' + ' ??SRCMBR(' + %trimr(QclrpgmiDS.SrcMbr) + ')' + ' ??PGMATR(' + %trimr(QclrpgmiDS.SrcAttrb) + ')'; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRCALLRV - Object and source mbr validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_IsValidMbrType /Define f_CheckObj /Define f_SndEscapeMsg /Define p_JCRCALLR /Define p_JCRCALLRV /COPY JCRCMDS,JCRCMDSCPY D SrcFilQual S 20a //--*ENTRY PARMS------------------------------------------- D p_JCRCALLRV PI D p_PgmQual 20a D p_SrcFil 10a D p_SrcLib 10a D p_SrcMbr 10a D p_Pgmatr 10a //--------------------------------------------------------- /free f_CheckObj(p_PgmQual : '*PGM '); SrcFilQual = p_SrcFil + p_SrcLib; 1b if not f_IsValidMbrType(SrcFilQual : p_SrcMbr: 'RPGLE ': 'SQLRPGLE ': 'CLP ': 'CLLE '); f_SndEscapeMsg('Program type ' + %trimr(p_Pgmatr) + ' not supported by JCRCALL.'); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRCMDSBND - Binder source for JCRCMDSSRV service program */ /* Note: Add entries to the end. */ /*--------------------------------------------------------------------------*/ STRPGMEXP SIGNATURE('JCRCMDS890123456') EXPORT SYMBOL(Apierrds) EXPORT SYMBOL(f_AddSortKey) EXPORT SYMBOL(f_BlankCommentsCL) EXPORT SYMBOL(f_BringDataBaseRecords) EXPORT SYMBOL(f_BuildString) EXPORT SYMBOL(f_CenterText) EXPORT SYMBOL(f_CheckMbr) EXPORT SYMBOL(f_CheckObj) EXPORT SYMBOL(f_CrtCmdString) EXPORT SYMBOL(f_GetDayName) EXPORT SYMBOL(f_MondaysDate) EXPORT SYMBOL(f_DecodeApiTimeStamp) EXPORT SYMBOL(f_DelayJobSeconds) EXPORT SYMBOL(f_DltOvr) EXPORT SYMBOL(f_DspLastSplf) EXPORT SYMBOL(f_DupFileToQtemp) EXPORT SYMBOL(f_RunOptionFile) EXPORT SYMBOL(f_RunOptionJob) EXPORT SYMBOL(f_RunOptionObject) EXPORT SYMBOL(f_RunOptionSplf) EXPORT SYMBOL(f_FakeEditWord) EXPORT SYMBOL(f_GetAllocSize01) EXPORT SYMBOL(f_GetApiHMS) EXPORT SYMBOL(f_GetApiISO) EXPORT SYMBOL(f_GetCardColor) EXPORT SYMBOL(f_GetCardFace) EXPORT SYMBOL(f_GetFileUtil) EXPORT SYMBOL(f_GetQual) EXPORT SYMBOL(f_GetRandom) EXPORT SYMBOL(f_GetRowColumn) EXPORT SYMBOL(f_IsValidMbr) EXPORT SYMBOL(f_IsValidMbrType) EXPORT SYMBOL(f_IsValidObj) EXPORT SYMBOL(f_OutFileAddPfm) EXPORT SYMBOL(f_OutFileCrtDupObj) EXPORT SYMBOL(f_OvrPrtf) EXPORT SYMBOL(f_ParmListCount) EXPORT SYMBOL(f_Pgm) EXPORT SYMBOL(f_Qmhrcvpm) EXPORT SYMBOL(f_Quscrtus) EXPORT SYMBOL(f_Qusrmbrd) EXPORT SYMBOL(f_Qusrobjd) EXPORT SYMBOL(f_RmvSflMsg) EXPORT SYMBOL(f_RtvMsgApi) EXPORT SYMBOL(f_Sbmjob) EXPORT SYMBOL(f_ShuffleDeck) EXPORT SYMBOL(f_SndCompMsg) EXPORT SYMBOL(f_SndEscapeMsg) EXPORT SYMBOL(f_SndSflMsg) EXPORT SYMBOL(f_SndStatMsg) EXPORT SYMBOL(f_System) EXPORT SYMBOL(FieldsArry) EXPORT SYMBOL(FieldsArry_NumberOfEntries) ENDPGMEXP ]]> v5r4 - v7r1 //--------------------------------------------------------- // JCRCMDSCPY - Copy Book for JCRCMDS //--------------------------------------------------------- /endif /If defined(ProgramHeaderSpecs) H DFTACTGRP(*NO) ACTGRP(*CALLER) DATFMT(*ISO) TIMFMT(*ISO) /IF DEFINED(*V6R1M0) H OPTION(*NOUNREF: *NODEBUGIO) /ELSE H OPTION(*NODEBUGIO) /ENDIF H EXPROPTS(*RESDECPOS) H BNDDIR('JCRCMDSDIR':'QSYS/QC2LE') /endif /If defined(ApiErrDS) //--------------------------------------------------------- // error return code parm for APIs. D ApiErrDS DS qualified import D BytesProvided 10i 0 D BytesReturned 10i 0 D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a /endif /If defined(ApiStampDS) //--------------------------------------------------------- D ApiStampDS DS 16 qualified inz extract c yymmdd D Century 1a overlay(ApiStampDS:1) 0=19 1=20 D MMDD 4a overlay(ApiStampDS:2) D YY 2a overlay(ApiStampDS:6) D HHMMSS 6a overlay(ApiStampDS:8) /endif /If defined(Atof) //--------------------------------------------------------- D atof PR 8f extproc('atof') string to float D * value options(*string) /endif /If defined(Atoi) //--------------------------------------------------------- D atoi PR 10i 0 extproc('atoi') string to integer D * value options(*string) /endif /If defined(Ceegsi) //--------------------------------------------------------- // Parameters for CEEGSI - Get String Information D ceegsi PR extproc('CEEGSI') get string info D 10i 0 const position D 10i 0 data type D 10i 0 parm length D 10i 0 max length D 12a options(*omit) feedback // CEEGSI values used in multiple functions D MaxLength s 10i 0 D DataType s 10i 0 D LengthOfParm s 10i 0 /endif /If defined(Constants) //--------------------------------------------------------- D rrn s 5u 0 D aa s 5u 0 D bb s 5u 0 D cc s 5u 0 D qs c const('''') single quote D qd c const('"') double quote D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') D lo c const('abcdefghijklmnopqrstuvwxyz') D IsExitPgm s n D IsRefresh s n D IsFirstTime s n D IsComment s n /endif /If defined(Cvthc) //--------------------------------------------------------- D cvthc PR ExtProc('cvthc') convert hex to char D * value receiver pointer D * value source pointer D 10i 0 value number of nibbles /endif /If defined(Infds) //--------------------------------------------------------- // File information Data Structure D Infds DS D InfdsFile 10a overlay(Infds:83) D InfdsLib 10a overlay(Infds:93) D InfdsRecLen 5i 0 overlay(Infds:125) D InfdsMbr 10a overlay(Infds:129) D InfdsNumRcds 10i 0 overlay(Infds:156) D InfdsMiscFlag 1a overlay(Infds:196) D InfdsCcsid 5i 0 overlay(Infds:218) D InfdsRcdfmt 10a overlay(Infds:261) D InfdsFkey 1a overlay(Infds:369) D SflRecNbrX 5i 0 overlay(Infds:376) D SflRecNbr 5i 0 overlay(Infds:378) /endif /If defined(Dspatr) //--------------------------------------------------------- D Green c const(x'20') D White c const(x'22') D Red c const(x'28') D Turq c const(x'30') D Yellow c const(x'32') D Pink c const(x'38') D Blue c const(x'3A') D ND c const(x'27') D RI c const(x'01') D HI c const(x'02') D UL c const(x'04') D PR c const(x'80') /endif /If defined(FieldsAttrDS) //--------------------------------------------------------- D FieldsAttrDS DS qualified inz D Length 10u 0 D DecimalPos 2a D DecimalPosN 2s 0 overlay(DecimalPos) D DataType 1a D FromFile 10a D QualifyingDS 50a D Text 25a /If defined(FieldsArry) D FieldsArry_NumberOfEntries... D s 10u 0 IMPORT D FieldsArry s 192a dim(12767) IMPORT D DS based(FieldPtr) D FieldsArryDS 192a dim(%elem(FieldsArry)) D FieldsNameArry 100a overlay(FieldsArryDS:1) D FieldsAttrArry overlay(FieldsArryDS:101) D like(FieldsAttrDS) D FieldPtr s * inz(%addr(FieldsArry)) /endif /endif /If defined(GetAllocSizeDS) //--------------------------------------------------------- D GetAllocSizeDS DS qualified D SizeReturned 10i 0 overlay(GetAllocSizeDS:5) /endif /If defined(Fild0100DS) //--------------------------------------------------------- // file header offsets D Fild0100ds DS qualified based(Fild0100ptr) D BytesReturned 10i 0 overlay(Fild0100ds:001) D TypeBits 1a overlay(Fild0100ds:009) D NumOfBasedPf 5i 0 overlay(Fild0100ds:015) D MaxMbrs 5i 0 overlay(Fild0100ds:042) D NumMbrs 5i 0 overlay(Fild0100ds:048) D NumRcdFmts 5i 0 overlay(Fild0100ds:062) D FileText 50a overlay(Fild0100ds:085) D NumOfFlds 5i 0 overlay(Fild0100ds:207) D FileRecLen 5i 0 overlay(Fild0100ds:305) D OffsFileScope 10i 0 overlay(Fild0100ds:317) D AccessType 2a overlay(Fild0100ds:337) D OffsPFAttr 10i 0 overlay(Fild0100ds:365) D OffsLfAttr 10i 0 overlay(Fild0100ds:369) // file scope array D FileScopeArry DS 160 qualified based(fscopePtr) D BasedOnPf 10a overlay(FileScopeArry:049) D BasedOnPfLib 10a overlay(FileScopeArry:059) D RcdFmt 10a overlay(FileScopeArry:069) D NumOfKeys 5i 0 overlay(FileScopeArry:116) D NumSelectOmit 5i 0 overlay(FileScopeArry:129) D OffsSelectOmit 10i 0 overlay(FileScopeArry:131) D OffsKeySpecs 10i 0 overlay(FileScopeArry:135) // key specification array D KeySpecsDS DS qualified based(KeySpecsPtr) D KeyFieldName 10a overlay(KeySpecsDS:1) D KeySequenBits 1a overlay(KeySpecsDS:14) // select/omit specification array. D SelectOmitSpec DS qualified based(SelectOmitSpecPtr) D StatementRule 1a overlay(SelectOmitSpec:3) D CompRelation 2a overlay(SelectOmitSpec:4) D FieldName 10a overlay(SelectOmitSpec:6) D NumberOfParms 5i 0 overlay(SelectOmitSpec:16) D OffsToParms 10i 0 overlay(SelectOmitSpec:29) // select/omit parameters. D SelectOmitParm DS qualified based(SelectOmitParmPtr) D OffsToNext 10i 0 overlay(SelectOmitParm:1) D ParmLength 5i 0 overlay(SelectOmitParm:5) D ParmValue 30a overlay(SelectOmitParm:21) // Logical file specific attributes section. D LfSpecific DS 48 qualified based(lfSpecificPtr) D JoinOffset 10i 0 overlay(LfSpecific:1) D AttrBits 1a overlay(LfSpecific:31) // join specifications linked list section. D JoinSpecDS DS 48 qualified based(JoinSpecPtr) D NextLink 10i 0 overlay(JoinSpecDs:1) D NumJFlds 5i 0 overlay(JoinspecDS:9) D JoinFileNum 5i 0 overlay(JoinspecDS:13) D OffsToJSA 10i 0 overlay(JoinspecDS:41) // join specification array. (JSA) D JoinSpecArryDS DS 48 qualified based(JoinSpecArryPtr ) D FromField 10a overlay(JoinSpecArryDS:1) D FromNumber 5i 0 overlay(JoinSpecArryDS:11) D ToField 10a overlay(JoinSpecArryDS:17) D ToNumber 5i 0 overlay(JoinSpecArryDS:27) // physical file attributes D PfAttrDS DS based(PfAttrPtr) qualified D OffsTriggers 10i 0 overlay(PfAttrDS:25) D NumOfTriggers 5i 0 overlay(PfAttrDS:29) // trigger information array D TriggerDS DS based(TriggerPtr) qualified D TTime 1a overlay(TriggerDS:1) D TEvent 1a overlay(TriggerDS:2) D TPrgNam 10a overlay(TriggerDS:3) D TPrgLib 10a overlay(TriggerDS:13) /endif /If defined(FunctionKeys) //--------------------------------------------------------- D f01 c const(x'31') D f02 c const(x'32') D f03 c const(x'33') D f04 c const(x'34') D f05 c const(x'35') D f06 c const(x'36') D f07 c const(x'37') D f08 c const(x'38') D f09 c const(x'39') D f10 c const(x'3A') D f11 c const(x'3B') D f12 c const(x'3C') D f13 c const(x'B1') D f14 c const(x'B2') D f15 c const(x'B3') D f16 c const(x'B4') D f17 c const(x'B5') D f18 c const(x'B6') D f19 c const(x'B7') D f20 c const(x'B8') D f21 c const(x'B9') D f22 c const(x'BA') D f23 c const(x'BB') D f24 c const(x'BC') D fPageup c const(x'F4') D fPageDown c const(x'F5') /endif /If defined(Ind) //--------------------------------------------------------- // name screen indicators D ind DS qualified inz D IsActivateF14 n overlay(ind:04) D IsKeysMode n overlay(ind:05) D sfldrop n overlay(ind:06) D IsMoreScreens n overlay(ind:08) D IsShowViewPFs n overlay(ind:09) D HeadingSwitch n overlay(ind:10) D sflnxtchg n overlay(ind:11) D IsChangedDate n overlay(ind:20) D ShowSrcData n overlay(ind:27) D sfldsp n overlay(ind:31) D sfldspctl n overlay(ind:32) D sflclr n overlay(ind:33) D sflend n overlay(ind:34) D sfldsp2 n overlay(ind:41) D sfldspctl2 n overlay(ind:42) D sflclr2 n overlay(ind:43) D sflend2 n overlay(ind:44) D sfldsp3 n overlay(ind:51) D sfldspctl3 n overlay(ind:52) D sfldsp4 n overlay(ind:61) D sfldspctl4 n overlay(ind:62) /endif /If defined(ListHeaderDS) //--------------------------------------------------------- // Get user header info from list user space D ListHeaderDS DS qualified based(ListHeaderPtr) D FileActual 10a D LibActual 10a D FileType 10a D FileText 50a /endif /If defined(Qbnlpgmi) //--------------------------------------------------------- D Qbnlpgmi PR extpgm('QBNLPGMI') list ile pgm info D 20a user space D 8a const api format D 20a const object and lib Db like(ApiErrDS) /endif /If defined(Qbnlspgm) //--------------------------------------------------------- D Qbnlspgm PR extpgm('QBNLSPGM') list srvpgm info D 20a user space D 8a const api format D 20a const object and lib Db like(ApiErrDS) /endif /If defined(Qbnrmodi) //--------------------------------------------------------- D Qbnrmodi PR extpgm('QBNRMODI') retrieve module info Db 200a receiver D 10i 0 const receiver length D 8a const api format D 20a const object and lib Db like(ApiErrDS) /endif /If defined(Qclrpgmi) //--------------------------------------------------------- D Qclrpgmi PR extpgm('QCLRPGMI') retrieve pgm info D 528a receiver D 10i 0 const receiver length D 8a const api format D 20a const file and lib Db like(ApiErrDS) /endif /If defined(Qcmdchk) //--------------------------------------------------------- D Qcmdchk PR extpgm('QCMDCHK') cl syntax checking D 500a D 15p 5 const /endif /If defined(Qcmdexc) //--------------------------------------------------------- D Qcmdexc PR extpgm('QCMDEXC') cl command processor D 125a options(*VarSize) D 15p 5 const /endif /If defined(Qdbldbr) //--------------------------------------------------------- D Qdbldbr PR extpgm('QDBLDBR ') data base relations D 20a user space D 8a const api format D 20a const file and lib D 10a const mbr D 10a const record format Db like(ApiErrDS) //-DBRL0100 format- D QdbldbrDS DS qualified based(QdbldbrPtr) D DependentLF 10a overlay(QdbldbrDS:21) D DependentLib 10a overlay(QdbldbrDS:31) D DependentFile 20a overlay(QdbldbrDS:21) /endif /If defined(Qdbrtvfd) //--------------------------------------------------------- D Qdbrtvfd PR extpgm('QDBRTVFD') retrieve file desc D 16000a options(*varsize) receiver D 10i 0 const receiver length D 20a return file and lib D 8a const api format D 20a const file and lib D 10a const record format D 1a const overrides D 10a const system D 10a const format type Db like(ApiErrDS) D ReturnFileQual s 20a //--------------------------------------------------------- // get size of memory to allocate for QDBRTVFD call D f_GetAllocSize01... D PR 10i 0 memory size D 20a const qualified file name D 10a const record format name D AllocateSize s 10i 0 /endif /If defined(Qeccvtec) //--------------------------------------------------------- D Qeccvtec PR extpgm('QECCVTEC') generate edit mask D 256a receiver D 10i 0 mask length D 10i 0 receiver length D 1a const 0 balance file D 1a const edit code D 1a const blank fill D 10i 0 const field length D 10i 0 const decimal location Db like(ApiErrDS) /endif /If defined(Qecedt) //--------------------------------------------------------- D Qecedt PR extpgm('QECEDT') apply edit mask D 256a receiver D 10i 0 mask length D 30p 9 to be edited D 10a const type D 10i 0 const field length D 256a edit mask D 10i 0 mask length D 1a const 0 balance file Db like(ApiErrDS) /endif /If defined(Qlgsort) //--------------------------------------------------------- // QLGSORT Sort Control Block D qlgSortDS DS 1024 qualified inz D BlockLength 10i 0 overlay(qlgSortDS:1) D TypeRequest 10i 0 overlay(qlgSortDS:5) inz(5) D Reserved1 10i 0 overlay(qlgSortDS:9) D Options 10i 0 overlay(qlgSortDS:13) D RecordLength 10i 0 overlay(qlgSortDS:17) D RecordCount 10i 0 overlay(qlgSortDS:21) D OffToKeyList 10i 0 overlay(qlgSortDS:25) inz(80) D NumOfKeys 10i 0 overlay(qlgSortDS:29) D OffNatLangInf 10i 0 overlay(qlgSortDS:33) D OffInpFileList 10i 0 overlay(qlgSortDS:37) D NumOfInpFiles 10i 0 overlay(qlgSortDS:41) D OffOutFileList 10i 0 overlay(qlgSortDS:45) D NumofOutFiles 10i 0 overlay(qlgSortDS:49) D KeyEntryLength 10i 0 overlay(qlgSortDS:53) inz(16) D SortSeqLength 10i 0 overlay(qlgSortDS:57) D LenInFileEntry 10i 0 overlay(qlgSortDS:61) DLenOutFileEntry 10i 0 overlay(qlgSortDS:65) D OffToNullMap 10i 0 overlay(qlgSortDS:69) D OffToVarRecInf 10i 0 overlay(qlgSortDS:73) D Reserved2 10i 0 overlay(qlgSortDS:77) //--*CALL PROTOTYPES--------------------------------------- D qlgsort PR extpgm('QLGSORT') D 1024a options(*varsize) sort ds D 20a dim(10) in buffer D 20a dim(10) out buffer D 10i 0 const length in buffer D 10i 0 const length out buffer Db like(ApiErrDS) error ds /endif /If defined(Qmhqrdqd) //--------------------------------------------------------- D Qmhqrdqd PR extpgm('QMHQRDQD') dataq description Db like(QmhqrdqdDS) receiver D 10i 0 const receiver length D 8a const api format Db 20a dtaq and lib D QmhqrdqdDS DS qualified inz D MsgLength 10i 0 overlay(QmhqrdqdDS:9) D KeyLength 10i 0 overlay(QmhqrdqdDS:13) D Sequence 1a overlay(QmhqrdqdDS:17) D SenderID 1a overlay(QmhqrdqdDS:18) D Text 50a overlay(QmhqrdqdDS:20) D LocalOrDDM 1a overlay(QmhqrdqdDS:70) D EntryCount 10i 0 overlay(QmhqrdqdDS:73) D CurrAllocated 10i 0 overlay(QmhqrdqdDS:77) D DtaqName 10a overlay(QmhqrdqdDS:81) D DtaqLib 10a overlay(QmhqrdqdDS:91) D MaxAllowed 10i 0 overlay(QmhqrdqdDS:101) D CreateSize 10i 0 overlay(QmhqrdqdDS:109) /endif /If defined(Qmhrcvm) //--------------------------------------------------------- D Qmhrcvm PR extpgm('QMHRCVM') receive non-pgm msg Db like(QmhrcvmDS) options(*varsize) message info D 10i 0 const length D 8a const format name D 20a const queue and lib D 10a const type D 4a const key D 10i 0 const wait time D 10a const message action Db like(ApiErrDS) options(*varsize) // parms for QMHRCVM retrieve non program messages D QmhrcvmDS DS qualified D BytesReturned 10i 0 overlay(QmhrcvmDS:1) D BytesAvail 10i 0 overlay(QmhrcvmDS:5) D MsgSeverity 10i 0 overlay(QmhrcvmDS:9) D MsgID 7a overlay(QmhrcvmDS:13) D MsgType 2a overlay(QmhrcvmDS:20) D MsgKey 4a overlay(QmhrcvmDS:22) D Reserved 7a overlay(QmhrcvmDS:26) D CcsidConvStat 10i 0 overlay(QmhrcvmDS:33) D Ccsid 10i 0 overlay(QmhrcvmDS:37) D MsgLenReturn 10i 0 overlay(QmhrcvmDS:41) D MsgLenAvail 10i 0 overlay(QmhrcvmDS:45) D ReplaceData 512a overlay(QmhrcvmDS:49) /endif /If defined(Qmhsndpm) //--------------------------------------------------------- D Qmhsndpm PR extpgm('QMHSNDPM') send program message D 7a const message id D 20a const file and lib D 75a 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(ApiErrDS) /endif /If defined(QsnGetCsrAdr) //--------------------------------------------------------- //get cursor Row and Column D QsnGetCsrAdr PR 10i 0 extproc('QsnGetCsrAdr') get cursor row,colum D 10i 0 const row D 10i 0 const col D 10i 0 const low level handle Db like(ApiErrDS) D QsnCursorRow s 10i 0 D QsnCursorCol s 10i 0 /endif /If defined(Qspclosp) //--------------------------------------------------------- D Qspclosp PR extpgm('QSPCLOSP') close spooled file D 10i 0 splf handle Db like(ApiErrDS) /endif /If defined(Qspgetsp) //--------------------------------------------------------- D Qspgetsp PR extpgm('QSPGETSP') get spooled data D 10i 0 splf handle D 20a user space D 8a const api format D 10i 0 ordinal number D 10a const end of open Db like(ApiErrDS) /endif /If defined(Qspopnsp) //--------------------------------------------------------- D Qspopnsp PR extpgm('QSPOPNSP') open spool file D 10i 0 splf handle D 26a const qualified job D 16a internal job id D 16a internal spool num D 10a const spool file name D 10i 0 const spool file num D 10i 0 const number of buffers Db like(ApiErrDS) /endif /If defined(Quscmdln) //--------------------------------------------------------- D Quscmdln PR extpgm('QUSCMDLN') command line /endif /If defined(Qusdltus) //--------------------------------------------------------- D Qusdltus PR extpgm('QUSDLTUS') delete user space D 20a user space Db like(ApiErrDS) /endif /If defined(UserProfiles) //--------------------------------------------------------- D Autu0200DS DS based(Autu0200ptr) D UsrPrf 10a overlay(Autu0200DS:1) D UsrPrfTxt 33a overlay(Autu0200DS:21) D Usri0300DS DS qualified inz D PrvSignDatTim 13a overlay(usri0300DS:19) D Status 10a overlay(usri0300DS:37) D UserClass 7a overlay(usri0300DS:74) D SpecialAuth 15a overlay(usri0300DS:84) D AllObj 1a overlay(SpecialAuth:1) D Secadm 1a overlay(SpecialAuth:2) D JobCtl 1a overlay(SpecialAuth:3) D SplCtl 1a overlay(SpecialAuth:4) D SavSys 1a overlay(SpecialAuth:5) D Service 1a overlay(SpecialAuth:6) D Audit 1a overlay(SpecialAuth:7) D ApiAuthArry 1a overlay(SpecialAuth:1) dim(15) D IoSysCfg 1a overlay(SpecialAuth:8) D JobdQual 20a overlay(usri0300DS:290) D OutqQual 20a overlay(usri0300DS:361) //--*CALL PROTOTYPES--------------------------------------- D qsylautu PR extpgm('QSYLAUTU') authorized user list D 20a user space D 8a const format Db like(ApiErrDS) D qsyrusri PR extpgm('QSYRUSRI') D 309a user profile info D 10i 0 const receiver len D 8a const format D 10a user profile Db like(ApiErrDS) /endif /If defined(Quslfld) //--------------------------------------------------------- D Quslfld PR extpgm('QUSLFLD') field descriptions D 20a user space D 8a const api format D 20a const file and lib D 10a const record format D 1a const overrides Db like(ApiErrDS) // data structure for Quslfld user space list entries D QuslfldDS DS qualified based(QuslfldPtr) D FieldName 10a overlay(QuslfldDS:1) D FieldType 1a overlay(QuslfldDS:11) D OutputPosition 10i 0 overlay(QuslfldDS:13) D InputPosition 10i 0 overlay(QuslfldDS:17) D FieldLengthA 10i 0 overlay(QuslfldDS:21) D FieldLengthN 10i 0 overlay(QuslfldDS:25) D DecimalPos 10i 0 overlay(QuslfldDS:29) D FieldText 50a overlay(QuslfldDS:33) D AliasName 10a overlay(QuslfldDS:223) D ScreenFieldRow 10i 0 overlay(QuslfldDS:449) D ScreenFieldCol 10i 0 overlay(QuslfldDS:453) /endif /If defined(Quslmbr) //--------------------------------------------------------- D Quslmbr PR extpgm('QUSLMBR') list mbr D 20a user space D 8a const api format D 20a const file and lib D 10a const mbr D 1a const override Db like(ApiErrDS) // list members information. D QuslmbrDS DS qualified based(QuslmbrPtr) D MbrName 10a overlay(QuslmbrDS:1) D MbrType 10a overlay(QuslmbrDS:11) D CreateDateTime 13a overlay(QuslmbrDS:21) D ChangeDateTime 13a overlay(QuslmbrDS:34) D Text 50a overlay(QuslmbrDS:47) D Ccsid 10i 0 overlay(QuslmbrDS:97) /endif /If defined(Quslobj) //--------------------------------------------------------- D Quslobj PR extpgm('QUSLOBJ') list objects D 20a user space D 8a const api format D 20a const object and lib D 10a const object type Db like(ApiErrDS) D QuslobjDS DS qualified based(QuslobjPtr) D ObjNam 10a overlay(QuslobjDS:1) D ObjLib 10a overlay(QuslobjDS:11) D ObjTyp 10a overlay(QuslobjDS:21) D ExtendedAttr 10a overlay(QuslobjDS:32) D ObjText 50a overlay(QuslobjDS:42) D CreateStamp 8a overlay(QuslobjDS:125) D CreatedByUser 10a overlay(QuslobjDS:216) D LastUseStamp 8a overlay(QuslobjDS:533) D NumDaysUsed 10i 0 overlay(QuslobjDS:549) D ObjSize 10i 0 overlay(QuslobjDS:577) D MultiplySize 10i 0 overlay(QuslobjDS:581) /endif /If defined(Quslspl) //--------------------------------------------------------- D Quslspl PR extpgm('QUSLSPL') list spooled files D 20a user space D 8a const api format D 10a const user profile D 20a outq and lib D 10a const form type D 10a const user data Db like(ApiErrDS) D QuslsplDS DS qualified based(QuslsplPtr) D InternalJobID 16a overlay(QuslsplDS:51) D InternalSplfID 16a overlay(QuslsplDS:67) //--------------------------------------------------------- // DS of spooled file attributes return variable. D splf0300DS DS qualified based(splf0300Ptr) D JobName 10a overlay(splf0300DS:1) D UserID 10a overlay(splf0300DS:11) D JobNo 6a overlay(splf0300DS:21) D SplfName 10a overlay(splf0300DS:27) D SplfNum 10i 0 overlay(splf0300DS:37) D Status 10i 0 overlay(splf0300DS:41) D CreateYYMMDD 6a overlay(splf0300DS:46) D CreateHHMMSS 6a overlay(splf0300DS:52) D UsrDta 10a overlay(splf0300DS:69) D FormType 10a overlay(splf0300DS:79) D Outq 10a overlay(splf0300DS:89) D OutqLib 10a overlay(splf0300DS:99) D ASP 10i 0 overlay(splf0300DS:109) D SplfSize 10i 0 overlay(splf0300DS:113) D MultiplySize 10i 0 overlay(splf0300DS:117) D PageNum 10i 0 overlay(splf0300DS:121) D Copies 10i 0 overlay(splf0300DS:125) D Priority 1a overlay(splf0300DS:129) /endif /If defined(Qusptrus) //--------------------------------------------------------- D Qusptrus PR extpgm('QUSPTRUS') retrieve pointer D 20a user space D * pointer Db like(ApiErrDS) /endif /If defined(Qusrjobi) //--------------------------------------------------------- D Qusrjobi PR extpgm('QUSRJOBI') retrieve job info Db 200a options(*varsize) receiver D 10i 0 const receiver length D 8a const api format D 26a const qualified job name D 16a const internal job num Db like(ApiErrDS) /endif /If defined(Qusrusat) //--------------------------------------------------------- // Retrieve User Space Attributes D Qusrusat PR extpgm('QUSRUSAT') user space sttribute Db like(QusrusatDS) receiver D 10i 0 const receiver length D 8a const api format D 20a user space Db like(ApiErrDS) // --return values for user space attributes-- D QusrusatDS DS qualified inz D BytesReturned 10i 0 overlay(QusrusatDS:1) D BytesAvailable 10i 0 overlay(QusrusatDS:5) D SpaceSize 10i 0 overlay(QusrusatDS:9) D Extendability 1a overlay(QusrusatDS:13) D InitialValue 1a overlay(QusrusatDS:14) D SpaceLibrary 10a overlay(QusrusatDS:15) /endif /If defined(Qwccvtdt) //--------------------------------------------------------- D Qwccvtdt PR extpgm('QWCCVTDT') spi date converter D 10a const from format D 8a api date stamp D 10a const to format Db 16a to date Db like(ApiErrDS) /endif /If defined(Qwdrjobd) //--------------------------------------------------------- D Qwdrjobd PR extpgm('QWDRJOBD') load jobd data Db 1000a options(*varsize) receiver D 10i 0 const receiver length D 8 const api format D 20 const jobd and lib Db like(ApiErrDS) /endif /If defined(Sds) //--------------------------------------------------------- D Sds D ProgId 10a /endif /If defined(Tstbts) //--------------------------------------------------------- D tstbts PR 10i 0 extproc('_TSTBTS') mi test bits D * value options(*string) bit string D 10u 0 value bit offset /endif /If defined(SrcDS) //--------------------------------------------------------- // Define fields from different spec types. D SrcDS DS qualified inz D SeqNum4A 1 4a D SeqNum6 1 6s 2 D SrcChgDat 7 12s 0 D CompileArray 13 15a D SpecType 18 18a D Asterisk 19 19a D SlashComment 19 20a D SlashIF 19 22a D SlashELSEIF 19 26a D FreeForm 19 27a D Src80 19 92a D Src112 13 112a // F specs // rpg 4 locations D fFileName 19 28a D fUsage 29 29a I U O D fEorF 34 34a E or F D fDevice 48 55a DISK, PRINTER, etc // rpg 3 locations D fFileName3 19 26a z D fUsage3 27 27a I U O D fEorF3 31 31a E or F D fDevice3 52 58a DISK, PRINTER, etc D fBeingRenamed3 31 40a KRENAME D fKeyWord3 65 71a KRENAME D fRenamed3 72 81a KRENAME // D specs D dTestPopulated 19 54a D dFieldName 19 33a D dDSext 34 34a D dDS 36 37a D dAllDStypes 34 37a D dStandAlone 35 37a D dProtoProcedur 35 38a D dAttribute 52 52a D dFromPos 40 44a D dFromPosN 40 44s 0 D dStatusWords 38 45a D dToPos 47 51a D dToPosN 47 51s 0 D dDecimalPos 53 54a D dKeyWord 56 92a // I specs D iAttribute 48 48a D iFromPos 49 53a D iToPos 54 58a D iDecimalPos 59 60a D iExternalFld 33 42a D iFieldName 61 74a // C specs D SubRoutine 19 20a D Conditioning 22 23a D Factor1 24 37a D OpCode 38 47a D Opcode1 1a overlay(OpCode:1) D Opcode2 2a overlay(OpCode:1) D Opcode3 3a overlay(OpCode:1) D Opcode4 4a overlay(OpCode:1) D Opcode6 6a overlay(OpCode:1) D Factor2 48 61a D ExtendFactor2 48 92a D ResultField 62 75a D FieldLength 76 80a D FieldLengthN 76 80s 0 D DecimalPos 81 82a D ResultingInd 83 88a D HIind 2a overlay(ResultingInd:1) D LOind 2a overlay(ResultingInd:3) D EQind 2a overlay(ResultingInd:5) D SrcComment 93 112a // 0 specs D oAndOr 28 31a D oLineType 29 29a D oIndicator 33 41a D oSpaceB 52 54a D oSpaceA 55 57a D oSkipB 58 60a D oSkipA 61 63a D oEname 42 55a D oEditCode 56 56a D oEndPos 59 63a D oConstant 65 92a D CopyStatement 25 60a D Src57 19 75a D Src63 13 75a // DDS specs D ddsCondIn1 21 22a D ddsCondIn2 24 25a D ddsCondIn3 27 28a D ddsParenthesis 61 61a D ddsField 57 68a D ddsField2 57 58a D ddsField4 57 60a D ddsField5 57 61a D ddsField6 57 62a D ddsField7 57 63a D ddsField9 57 65a D ddsField10 57 66a /endif /If defined(SqlCLI) //--------------------------------------------------------- // SQL Column types D SqlCHAR c const( 1) D SqlNUMERIC c const( 2) D SqlDECIMAL c const( 3) D SqlLONG c const( 4) D SqlSHORT c const( 5) D SqlFLOAT c const( 6) D SqlREAL c const( 7) D SqlDOUBLE c const( 8) D SqlDATE c const( 91) D SqlTIME c const( 92) D SqlTIMESTAMP... D c const( 93) // Sql constants D SqlNts c const(-3) D SqlTrue c const( 1) D SqlDrop c const( 1) D CommitNone c const( 1) D SysNaming c const(10002) D AttrCommit c const( 0) D SqlNumRcd s 10i 0 D retCode s 10i 0 D henv s 10i 0 D hdbc s 10i 0 D server s 10a inz('*LOCAL') D hstmt s 10i 0 D cOptVal s 10i 0 // Retrieve Error Information D sqlState s 5a D pfNativeErr s 10i 0 D szErrMsg s 256a D cbErrMsg s 5i 0 // Set environment attribute D envAttr s 10i 0 //--------------------------------------------------------- // Allocate Environment Handle D SQLAllocEnv PR 10i 0 extproc('SQLAllocEnv') D * value enviroment handle D SQLBindCol PR 10i 0 extproc('SQLBindCol') D 10i 0 value statement handle D 5i 0 value column number D 5i 0 value data type D * value rgb value D 10i 0 value cb max value D * value pcb value D SQLSetEnvAttr PR 10i 0 extproc('SQLSetEnvAttr') D 10i 0 value enviroment handle D 10i 0 value attr D * value p value D 10i 0 value strlen DSQLAllocConnect PR 10i 0 extproc('SQLAllocConnect') D 10i 0 value enviroment handle D * value ptr to connection D SQLConnect PR 10i 0 extproc('SQLConnect') D 10i 0 value connection handle D * value options(*string) szdsn D 5i 0 value cbdsn D * value options(*string) szuid D 5i 0 value cbuid D * value options(*string) szauthstr D 5i 0 value cbauthstr D SQLSetConnectOption... D PR 10i 0 extproc('SQLSetConnectOption') D 10i 0 value connection handle D 5i 0 value foption D * value vparam D SQLAllocStmt PR 10i 0 extproc('SQLAllocStmt') D 10i 0 value connection handle D * value phstmt D SQLFetch PR 10i 0 extproc('SQLFetch') D 10i 0 value statement handle D SQLExecDirect PR 10i 0 extproc('SQLExecDirect') D 10i 0 value statement handle D * value options(*string) szSqlStr D 10i 0 value cbSqlStr D SQLFreeStmt PR 10i 0 extproc('SQLFreeStmt') D 10i 0 value statement handle D 5i 0 value foption D SQLDisconnect PR 10i 0 extproc('SQLDisconnect') D 10i 0 value connection handle D SQLFreeConnect PR 10i 0 extproc('SQLFreeConnect') D 10i 0 value connection handle D SQLFreeEnv PR 10i 0 extproc('SQLFreeEnv') D 10i 0 value rnvironment handle D SQLError PR 10i 0 extproc('SQLError') D 10i 0 value environment handle D 10i 0 value hdbc D 10i 0 value hstmt D * value szSqlState D * value pfNativeErr D * value szErrMsg D 5i 0 value cbErrMsgMax D * value pcbErrMsg /endif /If defined(System) //--------------------------------------------------------- D System PR 10i 0 extproc('system') cl command processor D * value options(*string) /endif /If defined(UserSpaceHeaderDS) //--------------------------------------------------------- // Get user space list info from header section. D GenericHeader DS qualified based(GenericHeaderPtr) D SizeOfUsrSpc 10i 0 overlay(GenericHeader:105) D OffSetToHeader 10i 0 overlay(GenericHeader:117) D OffSetToList 10i 0 overlay(GenericHeader:125) D ListEntryCount 10i 0 overlay(GenericHeader:133) D ListEntrySize 10i 0 overlay(GenericHeader:137) D UserSpaceName s 20a inz('JCRCMDS QTEMP ') D ForCount s 10i 0 /endif /If defined(UserSpaceHeaderDS2) //--------------------------------------------------------- // Get second user space list info from header section. D GenericHeader2 DS likeds(GenericHeader) D based(GenericHeaderPtr2) D UserSpacename2 s 20a inz('JCRCMDS2 QTEMP ') D ForCount2 s 10i 0 /endif /If defined(f_CrtCmdString) //--------------------------------------------------------- Df_CrtCmdString... D PR 500a varying D 20a const cmd name and lib /endif /If defined(f_AddSortKey) //--------------------------------------------------------- Df_AddSortKey PR 16a D 10i 0 const start pos D 10i 0 const string size D 10i 0 const options(*nopass) data type D 10i 0 const options(*nopass) sort order /endif /If defined(f_BringDataBaseRecords) //--------------------------------------------------------- D f_BringDataBaseRecords... D PR D 10a const file D 10a const lib D 10a const mbr D 10i 0 number of recs /endif /If defined(f_BuildString) //--------------------------------------------------------- D f_BuildString... D PR 2048a opdesc D 2048a const options(*varsize) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) D 100a const options(*nopass:*varsize:*trim) /endif /If defined(f_Centertext) //--------------------------------------------------------- D f_CenterText... D PR 100a opdesc D 100a const options(*varsize) D 3u 0 const options(*nopass) /endif /If defined(f_CheckMbr) //--------------------------------------------------------- D f_CheckMbr PR D 20a const file and lib D 10a const mbr /endif /If defined(f_CheckObj) //--------------------------------------------------------- // validate Object exists D f_CheckObj PR D 20a const object and lib D 10a const object type /endif /If defined(f_GetDayName) //--------------------------------------------------------- D f_GetDayName PR 9a D d const options(*nopass) /endif /If defined(f_MondaysDate) //--------------------------------------------------------- D f_MondaysDate... D PR d D d const options(*nopass) /endif /If defined(f_DayOfWeekNumber) //--------------------------------------------------------- D f_DayOfWeekNumber... D PR 3u 0 D d const /endif /If defined(f_DecodeApiTimeStamp) //--------------------------------------------------------- D f_DecodeApiTimeStamp... D PR 16a api time stamp ds D 8a api date stamp /endif /If defined(f_DelayJobSeconds) //--------------------------------------------------------- D f_DelayJobSeconds... D PR D 5u 0 const seconds to delay /endif /If defined(f_DltOvr) //--------------------------------------------------------- D f_DltOvr PR D 10a const spooled file /endif /If defined(f_DspLastSplf) //--------------------------------------------------------- D f_DspLastSplf PR display last splf D 10a const program name D 8a const * or *PRINT /endif /If defined(f_DupFileToQtemp) //--------------------------------------------------------- D f_DupFileToQtemp... D PR D 10a const file name D 10a const library name D 1a const options(*nopass) override (Y N) /endif /If defined(f_RunOptionFile) //--------------------------------------------------------- D f_RunOptionFile... D PR D 1p 0 const option selected D 10a const file D 10a const lib D 10a const record format D 10a const member D 10a program id /endif /If defined(f_RunOptionJob) //--------------------------------------------------------- D f_RunOptionJob... D PR D 1p 0 option selected D 10a job name D 10a User Name D 6a job number D 10a program id /endif /If defined(f_RunOptionObject) //--------------------------------------------------------- D f_RunOptionObject... D PR D 1p 0 option selected D 10a Object Name D 10a Object Lib D 10a Object type D 10a program id /endif /If defined(f_RunOptionSplf) //--------------------------------------------------------- D f_RunOptionSplf... D PR D 1a option selected D 10a spool file name D 6a spool file number D 10a job name D 10a User Name D 6a job number D 60a email address D 10a program id 2b D IsSndSplf s n 2b D IsEsend s n 2b D IsOneTime s n inz(*on) D EmailAddr s 60a D oE c const('E=ESndMail ') D oS c const('S=SndSplf ') D o2 c const('2=Change ') D o3 c const('3=Hold ') D o4 c const('4=Delete ') D o5 c const('5=Display') /endif /If defined(f_RunDBUtility) //--------------------------------------------------------- D f_RunDBUtility... D PR 60a Execution string D 21a Lib/File D 10a const Member /endif /If defined(f_FakeEditWord) //--------------------------------------------------------- D f_FakeEditWord... D PR 28a opdesc D 288a options(*varsize) date/time format D 1a const date or time /endif /If defined(f_GetCardFace) //--------------------------------------------------------- D f_GetCardFace PR 2a D 3u 0 /endif /If defined(f_GetCardColor) //--------------------------------------------------------- D f_GetCardColor PR 1a hex color attribute D 1a suite (H D C S) /endif /If defined(f_GetRowColumn) //--------------------------------------------------------- D f_GetRowColumn PR 6a D 10a const field name D 10a file D 10a lib D 10a record format D CsrRowColDS DS D CsrRow 3s 0 inz D CsrCol 3s 0 inz /endif /If defined(f_GetApiISO) //--------------------------------------------------------- D f_GetApiISO PR 10a return ISO from api D 13a const /endif /If defined(f_GetFileUtil) //--------------------------------------------------------- D f_GetFileUtil... D PR 6a Set DBU,DFU,WRKDB /endif /If defined(f_GetQual) //--------------------------------------------------------- D f_GetQual PR 21a D 20a const name and lib D ExtIfile s 21a D ExtOFile s 21a /endif /If defined(f_GetRandom) //--------------------------------------------------------- D f_GetRandom PR 3u 0 D 3u 0 const upper limit value /endif /If defined(f_GetApiHMS) //--------------------------------------------------------- D f_GetApiHMS PR 8a from 13 digit api D 13a /endif /If defined(f_IsValidMbr) //--------------------------------------------------------- D f_IsValidMbr PR n D 10a const file D 10a const lib D 10a const options(*nopass) mbr /endif /If defined(f_IsValidMbrType) //--------------------------------------------------------- D f_IsValidMbrType... D PR n D 20a file and lib D 10a const mbr D 10a const mbr type 1 D 10a const options(*nopass) mbr type 2 D 10a const options(*nopass) mbr type 3 D 10a const options(*nopass) mbr type 4 /endif /If defined(f_IsValidObj) //--------------------------------------------------------- D f_IsValidObj PR n D 10a const object D 10a const library D 10a const object type /endif /If defined(f_OutFileAddPfm) //--------------------------------------------------------- D f_OutFileAddPfm... D PR D 20a const new file qual D 10a const new mbr D 8a const mbr type D 50a const options(*nopass) mbr text D 20a const options(*nopass) org file qual D 10a const options(*nopass) org mbr /endif /If defined(f_OutFileCrtDupObj) //--------------------------------------------------------- D f_OutFileCrtDupObj... D PR D 20a const out file and lib D 22a const mbr options D 10a const from object /endif /If defined(f_OvrPrtf) //--------------------------------------------------------- D f_OvrPrtf PR D 10a const spooled file D 10a const options(*omit) outq D 10a const options(*nopass) usrdta /endif /If defined(f_ParmListCount) //--------------------------------------------------------- D f_ParmListCount... D PR 5u 0 D 2a /endif /If defined(f_Pgm) //--------------------------------------------------------- D f_Pgm PR 4096a D 10a const program D 10a const lib D 256a const options(*nopass) parm 1 to 10 D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) D 256a const options(*nopass) /endif /If defined(f_Quscrtus) //--------------------------------------------------------- D f_Quscrtus PR * D 20a user space /endif /If defined(f_Qmhrcvpm) //--------------------------------------------------------- D f_Qmhrcvpm PR 75a receive program msg D 10i 0 const call stack counter /endif /If defined(f_Qusrmbrd) //--------------------------------------------------------- D f_Qusrmbrd PR 256 retrieve mbr desc D 20a const file and lib D 10a const mbr D 8a const api format D QusrmbrdDS DS 256 qualified inz D File 10a overlay(QusrmbrdDS:9) D Lib 10a overlay(QusrmbrdDS:19) D Mbr 10a overlay(QusrmbrdDS:29) D Attribute 10a overlay(QusrmbrdDS:39) D MbrType 10a overlay(QusrmbrdDS:49) D CreateDateTime 13a overlay(QusrmbrdDS:59) D Text 50a overlay(QusrmbrdDS:85) D IsSrcPF n overlay(QusrmbrdDS:135) D CurrNumberRecs 10i 0 overlay(QusrmbrdDS:141) D DeletedRecs 10i 0 overlay(QusrmbrdDS:145) D SizeOfData 10i 0 overlay(QusrmbrdDS:149) D SizeOfPath 10i 0 overlay(QusrmbrdDS:153) D ChangeDateTime 13a overlay(QusrmbrdDS:161) D SaveDateTime 13a overlay(QusrmbrdDS:174) DRestoreDateTime 13a overlay(QusrmbrdDS:187) D LastUseCount 10i 0 overlay(QusrmbrdDS:213) DLastUseDateTime 13a overlay(QusrmbrdDS:217) D SizeOfDataMLT 10i 0 overlay(QusrmbrdDS:233) D SizeOfPathMLT 10i 0 overlay(QusrmbrdDS:237) D Ccsid 10i 0 overlay(QusrmbrdDS:241) /endif /If defined(f_Qusrobjd) //--------------------------------------------------------- D f_Qusrobjd PR 480 retrieve object desc D 20a const object and lib D 10a const oblect type D 8a const options(*nopass) api format D QusrObjDS DS qualified inz D ObjNam 10a overlay(QusrObjDS:9) D Lib 10a overlay(QusrObjDS:19) D ReturnLib 10a overlay(QusrObjDS:39) D ExtendedAttr 10a overlay(QusrObjDS:91) D CreateDateTime 13a overlay(QusrObjDS:65) D ChangeDateTime 13a overlay(QusrObjDS:78) D Text 50a overlay(QusrObjDS:101) D SrcFile 10a overlay(QusrObjDS:151) D SrcLib 10a overlay(QusrObjDS:161) D SrcMbr 10a overlay(QusrObjDS:171) D SaveDateTime 13a overlay(QusrObjDS:194) DRestoreDateTime 13a overlay(QusrObjDS:207) D CreatedByUser 10a overlay(QusrObjDS:220) D LastUsedDate 7a overlay(QusrObjDS:461) cyymmdd format D NumDaysUsed 10i 0 overlay(QusrObjDS:469) D ObjSize 10i 0 overlay(QusrObjDS:473) D MultiplySize 10i 0 overlay(QusrObjDS:477) /endif /If defined(f_RmvSflMsg) //--------------------------------------------------------- D f_RmvSflMsg PR D 10a const program name /endif /If defined(f_RtvMsgAPI) //--------------------------------------------------------- D f_RtvMsgAPI PR 232a retrieve messages D 7a const message id D 112a replace value D 20a const options(*nopass) msg file qual /endif /If defined(f_SbmJob) //--------------------------------------------------------- D f_SbmJob PR D 4096a options(*varsize) const program info D 10a const options(*nopass) jobq D 10a const options(*nopass) jobd /endif /If defined(f_ShuffleDeck) //--------------------------------------------------------- D f_ShuffleDeck PR 2a dim(52) /endif /If defined(f_SndCompMsg) //--------------------------------------------------------- D f_SndCompMsg... D PR D 75a const message text /endif /If defined(f_SndEscapeMsg) //--------------------------------------------------------- D f_SndEscapeMsg PR send error message D 75a value /endif /If defined(f_SndSflMsg) //--------------------------------------------------------- D f_SndSflMsg PR D 10a const program name D 75a const msg text D 7a const options(*nopass) msg id D 10a const options(*nopass) msg file D 10a const options(*nopass) msg lib /endif /If defined(f_SndStatMsg) //--------------------------------------------------------- D f_SndStatMsg... D PR D 75a const message text /endif /If defined(f_System) //--------------------------------------------------------- D f_System PR opdesc cl command processor D 2048a const options(*varsize) /endif /If defined(f_BlankCommentsCL) //--------------------------------------------------------- D f_BlankCommentsCL... D PR 100a D 100a const /endif //--------------------------------------------------------- /If defined(p_JCRBNDR) /If defined(p_JCRBNDRV) D p_JCRBNDRV PR extpgm('JCRBNDRV') /else D p_JCRBNDR PR extpgm('JCRBNDR') /endif D 20a object and lib D 10a object type D 8a output type D 20a outfile and lib D 22a mbropt /endif /If defined(p_JCRCALLR) //--------------------------------------------------------- /If defined(p_JCRCALLRV) D p_JCRCALLRV PR extpgm('JCRCALLRV') /else D p_JCRCALLR PR extpgm('JCRCALLR') /endif D 20a program and lib D 10a src file D 10a src lib D 10a src mbr D 10a program attributes /endif /If defined(p_JCRDUMPR3) //--------------------------------------------------------- D p_JCRDUMPR3 PR extpgm('JCRDUMPR3') display program D 10a const program D 10a const library D 10a const outq D n refresh /endif /If defined(p_JCRFFDR) //--------------------------------------------------------- /If defined(p_JCRFFDRV) D p_JCRFFDRV PR extpgm('JCRFFDRV') /else D p_JCRFFDR PR extpgm('JCRFFDR') /endif D 20a file and lib D 10a record format name D 4a unpack format? D 8a *print or *outfile D 20a outfile and lib D 22a mbr option /endif /If defined(p_JCRGETFLDR) //--------------------------------------------------------- D p_JCRGETFLDR PR extpgm('JCRGETFLDR') D 20a const src file and lib D 10a src mbr D 2a severity D DiagSeverity s 2a /endif /If defined(p_JCRGETCLPR) //--------------------------------------------------------- D p_JCRGETCLPR PR extpgm('JCRGETCLPR') D 20a const src file and lib D 10a src mbr D 2a severity /endif /If defined(p_JCRFDMBRR) //--------------------------------------------------------- D p_JCRFDMBRR PR extpgm('JCRFDMBRR') D 20a /endif /If defined(p_JCRJOBIOR) //--------------------------------------------------------- D p_JCRJOBIOR PR extpgm('JCRJOBIOR') D 10a D 10a D 6a /endif /If defined(p_JCRSUBRR2) //--------------------------------------------------------- D p_JCRSUBRR2 PR extpgm('JCRSUBRR2') D 10a src mbr D 20a src file and lib /endif ]]> v5r4 //--------------------------------------------------------- // JCRCMDSSRV - Service program for JCRCMDS //--------------------------------------------------------- // Functions: // f_AddSortKey - concate on sort key blocks for qlgsort // f_BringDataBaseRecords - pull X number of records into memory // f_BuildString - build string with replacement values // f_BlankCommentsCL - CL source is easier to process if comments are blanked // f_CenterText - returns centered text for any length parm. // f_CheckMbr - check if mbr exists // f_CheckObj - check if object exists // f_CrtCmdString - return command creation parameters in a string // f_DayOfWeekNumber - returns 1 if Sunday, 2 if Monday, etc. // f_GetDayName - returns 'Monday ' if today or parm date is Monday date. // f_MondaysDate - returns Mondays iso date for week of passed date. // f_DecodeApiTimeStamp - accept API time stamp and return data structure. // f_DelayJobSeconds - delay job X number of seconds // f_DltOvr - delete file overrides // f_DspLastSplf - displays last spooled file and send send spooled file message // f_DupFileToQtemp - create duplicate file into Qtemp library with override. // f_FakeEditWord - return edit for date/time format printing // f_GetAllocSize01 - returns size of memory to be allocated for QDBRTVFD call // f_GetCardFace - return A,K,Q,J,10 downto 1 for numeric values passed in. // f_GetRowColumn - return csrrow and csrcol for passed in display file field // f_GetCardColor - return hex value for Color attribute. // f_GetApiHMS - return HH:MM:SS from 13 digit API date/time // f_GetApiISO - return *ISO- date from 13 digit API date/time // f_GetFileUtil - return if DBU, WRKDBF, or STRDFU is data base utility // f_GetQual - return lib/Obj for 20 long input // f_GetRandom - returns random number within range // f_IsValidMbr - returns *on if member exists in selected file // f_IsValidMbrType - validate member type against parameters // f_IsValidObj - returns *on if object exists // f_OutFileAddPfm - addpfm to select lib/file // f_OutFileCrtDupObj - validity check / create OutFiles // f_OvrPrtf - override prtf with outq and/or usrdta // f_ParmListCount - number entries in cmd list // f_Pgm - program to submit (f_SbmJob) // f_Quscrtus - create user space in qtemp, return pointer to that space // f_Qusrmbrd - retrieve member description data structure // f_Qusrobjd - retrieve object description data structure // f_RmvSflMsg - remove message from errmsg subfile. // f_RtvMsgAPI - retrieves messages with substitution values loaded // f_RunOptionFile - execute subfile options related to files // f_RunOptionJob - execute subfile options related to jobs // f_RunOptionObject - execute subfile options related to objects // f_RunOptionSplf - execute subfile options related to Spooled Files // f_RunDBUtility - execute DBU, WRKDBF, or STRDFU depending on what is installed // f_Qmhrcvpm - receive program messages // f_Sbmjob - submit program with variable names as parms! // f_ShuffleDeck - load / random shuffle / cut new deck of cards. // f_SndCompMsg - send completion message // f_SndEscapeMsg - Send error messages for validity checking programs. // f_SndSflMsg - send message to error message subfile. // f_SndStatMsg - send status message // f_System - execute system (Qcmdexc replacement) with error monitoring //--------------------------------------------------------- H NOMAIN DATFMT(*ISO) TIMFMT(*ISO) EXPROPTS(*RESDECPOS) /IF DEFINED(*V6R1M0) H OPTION(*NOUNREF: *NODEBUGIO) /ELSE H OPTION(*NODEBUGIO) /ENDIF H BNDDIR('QSYS/QC2LE') //--*COPY DEFINES------------------------------------------ /Define Ceegsi /Define DspAtr /Define Qdbrtvfd /Define Qmhsndpm /Define Quslfld /Define Qusptrus /Define Qwccvtdt /Define System /Define f_AddSortKey /Define f_BringDataBaseRecords /Define f_BuildString /Define f_BlankCommentsCL /Define f_CenterText /Define f_CheckMbr /Define f_CheckObj /Define f_CrtCmdString /Define f_GetDayName /Define f_MondaysDate /Define f_DayOfWeekNumber /Define f_DecodeApiTimeStamp /Define f_DelayJobSeconds /Define f_DltOvr /Define f_DspLastSplf /Define f_DupFileToQtemp /Define f_FakeEditWord /Define f_GetCardFace /Define f_GetRowColumn /Define f_GetCardColor /Define f_GetFileUtil /Define f_GetQual /Define f_GetRandom /Define f_GetApiHMS /Define f_GetApiISO /Define f_IsValidMbr /Define f_IsValidMbrType /Define f_IsValidObj /Define f_OutFileAddPfm /Define f_OutFileCrtDupObj /Define f_OvrPrtf /Define f_ParmListCount /Define f_Pgm /Define f_Quscrtus /Define f_Qusrmbrd /Define f_Qusrobjd /Define f_Qmhrcvpm /Define f_RmvSflMsg /Define f_RtvMsgAPI /Define f_RunOptionFile /Define f_RunOptionJob /Define f_RunOptionObject /Define f_RunOptionSplf /Define f_RunDBUtility /Define f_SbmJob /Define f_ShuffleDeck /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_System /Define UserSpaceHeaderDS /Define Constants /Define p_JCRJOBIOR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // ApiErrDS is exported to make it available to every program using this service. // Error return code parm for APIs. D ApiErrDS ds qualified export D BytesProvided 10i 0 inz(%size(ApiErrDS)) D BytesReturned 10i 0 inz(0) D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a //--*STAND ALONE------------------------------------------- D GlobalProgramName... D s 10a varying // Import C/C++ global variable D EXCP_MSGID s 7a import('_EXCP_MSGID') // Several utilities use common array to pass field attributes D FieldsArry_NumberOfEntries... D s 10u 0 export D FieldsArry s 192a dim(5000) export //--------------------------------------------------------- // Returns 16 character field with integer values for qlgsort key // block. If 3rd and fourth parms are not passed, load defaults. Pf_AddSortKey B export Df_AddSortKey PI 16a D p_StartPos 10i 0 const D p_StringSize 10i 0 const D p_DataType 10i 0 const options(*nopass) D p_SortOrder 10i 0 const options(*nopass) D KeyBlock ds 16 qualified D aa 10i 0 D bb 10i 0 D cc 10i 0 D dd 10i 0 /free KeyBlock.aa = p_StartPos; keyBlock.bb = p_StringSize; 1b if %parms > 2; KeyBlock.cc = p_DataType; KeyBlock.dd = p_SortOrder; 1x else; KeyBlock.cc = 6; KeyBlock.dd = 1; 1e endif; return KeyBlock; /end-free Pf_AddSortKey... P E //--------------------------------------------------------- // return size of memory to allocate for QDBRTVFD call. P f_GetAllocSize01... P B export D f_GetAllocSize01... D PI 10i 0 return size of data D p_FileQual 20a const qualified file name D p_RcdFmt 10a const record format name D GetAllocSizeDS ds qualified D SizeReturned 10i 0 overlay(GetAllocSizeDS:5) /free callp QDBRTVFD( GetAllocSizeDS: %len(GetAllocSizeDS): ReturnFileQual : 'FILD0100' : p_FileQual : p_RcdFmt : '0' : '*FILETYPE ': '*EXT ': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; return 0; 1x else; return GetAllocSizeDS.SizeReturned; 1e endif; /end-free P f_GetAllocSize01... P E //--------------------------------------------------------- // Asynchronously bring records into memory P f_BringDataBaseRecords... P B export D f_BringDataBaseRecords... D PI D p_file 10a const D p_lib 10a const D p_mbr 10a const D p_numrecs 10i 0 D RrnArry s 10i 0 dim(1000) D xx s 10i 0 D yy s 10i 0 D Qdbbrcds PR extpgm('QDBBRCDS') bring db records D 20a const file and lib D 10a const mbr D 10i 0 dim(1000) rrn array D 10i 0 number rrn Db like(ApiErrDS) /free 1b if p_Numrecs > 1000; yy = 1000; 1x else; yy = p_NumRecs; 1e endif; 1b for xx = 1 to yy; RrnArry(xx) = xx; 1e endfor; callp QDBBRCDS( p_file + p_lib: p_mbr: RrnArry: yy: ApiErrDS); return; /end-free P f_BringDataBaseRecords... P E //--------------------------------------------------------- // Returns string with replacement values loaded from parms. Accepts base string with // replacement values noted by & sign then accepts parms to replace & characters. // Special value &q is arbitrarily used to signify single Quote. You can check // ApiErrDs data structure if your string was returned as error. // NOTE: all character strings passed to this function should be %TRIMR( ) P f_BuildString B export D f_BuildString PI 2048a opdesc D p_String 2048a const options(*varsize) D p_Parm01 100a const options(*nopass:*varsize:*trim) D p_Parm02 100a const options(*nopass:*varsize:*trim) D p_Parm03 100a const options(*nopass:*varsize:*trim) D p_Parm04 100a const options(*nopass:*varsize:*trim) D p_Parm05 100a const options(*nopass:*varsize:*trim) D p_Parm06 100a const options(*nopass:*varsize:*trim) D p_Parm07 100a const options(*nopass:*varsize:*trim) D p_Parm08 100a const options(*nopass:*varsize:*trim) D p_Parm09 100a const options(*nopass:*varsize:*trim) D p_Parm10 100a const options(*nopass:*varsize:*trim) D p_Parm11 100a const options(*nopass:*varsize:*trim) D p_Parm12 100a const options(*nopass:*varsize:*trim) D p_Parm13 100a const options(*nopass:*varsize:*trim) D p_Parm14 100a const options(*nopass:*varsize:*trim) D p_Parm15 100a const options(*nopass:*varsize:*trim) D p_Parm16 100a const options(*nopass:*varsize:*trim) D p_Parm17 100a const options(*nopass:*varsize:*trim) D p_Parm18 100a const options(*nopass:*varsize:*trim) D p_Parm19 100a const options(*nopass:*varsize:*trim) D p_Parm20 100a const options(*nopass:*varsize:*trim) D p_Parm21 100a const options(*nopass:*varsize:*trim) D p_Parm22 100a const options(*nopass:*varsize:*trim) D p_Parm23 100a const options(*nopass:*varsize:*trim) D p_Parm24 100a const options(*nopass:*varsize:*trim) D p_Parm25 100a const options(*nopass:*varsize:*trim) D p_Parm26 100a const options(*nopass:*varsize:*trim) D p_Parm27 100a const options(*nopass:*varsize:*trim) D p_Parm28 100a const options(*nopass:*varsize:*trim) D p_Parm29 100a const options(*nopass:*varsize:*trim) D p_Parm30 100a const options(*nopass:*varsize:*trim) D xx s 3u 0 D QuoteCount s 5i 0 D ParmCount s 5i 0 D cc s 5u 0 D String s 2048a D ParmArry s 100a dim(30) /free ApiErrDS.BytesReturned = 0; //default error handler String = %trimr(p_String); // make Quotes uppercase for remainder of function cc = %scan('&q': String); 1b dow cc > 0; %subst(String:cc:2) = '&Q'; cc = %scan('&q': String: cc + 1); 1e enddo; // There should be even number of Quote characters. QuoteCount = 0; cc = %scan('&Q': String); 1b dow cc > 0; QuoteCount += 1; cc = %scan('&Q': String: cc + 1); 1e enddo; 1b if %rem(QuoteCount: 2) <> 0; ApiErrDS.ErrMsgId = 'CPF9898'; ApiErrDS.MsgReplaceVal = 'Odd number of single Quotes detected.'; ApiErrDS.BytesReturned = %len(%trimr(ApiErrDS.MsgReplaceVal)); return '**ERROR - see field ApiErrDS.MsgReplaceVal**'; 1e endif; //--------------------------------------------------------- // Number of parms should equal number of replacement values // (minus number of single Quotes.) ParmCount = 0; cc = %scan('&': String); 1b dow cc > 0; ParmCount += 1; cc = %scan('&': String: cc + 1); 1e enddo; 1b if (%parms + QuoteCount) <> (ParmCount + 1); 2b if (%parms + QuoteCount) > (ParmCount + 1); ApiErrDS.MsgReplaceVal = 'Too many replacement values passed.'; 2x else; ApiErrDS.MsgReplaceVal = 'Not enough replacement values passed.'; 2e endif; ApiErrDS.ErrMsgId = 'CPF9898'; ApiErrDS.BytesReturned = %len(%trimr(ApiErrDS.MsgReplaceVal)); return '**ERROR - see field ApiErrDS.MsgReplaceVal**'; 1e endif; // Spin through and replace all single Quotes. cc = %scan('&Q': String); 1b dow cc > 0; String = %replace(qs: String: cc: 2); cc = %scan('&Q': String: cc + 1); 1e enddo; // Load replacement value parms into array // so it will be easier to process in the next step. ParmCount = %parms - 1; 1b if ParmCount >= 1; ParmArry(1) = p_Parm01; 1e endif; 1b if ParmCount >= 2; ParmArry(2) = p_Parm02; 1e endif; 1b if ParmCount >= 3; ParmArry(3) = p_Parm03; 1e endif; 1b if ParmCount >= 4; ParmArry(4) = p_Parm04; 1e endif; 1b if ParmCount >= 5; ParmArry(5) = p_Parm05; 1e endif; 1b if ParmCount >= 6; ParmArry(6) = p_Parm06; 1e endif; 1b if ParmCount >= 7; ParmArry(7) = p_Parm07; 1e endif; 1b if ParmCount >= 8; ParmArry(8) = p_Parm08; 1e endif; 1b if ParmCount >= 9; ParmArry(9) = p_Parm09; 1e endif; 1b if ParmCount >= 10; ParmArry(10) = p_Parm10; 1e endif; 1b if ParmCount >= 11; ParmArry(11) = p_Parm11; 1e endif; 1b if ParmCount >= 12; ParmArry(12) = p_Parm12; 1e endif; 1b if ParmCount >= 13; ParmArry(13) = p_Parm13; 1e endif; 1b if ParmCount >= 14; ParmArry(14) = p_Parm14; 1e endif; 1b if ParmCount >= 15; ParmArry(15) = p_Parm15; 1e endif; 1b if ParmCount >= 16; ParmArry(16) = p_Parm16; 1e endif; 1b if ParmCount >= 17; ParmArry(17) = p_Parm17; 1e endif; 1b if ParmCount >= 18; ParmArry(18) = p_Parm18; 1e endif; 1b if ParmCount >= 19; ParmArry(19) = p_Parm19; 1e endif; 1b if ParmCount >= 20; ParmArry(20) = p_Parm20; 1e endif; 1b if ParmCount >= 21; ParmArry(21) = p_Parm21; 1e endif; 1b if ParmCount >= 22; ParmArry(22) = p_Parm22; 1e endif; 1b if ParmCount >= 23; ParmArry(23) = p_Parm23; 1e endif; 1b if ParmCount >= 24; ParmArry(24) = p_Parm24; 1e endif; 1b if ParmCount >= 25; ParmArry(25) = p_Parm25; 1e endif; 1b if ParmCount >= 26; ParmArry(26) = p_Parm26; 1e endif; 1b if ParmCount >= 27; ParmArry(27) = p_Parm27; 1e endif; 1b if ParmCount >= 28; ParmArry(28) = p_Parm28; 1e endif; 1b if ParmCount >= 29; ParmArry(29) = p_Parm29; 1e endif; 1b if ParmCount = 30; ParmArry(30) = p_Parm30; 1e endif; //--------------------------------------------------------- // Load all replacement values into string. // use ceegsi to get actual length of parms. // unload parm array into replace statement. cc = %scan('&': String); 1b for xx = 1 to ParmCount; CEEGSI(xx + 1: DataType: LengthOfParm: MaxLength: *omit); String = %replace(%trimr( %subst(ParmArry(xx): 1: LengthOfParm)): String: cc: 1); cc = %scan('&': String: cc + LengthOfParm); 1e endfor; return String; /end-free P f_BuildString... P E //--------------------------------------------------------- // Returns string with replacement values loaded from parms. Accepts base string with // replacement values noted by & sign then accepts parms to replace & characters. // Special value &q is arbitrarily used to signify single Quote. You can check // ApiErrDs data structure if your string was returned as error. // NOTE: all character strings passed to this function should be %TRIMR( ) P f_BlankCommentsCL... P B export D f_BlankCommentsCL... D PI 100a D LineCL 100a const D IsPreviousLineEndedinPlus... D s n static D IsBlanked s n D IsComment s n D aa s 5i 0 D bb s 5i 0 d Wrka s 100a /free ApiErrDS.BytesReturned = 0; //default error handler Wrka = LineCL; 1b Dou IsBlanked; IsComment = *off; 2b if IsPreviousLineEndedinPlus; aa = 1; IsComment = *on; 2x else; //--------------------------------------------------------- // Rules for when comment actually starts in CL program // 1) if /* starts in 1st position of source // 2) if _/* is found (blank space preceding /*) // 3) if /*_ is found (/* followed by blank space) aa = %scan('/*':Wrka); 3b if aa >0; 4b if aa = 1 or %subst(Wrka: aa-1:1) = ' ' or %subst(Wrka: aa+1:1) = ' '; IsComment = *on; 4e endif; 3e endif; 2e endif; // after comment is started, it can end with */ or '+'. 2b if not IsComment; IsPreviousLineEndedinPlus = *off; IsBlanked = *on; 2x else; bb = %scan('*/':Wrka); 3b if bb > 0; IsComment = *off; IsPreviousLineEndedinPlus = *off; IsBlanked = *off; // check for second comment on same line // fix this scenario later */ /* */ 4b if (bb-aa) < -1; IsBlanked = *on; 1v leave; 4e endif; %subst(Wrka: aa: (bb-aa) + 2) = *blanks; 3x else; %subst(Wrka: aa) = *blanks; IsPreviousLineEndedinPlus = *on; IsBlanked = *on; 3e endif; 2e endif; 1e enddo; return Wrka; /end-free P f_BlankCommentsCL... P E //--------------------------------------------------------- // Return centered text for any length Parm < 101 P f_CenterText B export D f_CenterText PI 100a opdesc D p_String 100a const options(*varsize) D p_Length 3u 0 const options(*nopass) D xx s 3u 0 D CenteredString s 100a /free ApiErrDS.BytesReturned = 0; //default error handler 1b if %parms() < 2; CEEGSI(1: DataType: LengthOfParm: MaxLength: *omit); 1x else; LengthOfParm = p_Length; 1e endif; xx = %uns((LengthOfParm - %len(%trimr(%subst(p_String: 1: LengthOfParm)))) / 2) + 1; %subst(CenteredString: xx) = %subst(p_String: 1: LengthOfParm); Return CenteredString; /end-free Pf_CenterText... P E //--------------------------------------------------------- // Check if member exists. If not, call retrieve message API to pull in // substitution variables and send escape message P f_CheckMbr B export D f_CheckMbr PI D p_FileQual 20a const D p_Mbr 10a const /free f_Qusrmbrd(p_FileQual: p_Mbr: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; return; /end-free P f_CheckMbr... P E //--------------------------------------------------------- // Call QCDRCMDI API to retrieve command creation definitions. // Build command string to create command. P f_CrtCmdString... P B export D f_CrtCmdString... D PI 500a varying D p_CmdQual 20a const D String s 500a varying D LimitUser s 10a inz('YES ') D Qcdrcmdi PR extpgm('QCDRCMDI') command definitions Db like(cmdi0100DS ) receiver D 10i 0 const receiver length D 8a const api format D 20a const file and lib Db like(ApiErrDS) // extracted command definition fields D cmdi0100DS DS 400 qualified D Cmd 10a overlay(cmdi0100DS:9) D Cmdlib 10a overlay(cmdi0100DS:19) D Cpgm 10a overlay(cmdi0100DS:29) D Clib 10a overlay(cmdi0100DS:39) D Sfile 10a overlay(cmdi0100DS:49) D Slib 10a overlay(cmdi0100DS:59) D Smbr 10a overlay(cmdi0100DS:69) D Vpgm 10a overlay(cmdi0100DS:79) D Vlib 10a overlay(cmdi0100DS:89) D Mode 3a overlay(cmdi0100DS:99) D ModeProd 1a overlay(cmdi0100DS:99) D ModeDebug 1a overlay(cmdi0100DS:100) D ModeService 1a overlay(cmdi0100DS:101) D Alw 9a overlay(cmdi0100DS:109) D AlwBpgm 1a overlay(cmdi0100DS:109) D AlwIpgm 1a overlay(cmdi0100DS:110) D AlwExec 1a overlay(cmdi0100DS:111) D AlwInteract 1a overlay(cmdi0100DS:112) D AlwBatch 1a overlay(cmdi0100DS:113) D AlwBrexx 1a overlay(cmdi0100DS:114) D AlwIrexx 1a overlay(cmdi0100DS:115) D AlwBmod 1a overlay(cmdi0100DS:116) D AlwImod 1a overlay(cmdi0100DS:117) D Limit 1a overlay(cmdi0100DS:124) D Pmfil 10a overlay(cmdi0100DS:129) D Pmlib 10a overlay(cmdi0100DS:139) D Msfil 10a overlay(cmdi0100DS:149) D Mslib 10a overlay(cmdi0100DS:159) D Hlpnl 10a overlay(cmdi0100DS:169) D Hlib 10a overlay(cmdi0100DS:179) D Hlpid 10a overlay(cmdi0100DS:189) D Ovpgm 10a overlay(cmdi0100DS:239) D Ovlib 10a overlay(cmdi0100DS:249) D Text 50a overlay(cmdi0100DS:265) /free // Extract command definitions callp QCDRCMDI( cmdi0100DS : %size(cmdi0100DS ): 'CMDI0100': p_CmdQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; //try with *libl callp QCDRCMDI( cmdi0100DS: %size(cmdi0100DS): 'CMDI0100': %subst(p_CmdQual:1:10) + '*LIBL ': ApiErrDS); 1e endif; 1b if cmdi0100DS.LIMIT = '0'; LimitUser = '*NO '; 1e endif; // generate Command creation code String = '?CRTCMD ??CMD(' + %trimr(f_GetQual(cmdi0100DS.CMD + cmdi0100DS.CMDLIB)) + ')'; //--------------------------------------------------------- // CMD program String += ' ??PGM(' + %trimr(f_GetQual(cmdi0100DS.CPGM + cmdi0100DS.CLIB)) + ')'; String += ' ??SRCFILE(' + %trimr(f_GetQual(cmdi0100DS.SFILE + cmdi0100DS.SLIB)) + ')' + ' ??SRCMBR(' + %trimr(cmdi0100DS.SMBR) + ')' + ' ??ALWLMTUSR(' + %trimr(LimitUser) + ')' + ' ??HLPID(' + %trimr(cmdi0100DS.HLPID) + ')'; //--------------------------------------------------------- // Mode where allowed to run String += ' ??MODE('; 1b if cmdi0100DS.MODE = '111'; String += '*ALL'; 1x else; 2b if cmdi0100DS.ModePROD = '1'; String += ' *PROD'; 2e endif; 2b if cmdi0100DS.ModeDEBUG = '1'; String += ' *DEBUG'; 2e endif; 2b if cmdi0100DS.ModeSERVICE = '1'; String += ' *SERVICE'; 2e endif; 1e endif; String += ')'; String += ' ??ALLOW('; 1b if cmdi0100DS.ALW = '111111111'; String += '*ALL'; 1x else; 2b if cmdi0100DS.AlwBPGM = '1'; String += ' *BPGM'; 2e endif; 2b if cmdi0100DS.AlwIPGM = '1'; String += ' *IPGM'; 2e endif; 2b if cmdi0100DS.AlwEXEC = '1'; String += ' *EXEC'; 2e endif; 2b if cmdi0100DS.AlwINTERACT = '1'; String += ' *INTERACT'; 2e endif; 2b if cmdi0100DS.AlwBATCH = '1'; String += ' *BATCH'; 2e endif; 2b if cmdi0100DS.AlwBREXX = '1'; String += ' *BREXX'; 2e endif; 2b if cmdi0100DS.AlwIREXX = '1'; String += ' *IREXX'; 2e endif; 2b if cmdi0100DS.AlwBMOD = '1'; String += ' *BMOD'; 2e endif; 2b if cmdi0100DS.AlwIMOD = '1'; String += ' *IMOD'; 2e endif; 1e endif; String += ')'; //--------------------------------------------------------- 1b if cmdi0100DS.VPGM > *blanks and cmdi0100DS.VPGM <> '*NONE '; String += ' ??VLDCKR(' + %trimr(f_GetQual(cmdi0100DS.VPGM + cmdi0100DS.VLIB)) + ')'; 1e endif; 1b if cmdi0100DS.PMFIL > *blanks and cmdi0100DS.PMFIL <> '*NONE '; String += ' ??PMTFILE(' + %trimr(f_GetQual(cmdi0100DS.PMFIL + cmdi0100DS.PMLIB)) + ')'; 1e endif; 1b if cmdi0100DS.HLPNL > *blanks and cmdi0100DS.HLPNL <> '*NONE '; String += ' ??HLPPNLGRP(' + %trimr(f_GetQual(cmdi0100DS.HLPNL + cmdi0100DS.HLIB)) + ')'; 1e endif; 1b if cmdi0100DS.OVPGM > *blanks and cmdi0100DS.OVPGM <> '*NONE '; String += ' ??PMTOVRPGM(' + %trimr(f_GetQual(cmdi0100DS.OVPGM + cmdi0100DS.OVLIB)) + ')'; 1e endif; String += ' ??TEXT(*SRCMBRTXT)'; return String; /end-free P f_CrtCmdString... P E //--------------------------------------------------------- // Check if object exists. If not, call retrieve message API to pull in // substitution variables and send escape message P f_CheckObj B export D f_CheckObj PI D p_ObjQual 20a const D p_ObjTyp 10a const /free f_QUSROBJD(p_ObjQual: p_ObjTyp: 'OBJD0100'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; return; /end-free P f_CheckObj... P E //--------------------------------------------------------- // Accepts ISO real date field and returns day name. If no date is passed, // function will return name of today date. P f_GetDayName B export D f_GetDayName PI 9a Day Name D p_DateISO d Const options(*NoPass) ISO Date D xx s 3u 0 /free ApiErrDS.BytesReturned = 0; 1b if %parms = 0; xx = f_DayOfWeekNumber(%date()); 1x else; xx = f_DayOfWeekNumber(p_DateISO); 1e endif; 1b if xx = 1; return 'Sunday '; 1x elseif xx = 2; return 'Monday '; 1x elseif xx = 3; return 'Tuesday '; 1x elseif xx = 4; return 'Wednesday'; 1x elseif xx = 5; return 'Thursday '; 1x elseif xx = 6; return 'Friday '; 1x elseif xx = 7; return 'Saturday '; 1x else; ApiErrDS.BytesReturned = 20; ApiErrDS.ErrMsgId = 'CPD5118'; ApiErrDS.MsgReplaceVal = *blanks; 1e endif; /end-free P f_GetDayName... P E //--------------------------------------------------------- // Accepts ISO real date field and returns iso Mondays date for whatever week // parm date was in. If no date is passed, it gets current weeks Monday. If Sunday date // is past, it returns next days date. P f_MondaysDate B export D f_MondaysDate PI d D p_DateISO d Const options(*NoPass) ISO Date D xx s 3i 0 D date s d inz /free ApiErrDS.BytesReturned = 0; //default error handler 1b if %parms = 0; date = %date(); 1x else; date = p_DateISO; 1e endif; xx = f_DayOfWeekNumber(date); 1b if xx = 1; //sunday return date + %days(1); 1x else; return date - %days(%abs(2 - xx)); 1e endif; /end-free P f_MondaysDate... P E //--------------------------------------------------------- // Accepts ISO real date field and returns integer value representing offset from // Saturday. 1=Sunday, 2 = Monday, etc... P f_DayOfWeekNumber... P B export D f_DayOfWeekNumber... D PI 3u 0 Day Of Week D p_DateISO d const D DayOfWeek s 3u 0 D ceedays PR extproc('CEEDAYS') OpDesc day of week lilian D 8a const iso D 8a const Picture D 10i 0 lilian date D 12a const options(*omit) feedback D ceedywk PR extproc('CEEDYWK') day of week lilian D 10i 0 lilian date D 10i 0 D O W number D 12a const options(*omit) feedback D Pic s 8a inz('YYYYMMDD') D Lilian s 10i 0 D xx s 10i 0 D FeedBack s 12a /free ApiErrDS.BytesReturned = 0; //default error handler callp ceedays(%char(p_DateISO:*iso0): Pic: Lilian: *OMIT); callp ceedywk(Lilian: xx: *OMIT); DayOfWeek = xx; return DayOfWeek; /end-free P f_DayOfWeekNumber... P E //--------------------------------------------------------- // Accept API time stamp and return data structure. P f_DecodeApiTimeStamp... P B export D f_DecodeApiTimeStamp... D PI 16a D p_ApiStamp 8a D Alpha16 s 16a /free callp QWCCVTDT( '*DTS ': p_ApiStamp : '*MDY ': Alpha16 : ApiErrDS); return Alpha16; /end-free P f_DecodeApiTimeStamp... P E //--------------------------------------------------------- // Delays job for parm number of seconds. P f_DelayJobSeconds... P B export D f_DelayJobSeconds... D PI D p_Seconds 5u 0 const /free ApiErrDS.BytesReturned = 0; SYSTEM('DLYJOB DLY(' + %char(p_Seconds) + ')'); return; /end-free P f_DelayJobSeconds... P E //--------------------------------------------------------- // Delete file overrides. P f_DltOvr B export D f_DltOvr PI D p_SplfName 10a const /free system('DLTOVR FILE(' + p_SplfName + ') LVL(*JOB)'); return; /end-free P f_DltOvr... P E //--------------------------------------------------------- // Display last spooled file and send completion message P f_DspLastSplf B export D f_DspLastSplf PI D p_ProgName 10a const D p_OutPut 8a const // Return identity for last spooled file created by this job. D Qsprilsp PR extpgm('QSPRILSP') get last splf attrib Db like(LastSplfInfoDS) receiver D 10i 0 const receiver length D 8a const api format Db like(ApiErrDS) // DS of spooled file attributes return variable. D LastSplfInfoDS... D DS 70 qualified inz D SplfName 10a overlay(LastSplfInfoDS:9) D SplfNum 10i 0 overlay(LastSplfInfoDS:45) //------------------------------ /free callp QSPRILSP( LastSplfInfoDS: %len(LastSplfInfoDS): 'SPRL0100': ApiErrDS); 1b if p_OutPut = '* '; f_System('DSPSPLF FILE('+LastSplfInfoDS.SplfName+') SPLNBR(*LAST)'); 1e endif; f_SndCompMsg('Splf ' +%trimr(LastSplfInfoDS.SplfName) + ' number ' + %char(LastSplfInfoDS.SplfNum) + ' generated by ' + %trimr(p_ProgName) + '.'); return; /end-free P f_DspLastSplf... P E //--------------------------------------------------------- // Create duplicate file into Qtemp library with override. P f_DupFileToQtemp... P B export D f_DupFileToQtemp... D PI D p_File 10a const D p_Lib 10a const D p_OvrDbf 1a const options(*nopass) D IsOvrDbf s n /free ApiErrDS.BytesReturned = 0; //default error handler 1b if not f_IsValidMbr(p_File: p_Lib); return; 1x else; 2b if f_IsValidMbr(p_File:'QTEMP '); system('CLRPFM QTEMP/' + p_File); return; 2x else; f_System('CRTDUPOBJ OBJ(' + %trimr(p_File) + ') FROMLIB(' + %trimr(p_Lib) + ') OBJTYPE(*FILE) TOLIB(QTEMP) DATA(*NO)'); system('RMVPFTRG FILE(QTEMP/' + %trimr(p_File) + ')'); IsOvrDbf = *on; 3b if %parms = 3 and p_OvrDbf = 'N'; IsOvrDbf = *off; 3e endif; 3b if IsOvrDbf; system('OVRDBF FILE(' + %trimr(p_File) + ') TOFILE(QTEMP/' + %trimr(p_File) + ') OVRSCOPE(*JOB)'); 3e endif; 2e endif; 1e endif; Return; /end-free P f_DupFileToQtemp... P E //--------------------------------------------------------- // execute DBU, WRKDBF, or STRDFU depending on what is installed P f_RunDBUtility... P B D f_RunDBUtility... D PI 60a D p_FileQual 21a D p_Mbr 10a const /free 1b if f_GetFileUtil() = 'DBU '; return 'DBU FILE(' + %trimr(p_FileQual) + ') MBR(' + %trimr(p_Mbr) + ')'; 1x elseif f_GetFileUtil() = 'WRKDBF'; return 'WRKDBF ' + p_FileQual; 1x else; return 'STRDFU OPTION(5) FILE(' + p_FileQual + ') MBR(' + %trimr(p_Mbr) + ')'; 1e endif; /end-free P f_RunDBUtility... P E //--------------------------------------------------------- // Execute system command depending on option selected. P f_RunOptionFile... P B export D f_RunOptionFile... D PI D p_Option 1p 0 const Option Selected D p_File 10a const File D p_Lib 10a const Lib D p_RcdFmt 10a const Record Format D p_Mbr 10a const Member D p_ProgId 10a program id D p_FileQual s 21a /free p_FileQual = %trimr(f_GetQual(p_File + p_Lib)); 1b if p_Option = 1; f_System(f_BuildString('JCRFFD FILE(&) RCDFMT(&) OUTPUT(*)': p_FileQual: p_RcdFmt)); 1x elseif p_Option = 2; f_System(f_RunDBUtility(p_FileQual: p_Mbr)); 1x elseif p_Option = 3; f_System('JCRFD ' + p_FileQual); 1x elseif p_Option = 4; f_System(f_BuildString('RMVM FILE(&) MBR(&)': p_FileQual: p_Mbr)); 1x elseif p_Option = 9; f_System(f_BuildString('CLRPFM FILE(&) MBR(&)': p_FileQual: p_Mbr)); 1x elseif p_Option = 7; f_System('WRKOBJ *ALL/' + p_File + 'OBJTYPE(*FILE)'); 1x elseif p_Option = 5; f_System(f_BuildString('WRKMBRPDM FILE(&) MBR(&)': p_FileQual: p_Mbr)); 1x else; f_SndSflMsg(p_ProgId: 'Option ' + %char(p_Option) + ' is not available.'); return; 1e endif; f_SndSflMsg(p_ProgId: 'Option '+%char(p_Option) + ' - completed.'); return; /end-free P f_RunOptionFile... P E //--------------------------------------------------------- // Execute system command depending on option selected. P f_RunOptionJob... P B export D f_RunOptionJob... D PI D p_Option 1p 0 D p_JobName 10a D p_JobUser 10a D p_JobNum 6a D p_ProgId 10a D JobString s 33a varying /free JobString = %trimr(f_BuildString('JOB(&/&/&)': p_JobNum: p_JobUser: p_JobName)); 1b if p_Option = 2; f_System('?CHGJOB ' + JobString); 1x elseif p_Option = 3; f_System('STRSRVJOB ' + JobString ); 1x elseif p_Option = 4; f_System('ENDJOB ' + JobString + ' OPTION(*IMMED)'); 1x elseif p_Option = 5; f_System('DSPJOB ' + JobString ); 1x elseif p_Option = 8; f_System('DSPJOB ' + JobString + ' OPTION(*SPLF)'); 1x elseif p_Option = 9; callp(e) p_JCRJOBIOR(p_JobName: p_JobUser: p_JobNum); 1x else; f_SndSflMsg(p_ProgId: 'Option ' + %char(p_Option) + ' is not available.'); return; 1e endif; f_SndSflMsg(p_ProgId: 'Option ' + %char(p_Option)+' - completed.'); return; /end-free P f_RunOptionJob... P E //--------------------------------------------------------- // Execute system command depending on option selected. P f_RunOptionObject... P B export D f_RunOptionObject... D PI D p_Option 1p 0 D p_ObjName 10a D p_ObjLib 10a D p_ObjType 10a D p_ProgId 10a D ObjLibAndName s 21a D QObjLibNameQ s 23a /IF DEFINED(*V6R1M0) D Qlidlto PR extpgm('QLIDLTO') delete object D 20a const name and lib D 10a const type D 10a const auxillary stg D 1a const remove message Db like(ApiErrDS) /ENDIF /free ObjLibAndName = f_GetQual(p_ObjName + p_ObjLib); 1b if p_Option = 1; f_System(f_BuildString('WRKOBJ OBJ(&) OBJTYPE(&)': ObjLibAndName: p_ObjType)); 1x elseif p_Option = 2; f_System(f_BuildString('DSPOBJD OBJ(&) OBJTYPE(&)': ObjLibAndName: p_ObjType)); 1x elseif p_Option = 3; f_System(f_BuildString('WRKOBJLCK OBJ(&) OBJTYPE(&)': ObjLibAndName: p_ObjType)); // call v6r1 delete object APi 1x elseif p_Option = 4; /IF DEFINED(*V6R1M0) callp Qlidlto( p_ObjName + p_ObjLib: p_ObjType: '* ': '0': ApiErrDS); /ELSE QObjLibNameQ = '(' + ObjLibAndName + ')'; 2b if p_ObjType = '*CMD '; f_System('DLTCMD CMD' + QObjLibNameQ); 2x elseif p_ObjType = '*DTAARA '; f_System('DLTDTAARA DTAARA' + QObjLibNameQ); 2x elseif p_ObjType = '*FILE '; f_System('DLTF FILE' + QObjLibNameQ); 2x elseif p_ObjType = '*DTAQ '; f_System('DLTDTAQ DTAQ' + QObjLibNameQ); 2x elseif p_ObjType = '*PNLGRP '; f_System('DLTPNLGRP PNLGRP' + QObjLibNameQ); 2x elseif p_ObjType = '*PGM '; f_System('DLTPGM PGM' + QObjLibNameQ); 2x elseif p_ObjType = '*MODULE '; f_System('DLTMOD MODULE' + QObjLibNameQ); 2x elseif p_ObjType = '*SRVPGM '; f_System('DLTSRVPGM SRVPGM' + QObjLibNameQ); 2x elseif p_ObjType = '*JOBD '; f_System('DLTJOBD JOBD' + QObjLibNameQ); 2x elseif p_ObjType = '*JRN '; f_System('DLTJRN JRN' + QObjLibNameQ); 2x elseif p_ObjType = '*JRNRCV '; f_System('DLTJRNRCV JRNRCV' + QObjLibNameQ); 2x elseif p_ObjType = '*MENU '; f_System('DLTMNU MENU' + QObjLibNameQ); 2x elseif p_ObjType = '*MSGF '; f_System('DLTMSGF MSGF' + QObjLibNameQ); 2x elseif p_ObjType = '*QRYDFN '; f_System('DLTQRY QRY' + QObjLibNameQ); 2x elseif p_ObjType = '*USRSPC '; f_System('DLTUSRSPC USRSPC' + QObjLibNameQ); 2x elseif p_ObjType = '*SCHIDX '; f_System('DLTSCHIDX SCHIDX' + QObjLibNameQ); 2x elseif p_ObjType = '*SQLPKG '; f_System('DLTSQLPKG SQLPKG' + QObjLibNameQ); 2x elseif p_ObjType = '*MSGQ '; f_System('DLTMSGQ MSGQ' + QObjLibNameQ); 2x elseif p_ObjType = '*OUTQ '; f_System('DLTOUTQ OUTQ' + QObjLibNameQ); 2x elseif p_ObjType = '*SBSD '; f_System('DLTSBSD SBSD' + QObjLibNameQ); 2x elseif p_ObjType = '*JOBQ '; f_System('DLTJOBQ JOBQ' + QObjLibNameQ); 2e endif; /ENDIF 1x elseif p_Option = 5; f_System('CLRPFM ' + ObjLibAndName); 1x elseif p_Option = 6; f_System(f_RunDBUtility(ObjLibAndName: '*FIRST ')); 1x elseif p_Option = 8; f_System(f_BuildString('WRKOBJ OBJ(*ALLUSR/&) OBJTYPE(&)': p_ObjName: p_ObjType)); 1x elseif p_Option = 9; f_System('WRKMBRPDM ' + ObjLibAndName); 1x else; f_SndSflMsg(p_ProgId: 'Option ' + %char(p_Option) + ' is not available.'); return; 1e endif; f_SndSflMsg(p_ProgId: 'Option ' + %char(p_Option)+' - completed.'); return; /end-free P f_RunOptionObject... P E //--------------------------------------------------------- // Execute system command depending on option selected. P f_RunOptionSplf... P B export D f_RunOptionSplf... D PI D p_Option 1a D p_SplfName 10a D p_SplfNum 6a D p_JobName 10a D p_JobUser 10a D p_JobNum 6a D p_EmailAddr 60a D p_ProgId 10a D Msg s 75a D SpoolString s 120a varying D Alpha6 ds qualified D num6 6s 0 inz(0) D p_JCREADDR PR extpgm('JCREADDR') one time email setup D 60a or get email address D p_JCRSPLFR2 PR extpgm('JCRSPLFR2') D 10a Job Name D 10a User Name D 6a Job Number D 10a Spooled File Name D 6s 0 Spooled File Number /free // get or setup default email one time 1b if p_Option = 'E' or p_Option = 'S'; callp p_JCREADDR(EmailAddr); 1e endif; 1b if p_Option = 'S'; SpoolString = %trimr(f_BuildString ('SPLF(&) JOB(&/&/&) SPLFN(&)': p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); 1x elseif p_Option = 'E'; SpoolString = %trimr(f_BuildString ('RECIPIENT(&) ATTLIST((* *PDF *N & &/&/& &))': EmailAddr: p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); 1x else; SpoolString = %trimr(f_BuildString ('FILE(&) JOB(&/&/&) SPLNBR(&)': p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); 1e endif; //------------------------------- 1b if p_Option = '1'; f_System('?SNDNETSPLF ' + SpoolString + ' ??TOUSRID(( ))'); 2b if ApiErrDS.BytesReturned = 0; msg = 'Sndnetsplf ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; 3b if ApiErrDS.ErrMsgId = 'CPF6801'; // no replace value returned ApiErrDS.MsgReplaceVal = 'F3 '; 3e endif; msg = %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal)); 2e endif; f_SndSflMsg(p_ProgId: msg); 1x elseif p_Option = 'S'; f_System('?SNDSPLF ' + SpoolString + ' ??TOLIST(' + %trimr(p_EmailAddr) + ') ' + ' ??FRADR(' + %trimr(p_EmailAddr) + ') ' + ' ??SUBJECT(' + %trimr(p_SplfName) + ') ' + ' ??MSGTXT(' + %trimr(p_SplfName) + ') ' + ' ??TOFMT(*PDF) ??TITLE(' + %trimr(p_SplfName) + ')'); 2b if ApiErrDS.BytesReturned = 0; msg = 'Sndsplf ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; msg = 'Sndsplf ' + %trimr(p_SplfName) + ' - Canceled.'; 2e endif; f_SndSflMsg(p_ProgId: msg); 1x elseif p_Option = 'E'; f_System('?ESEND/ESNDMAIL ' + SpoolString); 2b if ApiErrDS.BytesReturned = 0; msg = 'Esend ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; msg = 'Esend ' + %trimr(p_SplfName) + ' - Canceled.'; 2e endif; f_SndSflMsg(p_ProgId: msg); 1x elseif p_Option = '2'; f_System('?CHGSPLFA ' + SpoolString); 2b if ApiErrDS.BytesReturned = 0; msg = 'Change ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; msg = 'Change ' + %trimr(p_SplfName) + ' - Canceled.'; 2e endif; f_SndSflMsg(p_ProgId: msg); 1x elseif p_Option = '3'; f_System('HLDSPLF ' + SpoolString); f_SndSflMsg(p_ProgId: 'Hold Spooled File ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '4'; f_System('DLTSPLF ' + SpoolString); f_SndSflMsg(p_ProgId: 'Delete Spooled File ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '5'; f_System('DSPSPLF ' + SpoolString); f_SndSflMsg(p_ProgId: 'Display Spooled File ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '6'; f_System('RLSSPLF ' + SpoolString); f_SndSflMsg(p_ProgId: 'Release Spooled File ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '7'; //duplicate spooled file Alpha6 = p_SplfNum; callp p_JCRSPLFR2( p_JobName: p_JobUser: p_JobNum: p_SplfName: Alpha6.num6); f_SndSflMsg(p_ProgId: 'Duplicate Spooled File ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '8'; f_System('WRKSPLFA ' + SpoolString); f_SndSflMsg(p_ProgId: 'Work Spooled File Attributes ' + %trimr(p_SplfName) + ' - Completed.'); 1x elseif p_Option = '9'; f_System('?CPYSPLF ' + SpoolString + ' ??TOFILE( )'); 2b if ApiErrDS.BytesReturned = 0; msg = 'Copy ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; msg = 'Copy ' + %trimr(p_SplfName) + ' - Canceled.'; 2e endif; f_SndSflMsg(p_ProgId: msg); 1x elseif p_Option = 'H'; f_System('?SPLF2HTML ' + SpoolString + ' ??TODOC(' + qs + '/kpiReports/' + qs + ') STMFOPT(*REPLACE) FONTSIZE(2)'); 2b if ApiErrDS.BytesReturned = 0; msg = 'SPLF2HTML ' + %trimr(p_SplfName) + ' - Completed.'; 2x else; msg = 'SPLF2HTML ' + %trimr(p_SplfName) + ' - Canceled.'; 2e endif; f_SndSflMsg(p_ProgId: msg); 1x else; f_SndSflMsg(p_ProgId: 'Invalid Option Selected.'); 1e endif; return; /end-free P f_RunOptionSplf... P E //--------------------------------------------------------- // Return edit for date/time format printing P f_FakeEditWord... P B export D f_FakeEditWord... D PI 28a opdesc D p_String 288a options(*varsize) D p_DateType 1a const D wrkString s 288a varying /free 1b if p_DateType = 'Z'; return qs + ' - - - . . . ' + qs; 1x elseif p_DateType = 'T'; CEEGSI(1: DataType: LengthOfParm: MaxLength: *omit); wrkString = %xlate(lo: up: %subst(p_String: 1: LengthOfParm)); 2b if wrkString = 'TIMFMT(*USA)' or wrkString = '*USA'; return qs + ' . XM' + qs; 2x elseif wrkString = 'TIMFMT(*HMS)' or wrkString = 'TIMFMT(*JIS)' or wrkString = '*HMS' or wrkString = '*JIS'; return qs + ' : : ' + qs; 2x elseif wrkString = 'TIMFMT(*ISO)' or wrkString = 'TIMFMT(*EUR)' or wrkString = '*ISO' or wrkString = '*EUR'; return qs + ' . . ' + qs; 2x else; return qs + ' : : ' + qs; 2e endif; 1x elseif p_DateType = 'L' or p_DateType = 'D'; CEEGSI(1: DataType: LengthOfParm: MaxLength: *omit); wrkString = %xlate(lo: up: %subst(p_String: 1: LengthOfParm)); 2b if wrkString = 'DATFMT(*MDY)' or wrkString = 'DATFMT(*YMD)' or wrkString = 'DATFMT(*DMY)' or wrkString = '*MDY' or wrkString = '*YMD' or wrkString = '*DMY'; return qs + ' / / ' + qs; 2x elseif wrkString = 'DATFMT(*JUL)' or wrkString = '*JUL'; return qs + ' / ' + qs; 2x elseif wrkString = 'DATFMT(*ISO)' or wrkString = 'DATFMT(*JIS)' or wrkString = '*ISO' or wrkString = '*JIS'; return qs + ' - - ' + qs; 2x elseif wrkString = 'DATFMT(*USA)' or wrkString = '*USA' or wrkString = ' '; return qs + ' / / ' + qs; 2x elseif wrkString = 'DATFMT(*EUR)' or wrkString = '*EUR'; return qs + ' . . ' + qs; 2e endif; 1e endif; return p_String; /end-free P f_FakeEditWord... P E //--------------------------------------------------------- // Return A,K,Q,J,10 for numeric values passed in. P f_GetCardFace B export D f_GetCardFace PI 2a D p_CardNumVal 3u 0 D FaceOfCard s 2a /free 1b if p_CardNumVal = 01; FaceOfCard = 'A '; 1x elseif p_CardNumVal = 11; FaceOfCard = 'J '; 1x elseif p_CardNumVal = 12; FaceOfCard = 'Q '; 1x elseif p_CardNumVal = 13; FaceOfCard = 'K '; 1x else; FaceOfCard = %char(p_CardNumVal); 1e endif; return FaceOfCard; /end-free P f_GetCardFace... P E //--------------------------------------------------------- // Return color attributes for cards. P f_GetCardColor B export D f_GetCardColor PI 1a hex value D p_CardSuite 1a H S C D D Color s 1a /free 1b if p_CardSuite = 'H'; Color = %bitor(RED: RI); 1x elseif p_CardSuite = 'S'; Color = %bitor(BLUE: RI); 1x elseif p_CardSuite = 'C'; Color = %bitor(YELLOW: RI); 1x elseif p_CardSuite = 'D'; Color = %bitor(WHITE: RI); 1e endif; return Color; /end-free P f_GetCardColor... P E //--------------------------------------------------------- // Spin though user space return field names row and column in DSPF P f_GetRowColumn b export D f_GetRowColumn PI 6a D p_FieldName 10a const D p_File 10a D p_Lib 10a D p_RcdFmt 10a D UserSpaceName s 20a inz('JCRCMDSSRVQTEMP ') D PreviousFile s 10a static D PreviousLib s 10a static D CsrRowColDS ds D CsrRow 3s 0 D CsrCol 3s 0 /free 1b if not(p_File = PreviousFile and p_Lib = PreviousLib); PreviousFile = p_File; PreviousLib = p_Lib; GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLFLD( UserSpaceName: 'FLDL0100': p_File + p_Lib: p_RcdFmt: '0': ApiErrDS); 1e endif; QuslfldPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if p_FieldName = QuslfldDS.FieldName; csrrow = QuslfldDS.ScreenFieldRow; csrcol = QuslfldDS.ScreenFieldCol; 1v leave; 2e endif; QuslfldPtr += GenericHeader.ListEntrySize; 1e endfor; return CsrRowColDS; /end-free P f_GetRowColumn... P E //--------------------------------------------------------- // return *ISO- from 13 digit API date/time P f_GetApiISO B export D f_GetApiISO PI 10a D p_DateTime 13a const D alpha10 s 10a /free 1b if %subst(p_DateTime: 1: 1) = ' ' or %subst(p_DateTime: 1: 1) = x'00'; return ' '; 1e endif; 1b if %subst(p_DateTime: 1: 1) = '1'; alpha10 = '20'; 1x else; alpha10 = '19'; 1e endif; %subst(alpha10: 3: 3) = %subst(p_DateTime: 2: 2) + '-'; %subst(alpha10: 6: 3) = %subst(p_DateTime: 4: 2) + '-'; %subst(alpha10: 9: 2) = %subst(p_DateTime: 6: 2); return alpha10; /end-free P f_GetApiISO... P E //--------------------------------------------------------- // Return screen field for type data base utility installed // If neither DBU or WRKDBF is installed, default to STRDFU P f_GetFileUtil B export D f_GetFileUtil PI 6a D xx s 10i 0 /free ApiErrDS.BytesReturned = 0; //default error handler xx = system('CHKOBJ dbu *cmd'); 1b if xx = 0; return 'DBU '; 1e endif; xx = system('CHKOBJ wrkdbf *cmd'); 1b if xx = 0; return 'WRKDBF'; 1e endif; return 'STRDFU'; /end-free P f_GetFileUtil... P E //--------------------------------------------------------- // Return LIB/OBJ for 'OBJ LIB ' passed in P f_GetQual B export D f_GetQual PI 21a D p_String 20a const /free return %trimr(%subst(p_String: 11: 10)) + '/' + %subst(p_String: 1: 10); /end-free P f_GetQual... P E //--------------------------------------------------------- // Input parm is upper range limiter. // Return value is random number between 1 and upper range P f_GetRandom B export D f_GetRandom PI 3u 0 D p_UpperLimit 3u 0 const D RandFloat8 s 8f double precision D RandInt4 s 10i 0 STATIC unsigned integer D RandAlpha8 s 8a feed back D ceeran0 PR extproc('CEERAN0') get random number D 10i 0 RandInt4 D 8f RandFloat8 D 8a RandAlpha8 /free callp CEERAN0( RandInt4: RandFloat8: RandAlpha8); return (p_UpperLimit * RandFloat8) + 1; /end-free P f_GetRandom... P E //--------------------------------------------------------- // Return HH:MM:SS time from 13 digit API date/time P f_GetApiHMS B export D f_GetApiHMS PI 8a D p_DateTime 13a /free 1b if %subst(p_DateTime: 8: 1) = ' ' or %subst(p_DateTime: 8: 1) = x'00'; return ' '; 1x else; return %subst(p_DateTime: 8: 2) + ':' + %subst(p_DateTime: 10: 2) + ':' + %subst(p_DateTime: 12: 2); 1e endif; /end-free P f_GetApiHMS... P E //--------------------------------------------------------- // If member exists, return *on; P f_IsValidMbr B export D f_IsValidMbr PI n D p_File 10a const D p_Lib 10a const D p_Mbr 10a const options(*nopass) D mbrVar s 10a /free 1b if %parms = 2; mbrVar = '*FIRST '; 1x else; mbrVar = p_Mbr; 1e endif; QusrmbrdDS = f_Qusrmbrd(p_File + p_Lib: mbrVar: 'MBRD0100'); return (ApiErrDS.BytesReturned = 0); /end-free P f_IsValidMbr... P E //--------------------------------------------------------- // If object exists return *on; P f_IsValidObj B export D f_IsValidObj PI n D p_ObjNam 10a const D p_ObjLib 10a const D p_ObjTyp 10a const D Alpha8 s 8a /free f_QUSROBJD(p_ObjNam + p_ObjLib: p_ObjTyp: 'OBJD0100'); return (ApiErrDS.BytesReturned = 0); /end-free P f_IsValidObj... P E //--------------------------------------------------------- // Validate extracted member type against (up to) 4 types passed in as parms. You must pass // in at least one type. Note: I usually forbid a function changing parameters, but in this // case all programs using this function would benefit from having actual library // returned if library is '*LIBL '. P f_IsValidMbrType... P B export D f_IsValidMbrType... D PI n D p_FileQual 20a D p_Mbr 10a const D p_Type1 10a const member type 1 D p_Type2 10a const options(*nopass) member type 2 D p_Type3 10a const options(*nopass) member type 3 D p_Type4 10a const options(*nopass) member type 4 /free clear QusrmbrdDS.MbrType; QusrmbrdDS = f_Qusrmbrd(p_FileQual: p_Mbr: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; 1b if %subst(p_FileQual: 11: 10) = '*LIBL '; %subst(p_FileQual: 11: 10) = QusrmbrdDS.Lib; 1e endif; 1b if QusrmbrdDS.MbrType = p_Type1 or %parms >= 4 and QusrmbrdDS.MbrType = p_Type2 or %parms >= 5 and QusrmbrdDS.MbrType = p_Type3 or %parms = 6 and QusrmbrdDS.MbrType = p_Type4; return *on; 1x else; return *off; 1e endif; /end-free P f_IsValidMbrType... P E //--------------------------------------------------------- // Add member to existing file P f_OutFileAddPfm... P B export D f_OutFileAddPfm... D PI D p_NewFileQual 20a const D p_NewMbr 10a const D p_MbrType 8a const D p_MbrText 50a const options(*nopass) D p_OrgFileQual 20a const options(*nopass) D p_OrgMbr 10a const options(*nopass) /free // get original member text 1b if %parms = 6; QusrmbrdDS = f_Qusrmbrd(p_OrgFileQual: p_OrgMbr: 'MBRD0100'); QusrmbrdDS.Text = %xlate(qd + qs + '<&%':' ': QusrmbrdDS.Text); 1x else; QusrmbrdDS.Text = %xlate(qd + qs + '<&%':' ': p_MbrText); QusrmbrdDS.MbrType = p_MbrType; 1e endif; // If out member does not exists, create one. 1b if Not f_IsValidMbr(%subst(p_NewFileQual: 1: 10): %subst(p_NewFileQual: 11: 10): p_NewMbr); f_system(f_BuildString('ADDPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)': f_GetQual(p_NewFileQual): p_NewMbr: QusrmbrdDS.MbrType: QusrmbrdDS.Text)); 1x else; f_System(f_BuildString( 'CHGPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)': f_GetQual(p_NewFileQual): p_NewMbr: QusrmbrdDS.MbrType: QusrmbrdDS.Text)); f_system(f_BuildString('CLRPFM FILE(&) MBR(&)': f_GetQual(p_NewFileQual):p_NewMbr)); 1e endif; return; /end-free P f_OutFileAddPfm... P E //--------------------------------------------------------- // Validity check / create OutFile P f_OutFileCrtDupObj... P B export D f_OutFileCrtDupObj... D PI D p_FileQual 20a const D p_MbrOpt 22a const D p_FromObj 10a const D DataFileQual s 20a D RealMbr s 10a D LevelIDFrom s like(fild0200DS.LevelID) //--*DATA STRUCTURES--------------------------------------- // file header for fild0200 format D fild0200DS ds qualified inz D BytesReturned 10i 0 D BytesAvail 10i 0 D LevelID 13a overlay(fild0200DS:81) D fillerx 3000a overlay(fild0200ds:1) D OutFileDS ds D OutFile 10a D OutLib 10a D MbrOptDS ds D NumEntries 5i 0 D OutMbr 10a D OutMbrOpt 10a /free OutFileDS = p_FileQual; MbrOptDS = p_MbrOpt; RealMbr = OutMbr; 1b if OutFile = *blanks; f_SndEscapeMsg('Must select OutFile name'); 1e endif; // cannot use JCRCMDS from-object as OutFile. 1b if OutFile = p_FromObj; f_SndEscapeMsg('Select OutFile name other than ' + %trimr(p_FromObj) + '.'); 1e endif; //--------------------------------------------------------- 1b if (OutLib <> '*LIBL') and (OutLib <> '*CURLIB') and not f_IsValidObj(OutLib: 'QSYS ': '*LIB '); f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; ApiErrDS.ErrMsgId = *blanks; f_IsValidMbr(OutFile: OutLib: OutMbr); //--------------------------------------------------------- 1b if ApiErrDS.ErrMsgId = 'CPF9812'; 2b if OutLib = '*LIBL '; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 2x else; f_system( f_BuildString('CRTDUPOBJ OBJ(&) FROMLIB(*LIBL) + OBJTYPE(*FILE) TOLIB(&) NEWOBJ(&) DATA(*NO)': p_FromObj: OutLib: OutFile)); 3b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': Error occurred on CRTPF'); 3e endif; f_system( f_BuildString('RMVM FILE(&/&) MBR(*ALL)': OutLib: OutFile)); exsr srAddPfm; 2e endif; // if File exists but member does not, // make sure member can be added to File. 1x elseif ApiErrDS.ErrMsgId = 'CPF9815'; exsr srAddPfm; 1x elseif ApiErrDS.ErrMsgId > *blanks; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; 1b if OutMbrOpt = '*REPLACE '; f_system( f_BuildString('CLRPFM FILE(&/&) MBR(&)': OutLib: OutFile: RealMbr)); 1e endif; // compare record format ID for level check issues DataFileQual = p_FromObj + '*LIBL '; exsr srQDBRTVFD; LevelIDFrom = fild0200DS.LevelID; DataFileQual = OutFile + OutLib; exsr srQDBRTVFD; 1b if LevelIDFrom <> fild0200DS.LevelID; f_SndEscapeMsg( f_BuildString('CPF4131: Level check on file & in library &.': OutFile: OutLib)); 1e endif; return; //--------------------------------------------------------- begsr srQDBRTVFD; callp QDBRTVFD( fild0200DS: %len(fild0200DS): ReturnFileQual: 'FILD0200' : DataFileQual: '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; endsr; //--------------------------------------------------------- begsr srAddPfm; clear ApiErrDS.ErrMsgId; RealMbr = OutMbr; 1b if OutMbr = '*FIRST '; RealMbr = OutFile; 1e endif; f_system(f_BuildString('ADDPFM &/& &': OutLib: OutFile: realMbr)); 1b if (ApiErrDS.ErrMsgId = 'CPF7306'); f_SndEscapeMsg('Members for OutFile more than MAX allowed.'); 1e endif; endsr; /end-free P f_OutFileCrtDupObj... P E //--------------------------------------------------------- // Override prtf with outq and/or user data. P f_OvrPrtf B export D f_OvrPrtf PI D p_SplfName 10a const D p_Outq 10a const options(*omit) D p_UsrDta 10a const options(*nopass) /free f_DltOvr(p_SplfName); 1b if %parms = 2; f_System('OVRPRTF FILE(' + p_SplfName + ') OUTQ(' + p_Outq + ') OVRSCOPE(*JOB)'); 1e endif; 1b if %parms = 3; 2b if %addr(p_Outq) = *null; f_System('OVRPRTF FILE(' + p_SplfName + ') USRDTA(' + p_UsrDta + ') OVRSCOPE(*JOB)'); 2x else; f_System('OVRPRTF FILE(' + p_SplfName + ') OUTQ(' + p_Outq + ') USRDTA(' + p_UsrDta + ') OVRSCOPE(*JOB)'); 2e endif; 1e endif; return; /end-free P f_OvrPrtf... P E //--------------------------------------------------------- // Return number of elements passed in parameter list. P f_ParmListCount... P B export D f_ParmListCount... D PI 5u 0 D p_ListParm 2a D ExtractDS ds qualified D bin 1 2b 0 /free ApiErrDS.BytesReturned = 0; //default error handler ExtractDS = p_ListParm; return %uns(ExtractDS.bin); /end-free P f_ParmListCount... P E //--------------------------------------------------------- // Used as parm on f_SbmJob function. This function returns SBMJOB string with // parms converted from variable names to variables values. P f_Pgm B export D f_Pgm PI 4096a D p_PgmName 10a const D p_Lib 10a const D p_Parm01 256a const options(*nopass) D p_Parm02 256a const options(*nopass) D p_Parm03 256a const options(*nopass) D p_Parm04 256a const options(*nopass) D p_Parm05 256a const options(*nopass) D p_Parm06 256a const options(*nopass) D p_Parm07 256a const options(*nopass) D p_Parm08 256a const options(*nopass) D p_Parm09 256a const options(*nopass) D p_Parm10 256a const options(*nopass) D String s 4096a varying /free GlobalProgramName = p_PgmName; %len(String) = 0; String = 'CALL PGM(' + %trimr(p_Lib) + '/' + %trimr(p_PgmName) + ')'; 1b if %parms = 2 ; return String; 1x else; // start loading parm fields 2b if %parms >= 3; String += ' PARM(' + %trimr(p_Parm01); 2e endif; 2b if %parms >= 4; String += ' ' + %trimr(p_Parm02); 2e endif; 2b if %parms >= 5; String += ' ' + %trimr(p_Parm03); 2e endif; 2b if %parms >= 6; String += ' ' + %trimr(p_Parm04); 2e endif; 2b if %parms >= 7; String += ' ' + %trimr(p_Parm05); 2e endif; 2b if %parms >= 8; String += ' ' + %trimr(p_Parm06); 2e endif; 2b if %parms >= 9; String += ' ' + %trimr(p_Parm07); 2e endif; 2b if %parms >= 10; String += ' ' + %trimr(p_Parm08); 2e endif; 2b if %parms >= 11; String += ' ' + %trimr(p_Parm09); 2e endif; 2b if %parms = 12; String += ' ' + %trimr(p_Parm10); 2e endif; 1e endif; String += ')'; return String; /end-free P f_Pgm... P E //--------------------------------------------------------- // Create user space, change attributes to allow automatic extendibility, // and return pointer to user space. P f_Quscrtus B export D f_Quscrtus PI * D p_UserSpace 20a D uPtr s * D ReturnLib s 10a D Quscrtus PR extpgm('QUSCRTUS') create user space D 20a user space D 10a const extended attribute D 10i 0 const length of space D 1a const hex0 initialize D 10a const use authority D 50a const text D 10a const replace object Db like(ApiErrDS) D 10a const domain D 10i 0 const transfer size D 1a const optimum space D Quscusat PR extpgm('QUSCUSAT') change space attrib D 10a return library D 20a user space Db like(QuscusatDS) key to change Db like(ApiErrDS) D QuscusatDS DS qualified D NumberRecs 10i 0 overlay(QuscusatDS:1) inz(2) D Key1 10i 0 overlay(QuscusatDS:5) inz(2) Initial Value D LengthOfData1 10i 0 overlay(QuscusatDS:9) inz(1) D Data1 1a overlay(QuscusatDS:13) inz(x'00') D Key2 10i 0 overlay(QuscusatDS:14) inz(3) Auto Extend D LengthOfData2 10i 0 overlay(QuscusatDS:18) inz(1) D Data2 1a overlay(QuscusatDS:22) inz('1') /free callp QUSCRTUS( p_UserSpace: 'JCRCMDS': 8192: x'00': '*ALL': 'User Space JCRCMDS ': '*NO': ApiErrDS: '*DEFAULT': 32: '1'); callp QUSCUSAT( ReturnLib: p_UserSpace: QuscusatDS: ApiErrDS); callp QUSPTRUS( p_UserSpace: uPtr: ApiErrDS ); return uPtr; /end-free P f_Quscrtus... P E //--------------------------------------------------------- // Return member information P f_Qusrmbrd B export D f_Qusrmbrd PI 256a D p_FileQual 20a const D p_Mbr 10a const D p_ApiFormat 8a const D Qusrmbrd PR extpgm('QUSRMBRD') retrieve mbr desc D 256a options(*varsize) receiver D 10i 0 const receiver length D 8a const api format D 20a const file and lib D 10a const mbr D 1a const overrides Db like(ApiErrDS) /free callp Qusrmbrd( QusrmbrdDS: 256: p_ApiFormat: p_FileQual: p_Mbr: '0': ApiErrDS); return QusrmbrdDS; /end-free P f_Qusrmbrd... P E //--------------------------------------------------------- // Execute Qusrobjd API, included in copy is DS to extract values. // If format not passed, OBJD0200 is used as default. P f_Qusrobjd B export D f_Qusrobjd PI 480a D p_ObjQual 20a const D p_ObjTyp 10a const D p_ApiFormat 8a const options(*nopass) D LocalApiFormat... D s 8a D Qusrobjd PR extpgm('QUSROBJD') object description Db 472a options(*varsize) receiver D 10i 0 const receiver length D 8a const api format D 20a const object and lib D 10a const object type Db like(ApiErrDS) /free 1b if %parms = 2; LocalApiFormat = 'OBJD0200'; 1x else; LocalApiFormat = p_ApiFormat; 1e endif; callp QUSROBJD( QusrobjDS: %len(QusrobjDS): LocalApiFormat: p_ObjQual: p_ObjTyp: ApiErrDS); return QUSROBJDS; /end-free P f_Qusrobjd... P E //--------------------------------------------------------- // Remove all messages from error message subfile P f_RmvSflMsg B export D f_RmvSflMsg PI D p_ProgName 10a const D Qmhrmvpm PR ExtPgm('QMHRMVPM') D 10a const D 10i 0 const D 4a const D 10a const Ds like(ApiErrDS) /free callp Qmhrmvpm( p_ProgName: 0: ' ': '*ALL': ApiErrDs); return; /end-free P f_RmvSflMsg... P E //--------------------------------------------------------- // Retrieve error message replacement values. P f_RtvMsgAPI B export D f_RtvMsgAPI PI 232a D p_ErrMsgID 7a const D p_MsgReplace 112a D p_MsgFileQual 20a const options(*nopass) D mMsgf s 20a D mMsgLen s 10i 0 inz(%len(QmhrtvmDS)) D QmhrtvmDS DS qualified inz D MessageRtvLen 10i 0 overlay(QmhrtvmDS:9) length msg retrieved D MessageRtv 232a overlay(QmhrtvmDS:25) message retrieved D Qmhrtvm PR extpgm('QMHRTVM') retrieve messages D 256a message retrieved D 10i 0 length Of message D 8a const api format D 7a const message indentifier D 20a const msgf and lib D 100a const replacement data D 10i 0 const replace data length D 10a const substitution char D 10a const format control char Db like(ApiErrDS) /free 1b if %parms = 2; mMsgf = 'QCPFMSG *LIBL'; 2b if %subst(p_ErrMsgID: 1: 2) = 'RN'; mMsgf = 'QRPGLEMSG QDEVTOOLS'; 2e endif; 1x else; mMsgf = p_MsgFileQual; 1e endif; // need a way to analyze message field data // for now address specific problems as they occur. // CPF0201 Command not created uses &2 and &3, ignores &1 1b if p_ErrMsgid = 'CPF0201'; p_MsgReplace = ' ' + p_MsgReplace; 1e endif; // call retrieve message API to pull in substitution variables callp QMHRTVM( QmhrtvmDS : mMsgLen : 'RTVM0100': p_ErrMsgID: mMsgf: p_MsgReplace: %size(p_MsgReplace): '*YES ': '*NO ': ApiErrDS); // If too long, set length to size of return value 1b if QmhrtvmDS.MessageRtvLen > %size(QmhrtvmDS.MessageRtv); QmhrtvmDS.MessageRtvLen = %size(QmhrtvmDS.MessageRtv); 1e endif; // Only return populated message length Return %subst(QmhrtvmDS.MessageRtv: 1: QmhrtvmDS.MessageRtvLen); /end-free P f_RtvMsgAPI... P E //--------------------------------------------------------- // Receive program messages P f_qmhrcvpm B export D f_qmhrcvpm PI 75a D p_CallStack 10i 0 const D Qmhrcvpm PR ExtPgm('QMHRCVPM') receive pgm messages Db like(rcvm0100DS) D 10i 0 const D 8a const D 10a const D 10i 0 const D 10a const D 4a const D 10i 0 const D 10a const Db like(ApiErrDS) D rcvm0100DS ds qualified D BytesReturned 10i 0 overlay(rcvm0100DS:1) D BytesAvail 10i 0 overlay(rcvm0100DS:5) D LenOfMsg 10i 0 overlay(rcvm0100DS:41) D MessageText 100a overlay(rcvm0100DS:49) /free callp QMHRCVPM( rcvm0100DS: %len(rcvm0100DS): 'RCVM0100': '*': p_CallStack: '*LAST ': ' ': 10: '*REMOVE ': ApiErrDS); return rcvm0100DS.MessageText; /end-free P f_qmhrcvpm... P E //--------------------------------------------------------- // Use in conjunction with f_Pgm and functions to allow submit jobs with variable // names as parms instead of building string. P f_SbmJob B export D f_SbmJob PI D p_PgmInfo 4096a options(*varsize) const D p_Jobq 10a const options(*nopass) D p_Jobd 10a const options(*nopass) D Qcmdexc PR extpgm('QCMDEXC') CL Command Processor D 4096a options(*varsize) D 15p 5 Const D jobqLocal s 10a D jobdLocal s 10a D String s 4096a /free ApiErrDS.BytesReturned = 0; 1b if %parms < 2; JobqLocal = '*JOBD '; JobdLocal = '*USRPRF '; 1x elseif %parms = 2; jobqLocal = p_Jobq; JobdLocal = '*USRPRF '; 1x else; jobqLocal = p_Jobq; jobdLocal = p_Jobd; 1e endif; String = 'SBMJOB CMD(' + %trimr(p_PgmInfo) + ') JOB(' + GlobalProgramName + ') JOBQ(' + %trimr(jobqLocal) + ') JOBD(' + %trimr(jobdLocal) + ')'; callp QCMDEXC(string : %len(%trimr(string))); ApiErrDS.MsgReplaceVal = f_qmhrcvpm(1); return; /end-free P f_SbmJob... P E //--------------------------------------------------------- // Return shuffled deck of 52 cards (numeric values and suite info) P f_ShuffleDeck B export D f_ShuffleDeck PI 2a dim(52) D aa s 3u 0 D bb s 3u 0 D cc s 3u 0 inz D ShuffledDeck s 2a dim(52) D NewDeck ds 2 dim(52) inz qualified D NewCard 3u 0 D NewSuite 1a /free // load fresh deck 1b for aa = 4 downto 1; 2b for bb = 13 downto 1; cc += 1; NewDeck(cc).NewSuite = %subst('HSCD': aa: 1); NewDeck(cc).NewCard = bb; 2e endfor; 1e endfor; // Use random function to pull cards from NewDeck. Do twice. 1b for cc = 1 to 2; 2b for aa = 52 downto 1; bb = f_GetRandom(aa); ShuffledDeck(aa) = NewDeck(bb); NewDeck(bb) = NewDeck(aa); 2e endfor; NewDeck(*) = ShuffledDeck(*); 1e endfor; return ShuffledDeck; /end-free P f_ShuffleDeck... P E //--------------------------------------------------------- // Send completion messages. P f_SndCompMsg B export D f_SndCompMsg PI D p_MsgTxt 75a const /free callp QMHSNDPM( ' ': ' ': p_MsgTxt: 75: '*INFO ': '*CTLBDY ': 1: ' ': ApiErrDS); return; /end-free P f_SndCompMsg... P E //--------------------------------------------------------- // Send error messages for validity checking programs. P f_SndEscapeMsg B export D f_SndEscapeMsg PI D p_MsgTxt 75a value /free p_MsgTxt = '0000' + p_MsgTxt; callp QMHSNDPM( 'CPD0006 ': 'QCPFMSG *LIBL ': p_MsgTxt: %size(p_MsgTxt): '*DIAG' : '*CTLBDY': 1: ' ': ApiErrDS); clear p_MsgTxt; callp QMHSNDPM( 'CPF0002 ': 'QCPFMSG *LIBL ': p_MsgTxt: %size(p_MsgTxt): '*ESCAPE ': '*CTLBDY': 1: ' ': ApiErrDS); return; /end-free P f_SndEscapeMsg... P E //--------------------------------------------------------- // Send message to error message subfile P f_SndSflMsg B export D f_SndSflMsg PI D p_ProgName 10a const D p_MsgTxt 75a const D p_MsgID 7a const options(*nopass) D p_MsgFile 10a const options(*nopass) D p_MsgLib 10a const options(*nopass) D MsgID s 7a D MsgFileQual s 20a /free 1b if %parms < 3; clear msgid; clear MsgFileQual; 1x else; msgid = p_MsgID; 2b if %parms < 5; msgFileQual = p_MsgFile + '*LIBL '; 2x else; msgFileQual = p_MsgFile + p_MsgLib; 2e endif; 1e endif; callp QMHSNDPM( msgid: msgFileQual: p_MsgTxt: %len(p_MsgTxt): '*INFO': p_ProgName: 0: ' ': ApiErrDs); return; /end-free P f_SndSflMsg... P E //--------------------------------------------------------- // Send Status messages. P f_SndStatMsg B export D f_SndStatMsg PI D p_MsgTxt 75a const /free callp QMHSNDPM( 'CPF9898': 'QCPFMSG *LIBL ': p_MsgTxt: 75: '*STATUS': '*EXT': 1: ' ': ApiErrDS); return; /end-free P f_SndStatMsg... P E //--------------------------------------------------------- // Execute C function system using global exception variable P f_System B export D f_System PI opdesc D p_String 2048a const options(*varsize) /free CEEGSI(1: DataType: LengthOfParm: MaxLength: *omit); EXCP_MSGID = *blanks; 1b if system(%subst(p_String: 1: LengthOfParm)) = 1 and EXCP_MSGID > *blanks; ApiErrDS.ErrMsgId = EXCP_MSGID; 2b if ApiErrDS.ErrMsgId = 'CPF6801'; //f3 or f12 pressed ApiErrDS.MsgReplaceVal = 'F3'; else; ApiErrDS.MsgReplaceVal = *blanks; endif; ApiErrDS.BytesReturned = 7; 1x else; ApiErrDS.BytesReturned = 0; 1e endif; return; /end-free P f_System... P E ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRCOMPOST - recompile JCRCMDS utilities */ /* CALL JCRCOMPOST PARM(library where source is located) */ /* This program should be run after all members are extracted to */ /* source file JCRCMDS in mylib to compile all objects. */ /*--------------------------------------------------------------------------*/ /* Program Summary: */ /* Define data structures */ /* Create user space */ /* Retrieve pointer to user space */ /* Load user space with member names */ /* Loop until all entries have been processed */ /*--------------------------------------------------------------------------*/ /* note: For cl program JCRSSQLC to compile, you must be authorized */ /* to use the DMPSYSOBJ command on your system. If you are not */ /* authorized to that command, answer the run-time message with 'I'. */ /*--------------------------------------------------------------------------*/ PGM PARM(&LIBINSTALL) DCL VAR(&LIBINSTALL) TYPE(*CHAR) LEN(10) DCL VAR(&COUNT) TYPE(*UINT) VALUE(0) DCL VAR(&DUMMY) TYPE(*CHAR) LEN(1) /* Define pointer to user space */ DCL VAR(&HEADPTR) TYPE(*PTR) ADDRESS(&DUMMY) DCL VAR(&QUSLMBRPTR) TYPE(*PTR) ADDRESS(&DUMMY) /* Define generic API header data structure */ DCL VAR(&APIHEADER) TYPE(*CHAR) STG(*BASED) + LEN(140) BASPTR(&HEADPTR) DCL VAR(&BB) TYPE(*CHAR) STG(*DEFINED) LEN(4) + DEFVAR(&APIHEADER 125) DCL VAR(&CC) TYPE(*char) STG(*DEFINED) + LEN(4) DEFVAR(&APIHEADER 133) DCL VAR(&DD) TYPE(*CHAR) STG(*DEFINED) LEN(4) + DEFVAR(&APIHEADER 137) DCL VAR(&ENTRYCOUNT) TYPE(*INT) DCL VAR(&LISTOFFSET) TYPE(*INT) DCL VAR(&ENTRYSIZE) TYPE(*INT) /* Define quslmbr list entry data structure */ DCL VAR(&QUSLMBRDS) TYPE(*CHAR) STG(*BASED) + LEN(100) BASPTR(&QUSLMBRPTR) DCL VAR(&AUTOSTG) TYPE(*CHAR) STG(*AUTO) LEN(100) DCL VAR(&N) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&AUTOSTG 1) DCL VAR(&MbrType) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&AUTOSTG 11) DCL VAR(&MbrText) TYPE(*CHAR) STG(*DEFINED) LEN(50) + DEFVAR(&AUTOSTG 47) /* Error return code parameter for the APIs */ DCL VAR(&APIERRDS) TYPE(*CHAR) LEN(256) DCL VAR(&APROVIDED) TYPE(*INT) STG(*DEFINED) + LEN(4) DEFVAR(&APIERRDS) DCL VAR(&AAVAIL) TYPE(*INT) STG(*DEFINED) LEN(4) + DEFVAR(&APIERRDS 5) DCL VAR(&AMSGID) TYPE(*CHAR) STG(*DEFINED) + LEN(7) DEFVAR(&APIERRDS 9) DCL VAR(&ARESERVED) TYPE(*CHAR) STG(*DEFINED) + LEN(1) DEFVAR(&APIERRDS 16) DCL VAR(&AMSGDTA) TYPE(*CHAR) STG(*DEFINED) + LEN(112) DEFVAR(&APIERRDS 17) /* Define the fields used by the create user space API. */ DCL VAR(&USPACENAME) TYPE(*CHAR) LEN(20) + VALUE('JCRCOMPOSTQTEMP ') DCL VAR(&UEXTENDED) TYPE(*CHAR) LEN(10) + VALUE('TEST') DCL VAR(&UINITIAL) TYPE(*CHAR) LEN(1) VALUE(X'00') DCL VAR(&UAUTHORITY) TYPE(*CHAR) LEN(10) + VALUE('*ALL') DCL VAR(&UTEXT) TYPE(*CHAR) LEN(50) DCL VAR(&UREPLACE) TYPE(*CHAR) LEN(10) VALUE('*NO') /*-------------------------------------------------------------------*/ DCL VAR(&F) TYPE(*CHAR) LEN(10) VALUE('JCRCMDS ') DCL VAR(&L) TYPE(*CHAR) LEN(10) DCL VAR(&FLAG) TYPE(*CHAR) LEN(10) DCL VAR(&VFILLB) TYPE(*CHAR) LEN(20) DCL VAR(&COUNT) TYPE(*UINT) CHGVAR VAR(&APROVIDED) VALUE(128) CHGVAR VAR(&L) VALUE(&LIBINSTALL) RMVLIBLE LIB(&L) MONMSG MSGID(CPF0000) ADDLIBLE LIB(&L) POSITION(*FIRST) CHGCURLIB CURLIB(*CRTDFT) OVRDBF FILE(JCRSUBRLF) TOFILE(JCRSUBRPF) + OVRSCOPE(*JOB) /*-------------------------------------------------------------------*/ /* delete / recreate all ILE components of library */ /*-------------------------------------------------------------------*/ DLTMOD MODULE(&L/JCRCMDSSRV) MONMSG MSGID(CPF0000) DLTSRVPGM SRVPGM(&L/JCRCMDSSRV) MONMSG MSGID(CPF0000) DLTBNDDIR BNDDIR(&L/JCRCMDSDIR) MONMSG MSGID(CPF0000) CRTRPGMOD MODULE(&L/JCRCMDSSRV) SRCFILE(&L/&F) + DBGVIEW(*all) CRTSRVPGM SRVPGM(&L/JCRCMDSSRV) SRCFILE(&L/&F) + SRCMBR(JCRCMDSBND) TEXT('JCRCMDS service + program') BNDDIR(QSYS/QC2LE) OPTION(*DUPPROC) DLTMOD MODULE(&L/JCRCMDSSRV) CRTBNDDIR BNDDIR(&L/JCRCMDSDIR) TEXT('utility binding + directory') ADDBNDDIRE BNDDIR(&L/JCRCMDSDIR) OBJ((&L/JCRCMDSSRV)) + POSITION(*FIRST) DLTF FILE(&L/JCRBNDPFB) MONMSG MSGID(CPF0000) DSPBNDDIR BNDDIR(&L/JCRCMDSDIR) OUTPUT(*OUTFILE) + OUTFILE(&L/JCRBNDPFB) /* Create user space. Retrieve pointer to user space --------------*/ CALL PGM(QUSCRTUS) PARM(&USPACENAME &UEXTENDED + 50000 &UINITIAL &UAUTHORITY &UTEXT + &UREPLACE &APIERRDS) CALL PGM(QUSPTRUS) PARM(&USPACENAME &HEADPTR + &APIERRDS) CHGVAR VAR(&QUSLMBRPTR) VALUE(&HEADPTR) /*-Call API to load member names to user space ----------------------*/ CHGVAR VAR(&VFILLB) VALUE(&F *CAT &L) CALL PGM(QUSLMBR) PARM(&USPACENAME 'MBRL0200' + &VFILLB '*ALL ' '0' &APIERRDS) CHGVAR VAR(&ENTRYCOUNT) VALUE(%BIN(&CC)) CHGVAR VAR(&LISTOFFSET) VALUE(%BIN(&BB)) CHGVAR VAR(&ENTRYSIZE) VALUE(%BIN(&DD)) /*- make sure everything is compiled in proper sequence --------*/ CHGVAR VAR(&FLAG) VALUE('FILES') CALLSUBR SUBR(srSpinMbr) CHGVAR VAR(&FLAG) VALUE('PROGRAMS') CALLSUBR SUBR(srSpinMbr) CALLSUBR SUBR(SRCRTCMDS) SNDPGMMSG MSG('JCRCMDS installation in ' *CAT &L *TCAT + ' - completed') /*-------------------------------------------------------------------*/ /* move list entry pointer through the user space------------------*/ SUBR SUBR(srSpinMbr) CHGVAR VAR(%OFS(&QuslmbrPtr)) VALUE(%OFS(&HeadPtr) + + &ListOffset) DOFOR VAR(&Count) FROM(1) TO(&EntryCount) CALLSUBR SUBR(SrProcess) CHGVAR VAR(%OFS(&QuslmbrPtr)) + VALUE(%OFS(&QuslmbrPtr) + &EntrySize) ENDDO ENDSUBR /*-------------------------------------------------------------------*/ SUBR SUBR(SRPROCESS) CHGVAR VAR(&AUTOSTG) VALUE(&QUSLMBRDS) SELECT WHEN COND(&MBRTYPE = 'CMD ') /* skip */ WHEN COND(&FLAG *EQ 'FILES ') THEN(DO) SELECT WHEN COND(&MBRTYPE = 'PNLGRP ') THEN(DO) DLTPNLGRP PNLGRP(&L/&N) MONMSG MSGID(CPF0000) CRTPNLGRP PNLGRP(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) ENDDO WHEN COND(&MBRTYPE = 'LF ' *OR &MBRTYPE = 'DSPF ' + *OR &MBRTYPE = 'PRTF ' *OR &MBRTYPE = + 'PF') THEN(DO) DLTF FILE(&L/&N) MONMSG MSGID(CPF0000) SELECT WHEN COND(&MBRTYPE = 'PF ') THEN(CRTPF + FILE(&L/&N) SRCFILE(&L/&F) SIZE(*NOMAX)) WHEN COND(&MBRTYPE = 'DSPF ') THEN(CRTDSPF + FILE(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) + RSTDSP(*YES) DFRWRT(*NO)) WHEN COND(&MBRTYPE = 'PRTF ') THEN(DO) IF COND(%SST(&MBRTEXT 43 3) = '198') + THEN(CRTPRTF FILE(&L/&N) + SRCFILE(&L/&F) SRCMBR(&N) + PAGESIZE(66 198) LPI(6) CPI(15)) ELSE CMD(CRTPRTF FILE(&L/&N) SRCFILE(&L/&F) + SRCMBR(&N) PAGESIZE(66 132) LPI(6) + CPI(10)) ENDDO ENDSELECT ENDDO ENDSELECT ENDDO WHEN COND(&FLAG *EQ 'PROGRAMS ') THEN(DO) IF COND(&N *NE 'JCRCOMPOST ' *AND &N *NE + 'JCRCMDSSRV ' *AND &N *NE 'JCRCMDSCPY') THEN(DO) DLTPGM PGM(&L/&N) MONMSG MSGID(CPF0000) SELECT WHEN COND(&MBRTYPE = 'CLLE ') THEN(CRTBNDCL + PGM(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) + DBGVIEW(*all)) WHEN COND(&MBRTYPE = 'RPGLE ') THEN(CRTBNDRPG + PGM(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) + DBGVIEW(*all)) ENDSELECT ENDDO ENDDO ENDSELECT ENDSUBR /*-------------------------------------------------------------------*/ SUBR SUBR(SRCRTCMDS) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Create + Commands - in progress') TOPGMQ(*EXT) + MSGTYPE(*STATUS) CRTCMD CMD(&L/JCRANZD) PGM(*LIBL/JCRANZDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRANZDH) HLPID(JCRANZD) CRTCMD CMD(&L/JCRANZO) PGM(*LIBL/JCRANZOR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRANZORV) + HLPPNLGRP(*LIBL/JCRANZOH) HLPID(JCRANZO) CRTCMD CMD(&L/JCRANZP) PGM(*LIBL/JCRANZPC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRANZPRV) + HLPPNLGRP(*LIBL/JCRANZPH) HLPID(JCRANZP) CRTCMD CMD(&L/JCRBND) PGM(*LIBL/JCRBNDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRBNDRV) + HLPPNLGRP(*LIBL/JCRBNDH) HLPID(JCRBND) CRTCMD CMD(&L/JCRCALL) PGM(*LIBL/JCRCALLR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRCALLRV) + HLPPNLGRP(*LIBL/JCRCALLH) HLPID(JCRCALL) + PMTOVRPGM(*LIBL/JCRCALLRO) CRTCMD CMD(&L/JCRDQD) PGM(*LIBL/JCRDQDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDQDH) HLPID(JCRDQD) CRTCMD CMD(&L/JCRDQE) PGM(*LIBL/JCRDQER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDQEH) HLPID(JCRDQE) CRTCMD CMD(&L/JCRDTAARA) PGM(*LIBL/JCRDTAARAR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALLIBV) + HLPPNLGRP(*LIBL/JCRDTAARAH) HLPID(JCRDTAARA) CRTCMD CMD(&L/JCRDUMP) PGM(*LIBL/JCRDUMPR1) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDUMPH) HLPID(JCRDUMP) CRTCMD CMD(&L/JCRDUPKEY) PGM(*LIBL/JCRDUPKEYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRDUPKEYH) HLPID(JCRDUPKEY) CRTCMD CMD(&L/JCRFD) PGM(*LIBL/JCRFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRFDH) HLPID(JCRFD) CRTCMD CMD(&L/JCRDBR) PGM(*LIBL/JCRFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRDBRH) HLPID(JCRDBR) CRTCMD CMD(&L/JCRFFD) PGM(*LIBL/JCRFFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFFDRV) + HLPPNLGRP(*LIBL/JCRFFDH) HLPID(JCRFFD) CRTCMD CMD(&L/JCRLJOBD) PGM(*LIBL/JCRLJOBDR) + SRCFILE(&L/&F) + HLPPNLGRP(*LIBL/JCRLJOBDH) HLPID(JCRLJOBD) CRTCMD CMD(&L/JCRQJOBD) PGM(*LIBL/JCRQJOBDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + MODE(*ALL) ALLOW(*ALL) ALWLMTUSR(*NO) + HLPPNLGRP(*LIBL/JCRQJOBDH) HLPID(JCRQJOBD) CRTCMD CMD(&L/JCRFSET) PGM(*LIBL/JCRFSETRS) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFSETRV) + HLPPNLGRP(*LIBL/JCRFSETH) HLPID(JCRFSET) CRTCMD CMD(&L/JCRGAMES) PGM(*LIBL/JCRGAMESC) + SRCFILE(&L/&F) CRTCMD CMD(&L/JCRGENPR) PGM(*LIBL/JCRGENPRR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRGENPRV) + HLPPNLGRP(*LIBL/JCRGENPRH) + HLPID(JCRGENPR) PMTOVRPGM(*LIBL/JCRGENPRO) CRTCMD CMD(&L/JCRIFSCPY) PGM(*LIBL/JCRIFSCPYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSCPYV) + HLPPNLGRP(*LIBL/JCRIFSCPYH) HLPID(JCRIFSCPY) CRTCMD CMD(&L/JCRIFSMBR) PGM(*LIBL/JCRIFSMBRR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSMBRV) + HLPPNLGRP(*LIBL/JCRIFSMBRH) HLPID(JCRIFSMBR) CRTCMD CMD(&L/JCRIFSSAV) PGM(*LIBL/JCRIFSSAVR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSSAVV) + HLPPNLGRP(*LIBL/JCRIFSSAVH) HLPID(JCRIFSSAV) CRTCMD CMD(&L/JCRIND) PGM(*LIBL/JCRINDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRINDRV) + HLPPNLGRP(*LIBL/JCRINDH) HLPID(JCRIND) CRTCMD CMD(&L/JCRJOB) PGM(*LIBL/JCRJOBR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRJOBH) + HLPID(JCRJOB) CRTCMD CMD(&L/JCRJRNA) PGM(*LIBL/JCRJRNAR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRJRNAH) HLPID(JCRJRNA) CRTCMD CMD(&L/JCRLKEY) PGM(*LIBL/JCRLKEYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRLKEYH) HLPID(JCRLKEY) CRTCMD CMD(&L/JCRLOG) PGM(*LIBL/JCRLOGR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRLOGH) + HLPID(JCRLOG) CRTCMD CMD(&L/JCRLSRC) PGM(*LIBL/JCRLSRCR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRLSRCRV) + HLPPNLGRP(*LIBL/JCRLSRCH) HLPID(JCRLSRC) CRTCMD CMD(&L/JCRMRBIG) PGM(*LIBL/JCRMRBIGR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRMRBIGH) + HLPID(JCRMRBIG) CRTCMD CMD(&L/JCRNETFF) PGM(*LIBL/JCRNETFFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNETFFRV) + HLPPNLGRP(*LIBL/JCRNETFFH) HLPID(JCRNETFF) CRTCMD CMD(&L/JCRNETFM) PGM(*LIBL/JCRNETFMR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNETFMRV) + HLPPNLGRP(*LIBL/JCRNETFMH) HLPID(JCRNETFM) CRTCMD CMD(&L/JCRNETQ) PGM(*LIBL/JCRNETQR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRNETQH) HLPID(JCRNETQ) CRTCMD CMD(&L/JCRNOTPOP) PGM(*LIBL/JCRNOTPOPR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRNOTPOPH) HLPID(JCRNOTPOP) CRTCMD CMD(&L/JCRNUMB) PGM(*LIBL/JCRNUMBR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRNUMBH) HLPID(JCRNUMB) CRTCMD CMD(&L/JCROBJD) PGM(*LIBL/JCROBJDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALLIBV) + HLPPNLGRP(*LIBL/JCROBJDH) HLPID(JCROBJD) CRTCMD CMD(&L/JCROLCK) PGM(*LIBL/JCROLCKR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCROLCKH) HLPID(JCROLCK) CRTCMD CMD(&L/JCRPARTI) PGM(*LIBL/JCRPARTIR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRPARTIH) + HLPID(JCRPARTI) CRTCMD CMD(&L/JCRPATTR) PGM(*LIBL/JCRPATTRR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPATTRV) + HLPPNLGRP(*LIBL/JCRPATTRH) HLPID(JCRPATTR) CRTCMD CMD(&L/JCRPRTF) PGM(*LIBL/JCRPRTFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPRTFRV) + HLPPNLGRP(*LIBL/JCRPRTFH) HLPID(JCRPRTF) CRTCMD CMD(&L/JCRSDENT) PGM(*LIBL/JCRSDENTR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRSDENTH) HLPID(JCRSDENT) CRTCMD CMD(&L/JCRRECRT) PGM(*LIBL/JCRRECRTR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRRECRTH) HLPID(JCRRECRT) CRTCMD CMD(&L/JCRRFIL) PGM(*LIBL/JCRRFILR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRRFILH) HLPID(JCRRFIL) CRTCMD CMD(&L/JCRRFLD) PGM(*LIBL/JCRRFLDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRRFLDH) HLPID(JCRRFLD) CRTCMD CMD(&L/JCRRTVRPG) PGM(*LIBL/JCRRTVRPGC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRRTVRPGV) + HLPPNLGRP(*LIBL/JCRRTVRPGH) HLPID(JCRRTVRPG) CRTCMD CMD(&L/JCRSMLT) PGM(*LIBL/JCRSMLTRS) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRSMLTRV) + HLPPNLGRP(*LIBL/JCRSMLTH) HLPID(JCRSMLT) CRTCMD CMD(&L/JCRSPLF) PGM(*LIBL/JCRSPLFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRSPLFRV) + HLPPNLGRP(*LIBL/JCRSPLFH) HLPID(JCRSPLF) CRTCMD CMD(&L/JCRSPELL) PGM(*LIBL/JCRSPELLR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRSPELLH) + HLPID(JCRSPELL) CRTCMD CMD(&L/JCRSSQL) PGM(*LIBL/JCRSSQLC) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRSSQLH) + HLPID(JCRSSQL) CRTCMD CMD(&L/JCRSUBR) PGM(*LIBL/JCRSUBRR1) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRSUBRH) HLPID(JCRSUBR) CRTCMD CMD(&L/JCRSUNDRY) PGM(*LIBL/JCRSUNDRYC) + SRCFILE(&L/&F) CRTCMD CMD(&L/JCRUFIND) PGM(*LIBL/JCRUFINDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRUFINDRV) + HLPPNLGRP(*LIBL/JCRUFINDH) HLPID(JCRUFIND) CRTCMD CMD(&L/JCRUSPACE) PGM(*LIBL/JCRUSPACER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRUSPACEH) HLPID(JCRUSPACE) CRTCMD CMD(&L/JCRUSRAUT) PGM(*LIBL/JCRUSRAUTR) + SRCFILE(&L/&F) + HLPPNLGRP(*LIBL/JCRUSRAUTH) HLPID(JCRUSRAUT) CRTCMD CMD(&L/JCRUSRJOBD) PGM(*LIBL/JCRUSRJOBR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + MODE(*ALL) ALLOW(*ALL) + HLPPNLGRP(*LIBL/JCRUSRJOBH) HLPID(JCRUSRJOBD) CRTCMD CMD(&L/JCR4MAX) PGM(*LIBL/JCR4MAXC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCR4MAXRV) + HLPPNLGRP(*LIBL/JCR4MAXH) HLPID(JCR4MAX) CRTCMD CMD(&L/JCR4PROTO) PGM(*LIBL/JCR4PROTOR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCR4PROTOV) + HLPPNLGRP(*LIBL/JCR4PROTOH) HLPID(JCR4PROTO) CRTCMD CMD(&L/JCRFREESS) PGM(*LIBL/JCRFREESSR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRFREESSH) HLPID(JCRFREESS) CRTCMD CMD(&L/JCR5FREE) PGM(*LIBL/JCR5FREER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCR5FREEV) + HLPPNLGRP(*LIBL/JCR5FREEH) HLPID(JCR5FREE) CRTCMD CMD(&L/XMLGEN) PGM(*LIBL/XMLGENR) + SRCFILE(&L/&F) VLDCKR(*LIBL/XMLGENRV) + HLPPNLGRP(*LIBL/XMLGENH) HLPID(XMLGEN) CRTCMD CMD(&L/XMLGENCMD) PGM(*LIBL/XMLGENCMD) + SRCFILE(&L/&F) CRTCMD CMD(&L/XMLGENINC) PGM(*LIBL/XMLGENINC) + SRCFILE(&L/&F) CRTCMD CMD(&L/XMLGENMBR) PGM(*LIBL/XMLGENMBR) + SRCFILE(&L/&F) CRTCMD CMD(&L/XMLPREVIEW) PGM(*LIBL/XMLPREVIEC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/XMLPREVIEH) HLPID(XMLPREVIEW) CRTCMD CMD(&L/XMLSRCFIL) PGM(*LIBL/XMLSRCFILC) + SRCFILE(&L/&F) VLDCKR(*LIBL/XMLSRCFILV) + HLPPNLGRP(*LIBL/XMLSRCFILH) HLPID(XMLSRCFIL) CRTCMD CMD(&L/XMLSVIEW) PGM(*LIBL/XMLSVIEWR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/XMLSVIEWH) HLPID(XMLSVIEW) ENDSUBR ENDPGM ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRCOMPSRV - recompile JCRCMDS service program */ /* CALL JCRCOMSRV PARM(library where source is located) */ /* you must log off and back on to run new service program */ /*--------------------------------------------------------------------------*/ PGM PARM(&L) DCL VAR(&L) TYPE(*CHAR) LEN(10) DCL VAR(&F) TYPE(*CHAR) LEN(10) VALUE('JCRCMDS ') RMVLIBLE LIB(&L) MONMSG MSGID(CPF0000) ADDLIBLE LIB(&L) POSITION(*FIRST) CHGCURLIB CURLIB(*CRTDFT) /*-------------------------------------------------------------------*/ /* delete / recreate all ILE components of library */ /*-------------------------------------------------------------------*/ DLTMOD MODULE(&L/JCRCMDSSRV) MONMSG MSGID(CPF0000) DLTSRVPGM SRVPGM(&L/JCRCMDSSRV) MONMSG MSGID(CPF0000) CRTRPGMOD MODULE(&L/JCRCMDSSRV) SRCFILE(&L/&F) + DBGVIEW(*all) CRTSRVPGM SRVPGM(&L/JCRCMDSSRV) SRCFILE(&L/&F) + SRCMBR(JCRCMDSBND) TEXT('JCRCMDS service + program') BNDDIR(QSYS/QC2LE) OPTION(*DUPPROC) DLTMOD MODULE(&L/JCRCMDSSRV) ENDPGM ]]> v5r4 //--------------------------------------------------------- // JCRDAYNAMR - wrapper for CL programs to call to return day name //--------------------------------------------------------- /Define ProgramHeaderSpecs /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- D p_JCRDAYNAMR PR Extpgm('JCRDAYNAMR') D 9a D p_JCRDAYNAMR PI D p_DayName 9a //--------------------------------------------------------- /free p_DayName = f_GetDayName(); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDBR - Expanded Data Base Relations - CMD */ /* Display a subfile of data base relations including the file keys and the */ /* select/omit parameters. */ /* Note: This commands front-ends the JCRFDR program going straight to DBR */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Expanded Data Base Relations') PARM KWD(MBR) TYPE(*CHAR) CONSTANT('*FIRST ') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*FILE ') PARM KWD(CALLING) TYPE(*CHAR) LEN(10) CONSTANT('JCRDBR ') PARM KWD(VIEW) TYPE(*CHAR) LEN(4) CONSTANT('*DBR') PARM KWD(KEYSTRING) TYPE(*CHAR) LEN(58) CONSTANT(' ') ]]> v5r4 * .*-------------------------------------------------------------------* :PNLGRP.:HELP NAME='JCRDBR'.Expanded Data Base Relations (JCRDBR) - Help .*-------------------------------------------------------------------- :P.This JCR command generates a subfile of data base relations. The select/omit statements of the logicals are included. :P.If you select to view data base relations for a join logical, you will be prompted to select which based-on physical file you wish to process.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDBR/FILE'.File - Help :XH3.File (FILE) :P.File whose data base relations are to be retrieved.:EHELP.:EPNLGRP. ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDQD - Data queue description display - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Data Queue Description Display') PARM KWD(DTAQ) TYPE(DATAQ) MIN(1) PROMPT('Data Queue') DATAQ: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) CONSTANT('*DTAQ ') ]]> v5r4 *---------------------------------------------------------------- * JCRDQDD - Data queue description display - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 PRINT A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A ASHOWKEY 1A P A 1 3'JCRDQD' COLOR(BLU) A 1 23'Data Queue Description' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 3'Data Queue:' DSPATR(HI) A SCOBJHEAD 65 O 3 15 A 5 3'Created Size:' A SCCRTSIZE 8A O 5 17 A 5 27'Entry Length:' A SCQLEN 5Y 0O 5 41EDTCDE(4) A 5 48'Type:' A SCDDM 5A O 5 54 A 7 3'Sequence:' A SCQSEQUEN 6A O 7 13 A 7 21'Key Length:' DSPATR(&ASHOWKEY) A SCQKEYLEN 4Y 0O 7 33EDTCDE(4) DSPATR(&ASHOWKEY) A 9 3'Entry Counts' A 10 3'Current: . .' A SCENTRIES 9Y 0O 10 16EDTCDE(1) DSPATR(HI UL) A 12 3'Max Ever:. .' A SCCURALC 9Y 0O 12 16EDTCDE(1) DSPATR(UL) A 14 3'Max Allowed:' A SCMAXALLOW 9Y 0O 14 16EDTCDE(1) DSPATR(UL) A 23 2'F3=Exit' COLOR(BLU) A 23 20'F5=Refresh' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRDQD'.Data Queue Description Display (JCRDQD) - Help .*-------------------------------------------------------------------- :P.This JCR command displays selected data queue's Text, Data Length, Sequence, and Key Length. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDQD/DTAQ'.Data Queue - Help :XH3.Data Queue (DTAQ) :P.Specify name and library of data queue whose description is to be displayed. :EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRDQDR - Data queue description display // Call Qmhqrdqd API to retrieve data queue description. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDQDD cf e workstn infds(Infds) //--*COPY DEFINES------------------------------------------ /Define Infds /Define FunctionKeys /Define Dspatr /Define Qmhqrdqd /Define f_GetQual /Define f_GetDayName /Define f_BuildString /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRDQDR PR extpgm('JCRDQDR') D 20a Dtaq Name and Lib D 10a Object Type D p_JCRDQDR PI D p_DtaqNameQual 20a D p_DtaqObjType 10a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); 1b dou InfdsFkey = f03; callp QMHQRDQD( QmhqrdqdDS: %size(QmhqrdqdDS): 'RDQD0100': p_DtaqNameQual); scQlen = QmhqrdqdDS.MsgLength; scEntries = QmhqrdqdDS.EntryCount; scCurAlc = QmhqrdqdDS.CurrAllocated; aShowKey = ND; 2b if QmhqrdqdDS.Sequence = 'F'; scQsequen = '*FIFO'; 2x elseif QmhqrdqdDS.Sequence = 'L'; scQsequen = '*LIFO'; 2x elseif QmhqrdqdDS.Sequence = 'K'; scQsequen = '*KEYED'; aShowKey = Green; scQkeylen = QmhqrdqdDS.KeyLength; 2e endif; scObjHead = f_BuildString('& & &': QmhqrdqdDS.DtaqName: QmhqrdqdDS.DtaqLib: QmhqrdqdDS.Text); 2b if QmhqrdqdDS.LocalOrDDM = '0'; scDDM = 'Local'; 2x else; scDDM = 'DDM'; 2e endif; scMaxAllow = QmhqrdqdDS.MaxAllowed; 2b if QmhqrdqdDS.CreateSize = -1; scCrtSize = '*MAX16MB'; 2x else; scCrtSize = '*MAX2GB '; 2e endif; exfmt SCREEN; 1e enddo; f_SndCompMsg('JCRDQD for ' + %trimr(f_GetQual(p_DtaqNameQual)) + ' - completed'); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDQE - Data queue entries display - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Data Queue Entries Display') PARM KWD(DTAQ) TYPE(DTAQ) MIN(1) PROMPT('Data queue:') DTAQ: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library name:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*DTAQ ') ]]> v5r4 *---------------------------------------------------------------- * JCRDQED - Data Queue Entries Display - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA10 CA11 CA12 CA19 CA20 A PRINT INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A 04 CA14 A R SHEADER A 1 2'JCRDQE ' COLOR(BLU) A 1 23'Data Queue Entries Display' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Name:' A SCOBJHEAD 63 O 2 8 A 2 72SYSNAME A COLOR(BLU) A 31 04N05 3 2'ENTRIES' A DSPATR(HI) A 31 04 05 3 2'KEYS' A DSPATR(HI) A 3 35'Len:' A SENTRYLEN 5Y 0O 3 40EDTCDE(4) A DSPATR(HI) A 3 48'Seq:' A SACCESSTYP 17A O 3 53DSPATR(HI) A 4 2'Date ' DSPATR(UL HI) A 4 11'Time ' DSPATR(UL HI) A SCRULER 58A O 4 21DSPATR(UL HI) *---------------------------------------------------------------- A R SBFDTA1 SFL A QUDATE 8A O 5 2 A QUTIME 8A O 5 11 A VIEWQ1 58A O 5 21 A VIEWQ2 58A O 6 21 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(07) SFLSIZ(700) A 06 SFLDROP(CA13) A N06 SFLFOLD(CA13) A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A SFLMODE(&VSFLMODE) A VSFLMODE 1A H A VSRECNUM 4S 0H SFLRCDNBR A 20 2' - A - A ' A DSPATR(UL) A 08 21 2'Position to screen:' A 08 VDSPNUM 3Y 0B 21 23EDTCDE(4) DSPATR(HI) A 08 VSCRNNUM 3Y 0O 21 28EDTCDE(4) A 08 21 32'Screens' A VQTOTCNT 7Y 0O 21 49EDTCDE(4) A 21 57'Total Queue Entries' A 22 2'Shift to column:' A 31 VDSPPOS 5Y 0B 22 21EDTCDE(4) DSPATR(HI) A 31 VPOS 5Y 0O 22 28EDTCDE(4) A 31 22 32'Current column' A VQENTNUM 7Y 0O 22 49EDTCDE(4) A 22 57'Retrieved by API' A 23 2'F3=Exit' COLOR(BLU) A 23 17'F5=Refresh' COLOR(BLU) A 23 32'F10=Hex' COLOR(BLU) A 23 45'F11=UnFold/Fold' COLOR(BLU) A 23 65'F12=Cancel' COLOR(BLU) A N31 24 2'No Entries are currently in data q- A ueue.' DSPATR(HI RI) A 31 04N05 24 2'F14=Display Key' COLOR(BLU) A 31 04 05 24 2'F14=Display Entry'COLOR(BLU) A 24 45'F19=Shift Left' COLOR(BLU) A 24 65'F20=Shift Right' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRDQE'.Data Queue Entries Display (JCRDQE) - Help .*-------------------------------------------------------------------- :P.This JCR command executes a system API to access data queue entries as messages so you can view the data queue entries without disturbing them on the queue.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDQE/DTAQ'.Data Queue - Help :XH3.Data Queue (DTAQ) :P.Name and library of dataq to be selected.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRDQER - Data queue entries display // call QmhrdQm API for no-touch display of dataq entries as messages. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDQED cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D SflRecNbrsav s like(SflRecNbr) D TempqDS s 116a D ColumnShift s 10i 0 D ForCount s 10i 0 D ofs s 10i 0 D qTrimLen s 10i 0 D sflDspPag s 10i 0 D v0200len s 10i 0 D xx s 10i 0 D BytesAvail s 10i 0 D ff s 5u 0 D Shift s 5u 0 inz(58) D torecNum s 5u 0 D IsHexMode s n D cSflPag c const(7) D Hex40 c const(x'40') D cRuler1 c const('....+....1....+....2+ D ....+....3....+....4+ D ....+....5....+....6+ D ....+....7....+....8+ D ....+....9....+....0+ D ....+....1....+....2+ D ....+....3....+....4+ D ....+....5....+....6+ D ....+....7....+....8+ D ....+....9....+....0+ D ....+....1....+....2') D cRuler2 c const('. . . . + . . . . 1 + D . . . . + . . . . 2 + D . . . . + . . . . 3 + D . . . . + . . . . 4 + D . . . . + . . . . 5 + D . . . . + . . . . 6 + D . . . . + . . . . 7 + D . . . . + . . . . 8 + D . . . . + . . . . 9 + D . . . . + . . . . 0 + D . . . . + . . . . 1 + D . . . . + . . . . 2 + D . . . . + . . . . 3 + D . . . . + . . . . 4 + D . . . . + . . . . 5 + D . . . . + . . . . 6 + D . . . . + . . . . 7 + D . . . . + . . . . 8 + D . . . . + . . . . 9 + D . . . . + . . . . 0 ') //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define ApiStampDS /Define Constants /Define Cvthc /Define Infds /Define FunctionKeys /Define Ind /Define Qmhqrdqd /Define f_BuildString /Define f_GetDayName /Define f_DecodeApiTimeStamp /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Move pointer through message entries D ListEntryDS ds qualified based(ListEntryPtr) D NextEntry 10i 0 D Datetime 8a TOD format D MessageData 1000a variable text // Message selection info - RDQS0100 nonkeyed queues RDQS0200 Keyed data queues D rdqs0100DS ds qualified D Selection 1a inz('A') all D Reserved 3a D MsgByteRtv 10i 0 inz overlay(rdqs0100DS:5) message bytes to rtv D rdqs0200DS ds qualified D Selection 1a inz('K') Keyed D KeyOrder 2a inz('GE') D MsgByteRtv 10i 0 inz overlay(rdqs0200DS:5) message bytes to rtv D KeyByteRtv 10i 0 inz overlay(rdqs0200DS:9) keys bytes to rtv D KeyLen 10i 0 inz overlay(rdqs0200DS:13) key length D Key 256a overlay(rdqs0200DS:17) key value // Divide entry up into subfile fields D ViewqDS ds inz D Viewq1 D Viewq2 //--*CALL PROTOTYPES--------------------------------------- D QmhrdQm PR extpgm('QMHRDQM ') get dataq entry Db like(QmhrdQmDS) receiver D options(*varsize) D 10i 0 const receiver length D 8a const api format D 20a dtaq and lib Db like(RDQS0200DS) options(*varsize) key information D const D 10i 0 const key info length D 8a const information Db like(ApiErrDS) options(*varsize) // parms for QMHRDQM retrieve dataq entries D QmhrdQmDS DS qualified based(QMHRDQMPtr) D BytesReturned 10i 0 overlay(QmhrdQmDS:1) D BytesAvail 10i 0 overlay(QmhrdQmDS:5) D MsgRtnCount 10i 0 overlay(QmhrdQmDS:9) D MsgAvlCount 10i 0 overlay(QmhrdQmDS:13) D KeyLenRtn 10i 0 overlay(QmhrdQmDS:17) D KeyLenAvl 10i 0 overlay(QmhrdQmDS:21) D MsgTxtRtn 10i 0 overlay(QmhrdQmDS:25) D MsgTxtAvl 10i 0 overlay(QmhrdQmDS:29) D EntryLenRtn 10i 0 overlay(QmhrdQmDS:33) D EntryLenAvl 10i 0 overlay(QmhrdQmDS:37) D OffsetToEntry 10i 0 overlay(QmhrdQmDS:41) D DtaqLib 10a overlay(QmhrdQmDS:45) //--*ENTRY PARMS------------------------------------------- D p_JCRDQER PR extpgm('JCRDQER') D 20a Dtaq Name and Lib D 10a Object Type D p_JCRDQER PI D p_DtaqNameQual 20a D p_DtaqObjType 10a //--------------------------------------------------------- /free vSflMode = *on; Ind.sfldrop = vSflMode; vpos = 1; QMHRDQMptr = %alloc(1); evalr scDow = %trimr(f_GetDayName()); // Call API to retrieve data queue description. callp QMHQRDQD( QmhqrdqdDS: %size(QmhqrdqdDS): 'RDQD0100': p_DtaqNameQual); // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; Dealloc QMHRDQMptr; *inlr = *on; return; //--------------------------------------------------------- // Call API to retrieve data queue entries // Different type dataqs require different parm list to API. // Note anomaly that usual method of retrieving 8 bytes to get // bytes available does not work. I had to pass apis data structure // length to get bytes avail. begsr srRefreshScreen; 1b if QmhqrdqdDS.Sequence = 'K'; sAccessTyp = '*KEYED (' + %char(QmhqrdqdDS.KeyLength) + ')'; rdqs0200DS.MsgByteRtv = QmhqrdqdDS.MsgLength; rdqs0200DS.KeyByteRtv = QmhqrdqdDS.KeyLength; rdqs0200DS.KeyLen = QmhqrdqdDS.KeyLength; v0200Len = 16 + QmhqrdqdDS.KeyLength; //len of info QMHRDQMptr = %realloc(QMHRDQMptr: %len(QmhrdQmDS)); callp QMHRDQM( QmhrdQmDS: %len(QmhrdQmDS): 'RDQM0200': p_DtaqNameQual: rdqs0200DS: v0200Len: 'RDQS0200': ApiErrDS); BytesAvail = QmhrdQmDS.BytesAvail; // Use pointer based allocated memory as API can return more entries // than allowed by normal RPG field lengths. QMHRDQMptr = %realloc(QMHRDQMptr: BytesAvail); callp QMHRDQM( QmhrdQmDS: BytesAvail: 'RDQM0200': p_DtaqNameQual: rdqs0200DS: v0200Len: 'RDQS0200': ApiErrDS); 1x else; // non keyed sAccessTyp = '*NON-KEYED'; rdqs0100DS.MsgByteRtv = QmhqrdqdDS.MsgLength; QMHRDQMptr = %realloc(QMHRDQMptr: %len(QmhrdQmDS)); callp QMHRDQM( QmhrdQmDS: %len(QmhrdQmDS): 'RDQM0100': p_DtaqNameQual: rdqs0100DS: %size(rdqs0100DS): 'RDQS0100': ApiErrDS); BytesAvail = QmhrdQmDS.BytesAvail; QMHRDQMptr = %realloc(QMHRDQMptr: BytesAvail); callp QMHRDQM( QmhrdQmDS: BytesAvail: 'RDQM0100': p_DtaqNameQual: rdqs0100DS: %size(rdqs0100DS): 'RDQS0100': ApiErrDS); 1e endif; // Spin through dataq entries. // Convert API date/time stamp to human-readable. rrn = 0; 1b if QmhrdQmDS.MsgRtnCount > 0; // Move pointer through message entries ListEntryPtr = QMHRDQMptr + QmhrdQmDS.OffsetToEntry; 2b for ForCount = 1 to QmhrdQmDS.MsgRtnCount; // Decode Date-Time_Stamp into MM/DD/YY and HH:MM: sS ApiStampDS = f_DecodeApiTimeStamp(ListEntryDS.Datetime); Qudate = f_BuildString('&/&/&': %subst(ApiStampDS.MMDD: 1: 2): %subst(ApiStampDS.MMDD: 3: 2): ApiStampDS.YY); Qutime = f_BuildString('&:&:&': %subst(ApiStampDS.HHMMSS: 1: 2): %subst(ApiStampDS.HHMMSS: 3: 2): %subst(ApiStampDS.HHMMSS: 5: 2)); exsr srTempqDS; exsr srDataToDsp; rrn += 1; write SBFDTA1; 3b if rrn = 9999; 2v leave; 3e endif; ListEntryPtr = QMHRDQMptr + ListEntryDS.NextEntry; 2e endfor; 1e endif; // Display subfile. Calc number of screens in subfile. vSrecNum = 1; ColumnShift = 0; sEntryLen = QmhqrdqdDS.MsgLength; vQTotCnt = QmhrdQmDS.MsgAvlCount; 1b dou 1 = 2; xx = ofs + 1; 2b dow xx > 100; xx -= 100; 2e enddo; 2b if IsHexMode; scRuler = %subst(cRuler2: (xx*2) - 1); 2x else; scRuler = %subst(cRuler1: xx); 2e endif; 2b if ofs = 0; %subst(scRuler: 1: 1) = '*'; 2e endif; 2b if vSflMode = *on; sflDspPag = cSflPag * 2; 2x else; sflDspPag = cSflPag; 2e endif; vQentNum = rrn; vScrnNum = %div(rrn: sflDspPag); 2b if %rem(rrn: sflDspPag) > 0; vScrnNum += 1; 2e endif; Ind.IsMoreScreens = (rrn > sflDspPag); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; Ind.IsactivateF14 = (QmhqrdqdDS.Sequence = 'K'); scObjHead = f_BuildString('& & &': %subst(p_DtaqNameQual: 1: 10): QmhrdQmDS.DtaqLib: QmhqrdqdDS.Text); write SHEADER; exfmt SBFCTL1; Ind.sfldrop = vSflMode; // exit / cancel 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; // refresh 2x elseif InfdsFkey = f05; rrn = 0; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; LV leavesr; // change display mode 2x elseif InfdsFkey = f10; 3b if IsHexMode; IsHexMode = *off; Shift = 58; 3x else; IsHexMode = *on; Shift = 25; 3e endif; SflRecNbrSav = SflRecNbr; exsr srUpdSfl; SflRecNbr = SflRecNbrSav; // fold/unfold 2x elseif InfdsFkey = f11; 3b if vSflMode = *on; vSflMode = *off; 3x else; vSflMode = *on; 3e endif; Ind.sfldrop = vSflMode; 2x elseif InfdsFkey = f14; Ind.IsKeysMode = (Ind.IsKeysMode = *off); SflRecNbrSav = SflRecNbr; exsr srUpdSfl; SflRecNbr = SflRecNbrSav; // shift column position to left 2x elseif InfdsFkey = f19; ColumnShift -= Shift; 3b if ColumnShift < 0; ColumnShift = 1; 3e endif; vdspPos = ColumnShift; // shift column position to right 2x elseif InfdsFkey = f20; ColumnShift += Shift; 3b if ColumnShift >= QmhqrdqdDS.MsgLength; ColumnShift = QmhqrdqdDS.MsgLength - 1; 3e endif; vdspPos = ColumnShift; 2e endif; //--------------------------------------------------------- // Determine which screen user wants to display. 2b if vdspNum = 0; 3b if SflRecNbr = 0; SflRecNbr = 1; 3e endif; vsrecNum = SflRecNbr; 2x else; torecNum = vdspNum * sflDspPag; 3b if torecNum < rrn; vsrecNum = torecNum; 3x else; vsrecNum = rrn; 3e endif; 2e endif; // Determine column offset user wants to display. 2b if vdspPos > 0; ofs = vdspPos - 1; 3b if ofs < 0; ofs = 0; 3e endif; 3b if ofs >= QmhqrdqdDS.MsgLength; ofs = QmhqrdqdDS.MsgLength - 1; 3e endif; exsr srUpdSfl; vpos = ofs + 1; vdspPos = 0; 2e endif; vdspNum = 0; torecNum = 0; 1e enddo; endsr; //--------------------------------------------------------- // Update Subfile. begsr srUpdSfl; ListEntryPtr = QMHRDQMptr + QmhrdQmDS.OffsetToEntry; 1b for xx = 1 to vQentNum; chain xx SBFDTA1; exsr srTempqDS; exsr srDataToDsp; update SBFDTA1; ListEntryPtr = QMHRDQMptr + ListEntryDS.NextEntry; 1e endfor; endsr; //--------------------------------------------------------- // Fill TempqDS from allocated memory. // Note: If Keyed data queue, then there is unexplained // 5 bytes at beginning of each key. // not sure if this a bug or undocumented feature. // Also size of msg entry could be larger than msg variable // allowed. qTrimLen is used to make sure this doesn't blow up! begsr srTempqDS; qTrimLen = QmhqrdqdDS.MsgLength - ofs; 1b if QmhqrdqdDS.Sequence = 'K'; 2b if (5 + QmhqrdqdDS.KeyLength) + QmhqrdqdDS.MsgLength > %size(ListEntryDS.MessageData); qTrimLen = %size(ListEntryDS.MessageData) - (5 + QmhqrdqdDS.KeyLength); 2e endif; 2b if qTrimLen > %len(ViewqDS); qTrimLen = %len(ViewqDS); 2e endif; // Entry/Key display mode. 2b if Ind.IsKeysMode; TempqDS = %subst(ListEntryDS.MessageData: 5 + ofs: QmhqrdqdDS.KeyLength); 2x else; TempqDS = %subst(ListEntryDS.MessageData: 5 + QmhqrdqdDS.KeyLength + ofs: qTrimLen); 2e endif; 1x else; 2b if QmhqrdqdDS.MsgLength > %size(ListEntryDS.MessageData); qTrimLen = %size(ListEntryDS.MessageData); 2e endif; 2b if qTrimLen > %len(ViewqDS); qTrimLen = %len(ViewqDS); 2e endif; // When actual message received is shorter than maximum entry possible 2b if ofs + 1 <= %size(ListEntryDS.MessageData); TempqDS = %subst(ListEntryDS.MessageData: 1 + ofs); 2x else; TempqDS = *blanks; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Move data to display fields. begsr srDataToDsp; 1b if IsHexMode; ViewqDS = ''; callp cvthc(%addr(ViewqDS): %addr(TempqDS): qTrimLen * 2); 1x else; ViewqDS = %subst(TempqDS: 1); // Drop anything below Hex 40 before sending to screen. ff = qTrimLen; 2b for aa = 1 to ff; 3b if %subst(ViewqDS: aa: 1) < Hex40; %subst(ViewqDS: aa: 1) = ' '; 3e endif; 2e endfor; 2b if qTrimLen + 1 < %len(ViewqDS); %subst(ViewqDS: qTrimLen + 1) = *all' '; 2e endif; 1e endif; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDTAARA - List dtaara values and rollover distance - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Dtaara *DEC Values') PARM KWD(DTAARA) TYPE(DTAARA) MIN(1) PROMPT('Data Area Names:') DTAARA: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) MIN(1) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRDTAARA'.List Dtaara *DEC Values (JCRDTAARA) .*-------------------------------------------------------------------- :P.This JCR command prints listing of all type(*DEC) Data Areas in selected library. Current data area value is shown along with how many integer values are left before data area 'rolls over'. :P.Also included is Last used date, Creation Date and Number of days used.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDTAARA/DTAARA'.Data Area - Help :XH3.Data Area(s) (DTAARA) :P.Name/*All/Generic* and library of Data Areas to be evaluated.:EHELP. :HELP name='JCRDTAARA/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRDTAARAP - List dtaara values and rollover distance - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A INDARA A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRDTAARA' A 27'List Data Area Values and Distance- A from Rollover' A SCDOW 9A O 110 A 120DATE EDTWRD(' / / ') A 130TIME EDTWRD(' : : ') A 140'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'Library:' A HEADLIB 10A 11 A 25'Dtaara Select:' A HEADDTA 10A 41SPACEA(1) *--- A 64'Approximate Integer' A 93'Object' A 112'Days' SPACEA(1) *--- A 2'Dtaara' A 14'Attribute' A 27'Len' A 32'Dec' A 39'Current Value ' A UNDERLINE A 64'Distance to RollOver ' A UNDERLINE A 93'Created' A 102'LastUsed' A 112'Used' A 118'Text' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A OBJNAM 10A 2 A PRTVALTYPE 10A 14 A PRTLENGTH 5 0 25EDTCDE(3) A PRTNUMDEC 3 0 31EDTCDE(3) A CURVALA 24A 37 A TOROLLA 24A 62 A CREATEDATE 6 0 93EDTCDE(Y) A 30 LASTUSED 6 0 103EDTCDE(Y) A DAYSUSED 4 0 113EDTCDE(4) A OBJTEXT 50A 120 *---------------------------------------------------------------- A R PRTMESSAGE SPACEB(2) A VMESSAGE 100A 3 ]]> v5r4 //--------------------------------------------------------- // JCRDTAARAR - List dtaara values and rollover distance // call Quslobj API to load object names to user space. // call Qwcrdtaa API to extract data area info. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDTAARAPo e printer oflind(IsOverFlow) indds(Ind) F usropn //--*STAND ALONE------------------------------------------- D CvtVar s like(EditMask) D xSrcvar s like(EditMask) D xString s like(EditMask) D EditMask s 256a D p_ObjTyp s 10a inz('*DTAARA') D MaxValuea s 35a varying D CurValf s 8f D MaxValuef s 8f D ToRollf s 8f D EditMaskLen s 10i 0 D ForCount2 s 10i 0 D NumXXX s 10i 0 D TempPos s 10i 0 D ToRolli s 20i 0 D vRecvrLen s 10i 0 D IsFound s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define ApiStampDS /Define Atof /Define Constants /Define Qeccvtec /Define Quslobj /Define UserSpaceHeaderDS /Define f_BuildString /Define f_DecodeApiTimeStamp /Define f_GetQual /Define f_Quscrtus /Define f_RtvMsgAPI /Define f_SndStatMsg /Define f_OvrPrtf /Define f_Dltovr /Define f_DspLastSplf /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D QwcrdtaaDS ds qualified D BytesProvided 10i 0 inz D BytesReturned 10i 0 inz D TypeOfValue 10a D DtaaraLib 10a D LenReturned 10i 0 inz D NumDecimal 10i 0 inz D Value 2000a D Ind ds qualified D IsLastUsed n overlay(ind:30) //--*CALL PROTOTYPES--------------------------------------- D Qwcrdtaa PR extpgm('QWCRDTAA ') Display Dtaara Db like(QwcrdtaaDS) Receiver D 10i 0 const Length of Receiver D 20a const Dtaara and Lib D 10i 0 const Starting Position D 10i 0 const Length of Receiver Db like(ApiErrDS) Error Parm D Qecedt PR ExtPgm('QECEDT') apply edit mask D 256a receiver D 10i 0 mask length D 256a to be edited D 10a const type D 10i 0 const field length D 256a edit mask D 10i 0 mack length D 1a const 0 balance file Db like(ApiErrDs) //--*ENTRY PARMS------------------------------------------- D p_JCRDTAARAR PR extpgm('JCRDTAARAR') D 20a Dtaara Name and Lib D 8a D p_JCRDTAARAR PI D p_DtaaraQual 20a D p_Output 8a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); headlib = %subst(p_DtaaraQual: 11: 10); headdta = %subst(p_DtaaraQual: 1: 10); f_SndStatMsg(f_BuildString('List dtaaras from & - in progress': f_GetQual(p_DtaaraQual))); f_OvrPrtf('JCRDTAARAP': *OMIT: HeadLib); open JCRDTAARAP; write prthead; // call API to load object names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0600': p_DtaaraQual: p_ObjTyp: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; // load print file field, print error message vMessage = ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi( ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); exsr srWriteAsterick; write PrtMessage; exsr srSendCompletMsg; 1e endif; // if no matching objects found, print error message. 1b if GenericHeader.ListEntryCount = 0; exsr srWriteAsterick; vmessage = 'No matching dtaara names found.'; write PrtMessage; exsr srSendCompletMsg; 1e endif; // Process objects in user space by moving pointer. QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; IsFound = *on; // extract object create date, last used date, number times used ApiStampDS = f_DecodeApiTimeStamp(QuslobjDS.CreateStamp); CreateDate = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); 2b if QuslobjDS.NumDaysUsed > 9999; DaysUsed = 9999; 2x else; DaysUsed = QuslobjDS.NumDaysUsed; 2e endif; 2b if QuslobjDS.NumDaysUsed > 0; ApiStampDS = f_DecodeApiTimeStamp(QuslobjDS.LastUseStamp); LastUsed = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); Ind.IsLastUsed = *on; 2x else; Ind.IsLastUsed = *off; 2e endif; callp QWCRDTAA( QwcrdtaaDS: %len(QwcrdtaaDS): QuslobjDS.ObjNam + QuslobjDS.ObjLib: -1: 20: ApiErrDS); 2b if QwcrdtaaDS.TypeOfValue = '*DEC '; xSrcvar = %trimr(QwcrdtaaDS.Value); // Convert to String xString = *blanks; clear EditMask; EditMaskLen = 0; callp QECCVTEC( EditMask: EditMaskLen: vRecvrLen: ' ': 'J': ' ': QwcrdtaaDS.LenReturned: QwcrdtaaDS.NumDecimal: ApiErrDS); cvtvar = *allx'FF'; callp QECEDT( cvtvar: vRecvrLen: xSrcvar: '*PACKED': QwcrdtaaDS.LenReturned: EditMask: EditMaskLen: ' ': ApiErrDS); temppos = %checkr(x'FF': cvtvar); 3b if temppos = *zeros; temppos = vRecvrLen; 3e endif; xString = %subst(cvtvar: 1: temppos); evalr curvala = %trimr(xString); 3b if curvala = *blanks; evalr curvala = '0'; 3e endif; // remove/compress commas from J code edit, // before converting to float. aa = 1; 3b dou aa = 0; aa = %scan(',': xString: aa); 4b if aa > 0; xString = %subst(xString: 1: aa - 1) + %subst(xString: aa + 1); 4e endif; 3e enddo; CurValf = atof(%trimr(xString)); // build character string to match largest size of dtaara. NumXXX = (QwcrdtaaDS.LenReturned - QwcrdtaaDS.NumDecimal); %len(MaxValueA) = 0; 3b for ForCount2 = 1 to NumXXX; MaxValueA = MaxValueA + '9'; 3e endfor; 3b if QwcrdtaaDS.NumDecimal > 0; MaxValueA = MaxValueA + '.'; 3e endif; 3b for ForCount2 = 1 to QwcrdtaaDS.NumDecimal; MaxValueA = MaxValueA + '9'; 3e endfor; // make it float value MaxValuef = atof(%trimr(maxvaluea)); // calc difference and load to alpha ToRollF = MaxValuef - CurValf; NumXXX = (QwcrdtaaDS.LenReturned - QwcrdtaaDS.NumDecimal); eval(h) ToRolli = ToRollf; evalr torolla = %editc(torolli:'J'); PrtLength = QwcrdtaaDS.LenReturned; PrtNumDec = QwcrdtaaDS.NumDecimal; // print line of report ObjNam = QuslobjDS.ObjNam; ObjText = QuslobjDS.ObjText; PrtValType = QwcrdtaaDS.TypeOfValue; write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; // if no matching objects found, print message and exit. 1b if not IsFound; exsr srWriteAsterick; vmessage = 'No matching dtaara names found.'; write PrtMessage; 1x else; // end of report vmessage = ' ** End Of Report'; write PrtMessage; 1e endif; exsr srSendCompletMsg; //--------------------------------------------------------- begsr srSendCompletMsg; close JCRDTAARAP; f_Dltovr('JCRDTAARAP'); f_DspLastSplf('JCRDTAARAR': p_Output); *inlr = *on; return; endsr; //--------------------------------------------------------- begsr srWriteAsterick; QuslobjPtr = GenericHeaderPtr; ObjNam = *all'*'; CreateDate = 0; LastUsed = 0; Ind.IsLastUsed = *on; DaysUsed = 0; ObjText = *all'*'; write PrtDetail; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDUMP - Count number of dumps by program - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Summarize RPG Dump Listings') PARM KWD(OUTQ) TYPE(OUTQ) MIN(0) PROMPT('Outq name:') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(QEZDEBUG) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) CONSTANT('*OUTQ ') PARM KWD(JOB_DATE) TYPE(*DATE) DFT(*AVAIL) + SPCVAL((*AVAIL 222222) (*CURRENT 333333) + (*PRVDAY 444444)) PROMPT('Selected date (MMDDYYYY):' 1) PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) DFT(*PRINT) VALUES(* *PRINT) + PROMPT('Output:') /* prompt for program name if DISPLAY selected. */ PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ * )) PARM KWD(PROGRAM) TYPE(PROGRAM) MIN(0) PGM(*YES) + PMTCTL(PMTCTL1) PROMPT('Program:') PROGRAM: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) MIN(1) PROMPT('Library:') ]]> v5r4 *---------------------------------------------------------------- * JCRDUMPD - Count number of dumps by program - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA12 CA21 PRINT INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A PSPLFNAM 10A H A SBFOPTION 1A B 7 2 A PUSERNAM 10A O 7 6 A PJOBNAM 10A O 7 18 A PJOBNBR 6A O 7 30 A PSDATE L O 7 38DATFMT(*ISO) A PSTIME T O 7 50TIMFMT(*HMS) A PSPLFNBR 6A O 7 61 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(15) SFLSIZ(30) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A 1 3'JCRDUMPR3' COLOR(BLU) A 1 23'Dump Spooled File Viewer' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 3'Program:' A P_PGM 10A O 2 12 A 2 26'Library:' A P_LIB 10A O 2 35 A 2 52'Queue:' A P_QUEUE 10A O 2 59 A 2 72SYSNAME COLOR(BLU) A 3 2'Type options, press Enter.' A COLOR(BLU) A 4 4'1=SndNet' COLOR(BLU) A SCOPTIONS 63A O 4 14COLOR(BLU) A 6 2'Opt' DSPATR(HI UL) A 6 6'User ' DSPATR(HI UL) A 6 18'Job ' DSPATR(HI UL) A 6 30'Job Nbr' DSPATR(HI UL) A 6 38'Date ' DSPATR(HI UL) A 6 50'Time ' DSPATR(HI UL) A 6 60'Splf Nbr' DSPATR(HI UL) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 20'F5=Refresh' COLOR(BLU) A 23 41'F21=Command Line' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 *---------------------------------------------------------------- * JCRDUMPF - Count number of dumps by program - PF *---------------------------------------------------------------- A R JCRDUMPFR TEXT('Count Number of Dumps') A PGMNAM 10 COLHDG('Program Name') A PGMLIB 10 COLHDG('Library Name') A PSDATE L DATFMT(*ISO) A COLHDG('Date of' 'Dump') A PSTIME T TIMFMT(*HMS) A COLHDG('Time of' 'Dump') A PMSGD 60 COLHDG('Program status ID') A PSPLFNAM 10 COLHDG('Splf Name') A PSPLFNBR 6 COLHDG('Splf Number') A PJOBNAM 10 COLHDG('Job Name') A PJOBNBR 6 COLHDG('Job Number') A PUSERNAM 10 COLHDG('User Name') A K PSDATE A K PGMLIB A K PGMNAM A K PMSGD ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRDUMP'.Summarize RPG Dump Listings (JCRDUMP) - Help .*-------------------------------------------------------------------- :P.This JCR command prints list of all RPG programs that have generated Dump spooled file and the count of how many times that program has dumped. :P.The command uses several spooled file APIs to efficiently "read" through selected outq and extract desired information from each spooled file.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDUMP/JOB_DATE'.Selected date (MMDDYYYY) (JOB_DATE) - Help :XH3.Selected date (MMDDYYYY) (JOB_DATE) :P.Date to filter against job-start-date extracted from spooled file. :PARML.:PT.:PK def.*AVAIL:EPK. :PD.The default value, *AVAIL, selects data from all spooled files in the selected outq. :PT.:PK def.*CURRENT:EPK. :PD.Select data from spooled files whose job started on today's date. :PT.date :PD.Select data from spooled files whose job started on that date.:EPARML.:EHELP. :HELP name='JCRDUMP/OUTQ'.Outq name - Help :XH3.Outq name (OUTQ) :P.Name and library of output queue that is to have its spooled files processed.:EHELP. :HELP name='JCRDUMP/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print results or load into subfile.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRDUMPP - Count number of dumps by program- PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD A 2'JCRDUMP' A SKIPB(01) A 20'RPG PROGRAM DUMPS' A SCDOW 9 77 A 88DATE A EDTCDE(Y) A 108'Page' A PAGE1 4 0 114EDTCDE(4) A SPACEA(2) A 5'Dump Date' A 23'Program Name Library' A 49'Number of Dumps' A 69'Program Status Message' A SPACEA(1) A R PRTL1 A HEADERDATE 10 5 A PGMNAM 10 23 A PGMLIB 10 36 A L1TOTAL 10 0 52EDTCDE(2) A PMSGD 60 69 A SPACEA(1) A R PRTL2 A 58'------' A SPACEA(1) A L2TOTAL 10 0 52EDTCDE(2) A SPACEA(2) A R PRTLR A 1'TOTAL DUMPS' A SPACEB(2) A LRTOTAL 10 0 52EDTCDE(2) A SPACEA(2) ]]> v5r4 //--------------------------------------------------------- // JCRDUMPR1 - Count number of dumps by program - load // spin through list of spooled files retrieved from outq // extract spooled file information to load into work data file. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDUMPF o a e disk usropn extfile('QTEMP/JCRDUMPF') //--*STAND ALONE------------------------------------------- D kgmLib s like(pgmLib) D kgmnam s like(pgmnam) D kmsgd s like(pmsgd) D Buffer s 5000a based(Ptr4) D DumpType s 4a D InternalSplfID s 16a D IntJobID s 16a D SelectAll s 4a inz('*NO ') D SpoolDump s 4a inz('*NO ') D DumpDate s D D ip_isoDate s D D Handle s 10i 0 D OfsetToOfset s 10i 0 based(Ptr2) D OrdinalNumber s 10i 0 inz(-1) D dd s 5u 0 D GenericHeaderPtr2... D s * inz(*null) D vDateEntered c 'Date Entered System . ' D vLibrary c ' Library . ' D vProgramName c 'Program Name . ' D vProgramStat c 'Program Status .' D vRpg3Dump c 'RPG/400 FORMATTED DU' D vRpg4Dump c 'ILE RPG/400 FORMATTE' D vRpg4Dumpx c 'Program Status Area:' D vRpg4V6r1 c 'ILE RPG FORMATTED DUMP' //--*DATA STRUCTURES--------------------------------------- D KeysToReturn ds qualified API key values D key01 10i 0 inz(0201) spooled file name D key02 10i 0 inz(0202) job name D key03 10i 0 inz(0203) user named D key04 10i 0 inz(0204) job number D key05 10i 0 inz(0205) spooled file number D key06 10i 0 inz(0216) date opned D key07 10i 0 inz(0217) time opened D key08 10i 0 inz(0218) internal job ID D key09 10i 0 inz(0219) internal spool ID D NumberKeys s 10i 0 inz(9) number to return // buffer information section D BufferInfoDS ds qualified based(BufferInfoPtr) D BufferLength 10i 0 overlay(BufferInfoDS:1) D OrdinalNumber 10i 0 overlay(BufferInfoDS:5) D OffsetGeneral 10i 0 overlay(BufferInfoDS:9) D SizeGeneral 10i 0 overlay(BufferInfoDS:13) D OffsetToPage 10i 0 overlay(BufferInfoDS:17) D SizePageData 10i 0 overlay(BufferInfoDS:21) D NumPageEntries 10i 0 overlay(BufferInfoDS:25) D SizePageEntry 10i 0 overlay(BufferInfoDS:29) D OffsetPrintDataSection... D 10i 0 overlay(BufferInfoDS:33) D SizePrintDataSection... D 10i 0 overlay(BufferInfoDS:37) // get end of line of print as determined by Qspgetsp API. D EndOfLineDS ds qualified D Hex00 1a inz(x'00') D Hex15 1a inz(x'15') D Hex002 1a inz(x'00') D Hex34 1a inz(x'34') D cvt ds qualified D Alpha4 4a D Binary4 1 4b 0 inz //--*CALL PROTOTYPES--------------------------------------- D p_JCRDUMPR2 PR extpgm('JCRDUMPR2') Print Report D Quslspl PR ExtPgm('QUSLSPL ') list spooled files D 20a user space D 8a const format D 10a const user D 20a outq and lib D 10a const form type D 10a const user data Db like(ApiErrDS) D 26a const not used job info Db like(KeysToReturn) D 10i 0 number of keys D QuslsplDS ds qualified based(QuslsplPtr) D NumFieldRtn 10i 0 overlay(QuslsplDS:1) 0200 format only // Define ds to extract repeating key value fields. D splf0200DS ds qualified based(splf0200Ptr) D LenghtOfInfo 10i 0 overlay(splf0200DS:1) D KeyReturned 10i 0 overlay(splf0200DS:5) D TypeOfData 1a overlay(splf0200DS:9) D Reserved 3a overlay(splf0200DS:10) D LenOfData 10i 0 overlay(splf0200DS:13) D KeyData 17a overlay(splf0200DS:17) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Qspclosp /Define Qspgetsp /Define Qspopnsp /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_DupFileToQtemp /Define f_GetQual /Define f_Quscrtus /Define f_SndCompMsg /Define f_SndStatMsg /Define f_BuildString /Define p_JCRDUMPR3 /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRDUMPR1 PR extpgm('JCRDUMPR1') D 20a Outq Name and Lib D 10a Object Type D 7a Date D 8a Output D 20a Program Name and Lib D p_JCRdumpr1 PI D p_OutqQual 20a D p_ObjType 10a D p_Date 7a D p_Output 8a D p_PgmQual 20a //--------------------------------------------------------- /free 1b dou not IsRefresh; f_SndStatMsg(f_BuildString( 'Processing DUMP spooled files from & - in progress': f_GetQual(p_OutqQual))); f_DupFileToQtemp('JCRDUMPF ': '*LIBL ': 'N'); open JCRDUMPF; //--------------------------------------------------------- // dates coming in from command are CYYMMDD. // 0222222= allow all dates // 0333333= retrieve current date only // Dates are converted to *ISO standard. 2b if p_Date = '0222222'; SelectAll = '*YES'; 2x elseif p_Date = '0333333'; ip_isoDate = %date(); 2x elseif p_Date = '0444444'; ip_isoDate = %date() - %days(1); 2x else; ip_isoDate = %date('20' + %subst(p_Date: 2: 6): *iso0); 2e endif; //--------------------------------------------------------- // create user spaces for APIs. // UserSpaceName used by Quslspl to load list of spooled file names. // UserSpaceName2 used by Qspgetsp to load data from spooled file. GenericHeaderPtr = f_Quscrtus(UserSpaceName); GenericHeaderPtr2 = f_Quscrtus(UserSpaceName2); // load spooled file internal names to user space. callp QUSLSPL( UserSpaceName: 'SPLF0200': '*ALL ': p_OutqQual: '*ALL ': '*ALL ': ApiErrDS : ' ': KeysToReturn: NumberKeys); //--------------------------------------------------------- // process data from user space. // each block is retrieved to get spooled file internal identifiers and open date. QuslsplPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 2b for ForCount = 1 to GenericHeader.ListEntryCount; // Spin through data to extract selected key values. splf0200Ptr = QuslsplPtr + 4; 3b for ForCount2 = 1 to QuslsplDS.NumFieldRtn; 4b if splf0200DS.KeyReturned = 0201; pSplfNam = splf0200DS.KeyData; 4x elseif splf0200DS.KeyReturned = 0202; pJobNam = splf0200DS.KeyData; 4x elseif splf0200DS.KeyReturned = 0203; pUserNam = splf0200DS.KeyData; 4x elseif splf0200DS.KeyReturned = 0204; pJobNbr = splf0200DS.KeyData; 4x elseif splf0200DS.KeyReturned = 0205; cvt.Alpha4 = splf0200DS.KeyData; evalr pSplfNbr = '000000' + %char(cvt.Binary4); 4x elseif splf0200DS.KeyReturned = 0216; DumpDate = %date('20' + %subst(splf0200DS.KeyData: 2: 6): *iso0); 4x elseif splf0200DS.KeyReturned = 0217; pstime = %time(%subst(splf0200DS.KeyData: 1: 6): *hms0); 4x elseif splf0200DS.KeyReturned = 0218; IntJobID = splf0200DS.KeyData; 4x elseif splf0200DS.KeyReturned = 0219; InternalSplfID = splf0200DS.KeyData; 4e endif; splf0200Ptr += splf0200DS.LenghtOfInfo; 3e endfor; // use internal identifiers to open spooled file. 3b if SelectAll = '*YES' or ip_isoDate = DumpDate; callp QSPOPNSP( Handle: '*INT ': IntJobID: InternalSplfID: '*INT ': 0: 8: ApiErrDS); // load 1st pages of print data. callp QSPGETSP( Handle: UserSpaceName2: 'SPFR0200': OrdinalNumber: '*ERROR ': ApiErrDS); //--------------------------------------------------------- // retrieve offset to page data offset. // get offsets to print data. // retrieve 1st buffer of print data. Ptr2 = GenericHeaderPtr2 + 92; //Offset to Offset BufferInfoPtr = GenericHeaderPtr2 + OfsetToOfset; Ptr4 = GenericHeaderPtr2 + BufferInfoDS.OffsetPrintDataSection; // close spooled file. callp QSPCLOSP(Handle: ApiErrDS); // extract info about dump and determine which type dump SpoolDump = '*NO '; 4b if %subst(Buffer: 48: 20) = vRpg3Dump; //RPG3 dump SpoolDump = '*YES'; DumpType = 'RPG3'; 4e endif; // - - - 4b if %subst(Buffer: 48: 20) = vRpg4Dump or %subst(Buffer: 51: 20) = vRpg4Dumpx //RPG4 dump or %subst(Buffer: 48: 22) = vRpg4V6r1 ; //RPG4 V6R1 SpoolDump = '*YES'; DumpType = 'RPG4'; 4e endif; //--------------------------------------------------------- // extract job starting date and make sure this dump is for // correct date. RPG3 = 6 long so different extract is used. 4b if SpoolDump = '*YES'; cc = %scan(vDateEntered: Buffer: 1000); 5b if cc > 0; // get program name cc = %scan(vProgramName: Buffer: 96); 6b if cc > 0; cc += 43; //--------------------------------------------------------- // RPG3 extract program name and Library. // lllllll/pppppppp l=Lib p=pgm. Library and program // are variable length and must be extracted. // Position of '/' is retrieved, then position of // end-of-line marker. With these values, the // desired data can be extracted. // position | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | // |---|---|---|---|---|---|---|---|----- // data | | l | i | b | / | p | g | m | x'00150034' // cc = 2 : aa = 5 : bb = 9 // note: it is 43 positions from beginning of constant // to start of data. 7b if DumpType = 'RPG3'; aa = %scan('/': Buffer: cc); bb = %scan(EndOfLineDS: Buffer: cc); dd = (aa - cc); kgmLib = %subst(Buffer: cc: dd); aa += 1; dd = bb - aa; kgmnam = %subst(Buffer: aa: dd); //--------------------------------------------------------- // RPGv4 extract program name and Library. // ILE dump has program/Library on separate lines. // There is hex00 after name // and Library. (it does not leave spaces for name.) 7x elseif DumpType = 'RPG4'; aa = %scan(x'00': Buffer: cc); //find blank after name kgmnam = %subst(Buffer: cc: aa - cc); cc = %scan(vLibrary: Buffer: cc); 8b if cc > 0; cc += 43; aa = %scan(x'00': Buffer: cc); //find blank after name kgmLib = %subst(Buffer: cc: aa - cc); 8e endif; 7e endif; //--------------------------------------------------------- // extract program status message data. Used // Used to extract MSGID/DTA didn't always have data in it. // Extract status ID then extract ID message data (if any) clear kmsgd; cc = %scan(vProgramStat: Buffer: cc); //Start of msgd bb = %scan(EndOfLineDS: Buffer: cc); //END OF LINE 7b if cc > 0; cc += 43; dd = bb - cc; //length of msgid 8b if dd > 0; //THERE IS MSG kmsgd = %subst(Buffer: cc: dd); //MESSAGE DATA // Step over 7 places and extract message. 9b if kmsgd > '00000 '; //found one cc = bb + 7; bb = %scan(EndOfLineDS: Buffer: cc); kmsgd = %trimr(kmsgd) + ' ' + %triml(%subst(Buffer: cc: bb - cc)); 9e endif; 8e endif; // add records to file. pgmnam = kgmnam; pgmLib = kgmLib; pmsgd = kmsgd; psdate = DumpDate ; write JCRDUMPFR; 7e endif; 6e endif; 5e endif; 4e endif; 3e endif; QuslsplPtr += GenericHeader.ListEntrySize; 2e endfor; close JCRDUMPF; 2b if p_Output = '*PRINT '; callp p_JCRDUMPR2(); 2x else; callp p_JCRDUMPR3( %subst(p_PgmQual: 1: 10): %subst(p_PgmQual: 11: 10): %subst(p_OutqQual: 1: 10): IsRefresh); 2e endif; 1e enddo; f_SndCompMsg('JCRDUMP for ' + %trimr(f_GetQual(p_OutqQual)) + ' - completed'); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRDUMPR2 - Count number of dumps by program - print //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /Undefine ProgramHeaderSpecs FJCRDUMPF if e k disk extfile('QTEMP/JCRDUMPF') FJCRDUMPP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D HeaderDate s 10a D L1total s 10u 0 D L2total s 10u 0 D LRtotal s 10u 0 D scDow s 9a //--*COPY DEFINES------------------------------------------ /Define f_GetDayName /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- /free open JCRDUMPP; evalr scDow = %trimr(f_GetDayName()); write PrtHead; setll *start JCRDUMPF; read JCRDUMPFR; 1b dow not %eof; L2total = 0; HeaderDate = %char(psdate); 2b dow not %eof; L1total = 0; 3b dow not %eof; L1total += 1; L2total += 1; LRtotal += 1; reade (psdate:pgmlib:pgmnam:pmsgd) JCRDUMPFR; 3e enddo; 3b if IsOverFlow; HeaderDate = %char(psdate); write PrtHead; IsOverFlow = *off; 3e endif; write PrtL1; setgt (psdate:pgmlib:pgmnam:pmsgd) JCRDUMPFR; reade psdate JCRDUMPFR; 2e enddo; //--------------------------------------------------------- 2b if IsOverFlow; HeaderDate = %char(psdate); write PrtHead; IsOverFlow = *off; 2e endif; write PrtL2; setgt psdate JCRDUMPFR; read JCRDUMPFR; 1e enddo; write PrtLR; close JCRDUMPP; f_DspLastSplf('JCRDUMPR2 ': '*PRINT '); *inlr = *on; ]]> v5r4 //--------------------------------------------------------- // JCRDUMPR3 - Count number of dumps by program - display // read outfile. // display subfile of selected spooled files. // process options selected from subfile. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDUMPD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) FJCRDUMPF if e k disk extfile('QTEMP/JCRDUMPF') //--*COPY DEFINES------------------------------------------ /Define Constants /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define f_IsValidObj /Define f_RunOptionSplf /Define f_RmvSflMsg /Define f_SndSflMsg /Define f_GetDayName /Define Quscmdln /Define p_JCRDUMPR3 /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRdumpr3 PI D p_Pgm 10a const D p_Lib 10a const D p_Queue 10a const D p_Refresh n //--------------------------------------------------------- /free p_Refresh = *off; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; evalr scDow = %trimr(f_GetDayName()); // line up option headings depending on your system IsSndSplf = f_IsValidObj('SNDSPLF ': '*LIBL ': '*CMD'); IsEsend = f_IsValidObj('ESNDMAIL ': 'ESEND ': '*CMD'); 1b if IsSndSplf and IsEsend; scOptions = oE + oS + o2 + o5; 1x elseif IsESend; scOptions = oE + o2 + o5; 1x elseif IsSndSplf; scOptions = oS + o2 + o5; 1x else; scOptions = o2 + o5; 1e endif; setll *start JCRDUMPF; read JCRDUMPFR; 1b dow not %eof; 2b if p_Pgm = pgmnam and p_Lib = pgmLib; rrn += 1; write SBFDTA1; 2e endif; read JCRDUMPFR; 1e enddo; // show subfile Ind.sfldsp = (rrn > 0); 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No dump spooled files found for selected program.'); 1e endif; Ind.sfldspctl = *on; 1b dou 1 = 2; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); 2b if InfdsFkey = f05; p_Refresh = *on; *inlr = *on; return; 2e endif; 2b if not Ind.sfldsp; //subfile empty 1i iter; 2e endif; 2b if InfdsFkey = f21; Quscmdln(); 2e endif; // process user requests--------------------------------------- readc SBFDTA1; 2b dow not %eof; 3b if sbfOption > ' '; f_RunOptionSplf( sbfOption: pSplfNam: pSplfNbr: pJobNam: pUserNam: pJobNbr: EmailAddr: ProgId); clear sbfOption; update SBFDTA1; 3e endif; readc SBFDTA1; 2e enddo; 1e enddo; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRDUPKEY - Find Duplicate Keyed Logicals - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find Duplicate Keyed Logicals') PARM KWD(MBR) TYPE(*CHAR) CONSTANT('*FIRST ') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRDUPKEY'.Find Duplicate Keyed Logicals (JCRDUPKEY) - Help .*-------------------------------------------------------------------- :P.This JCR command prints list of file data base relations that have same leading keys and select/omit statements.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRDUPKEY/FILE'.File - Help :XH3.File (FILE) :P.Name and library of file to be selected.:EHELP. :HELP name='JCRDUPKEY/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRDUPKEYP - Find Duplicate Keyed Logicals - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRDUPKEY' A 20'Find Duplicate Keyed Logicals' A SCDOW 9A O 82 A 92DATE EDTWRD(' / / ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'File:' A SCOBJHEAD 75A 8SPACEA(2) *--- A 1'File' A 13'Library' A 25'Keys' *---------------------------------------------------------------- A R PRTLINE SPACEA(1) A PRTFILE 10A O 1 A PRTLIB 10A O 13 A PRTKEYS 104A 25 *---------------------------------------------------------------- A R PRTDIVIDER SPACEA(1) A 1'---------' A 13'----------' A 25'----------------------------------- A ------------------------------------ A -----------------------------------' ]]> v5r4 //--------------------------------------------------------- // JCRDUPKEYR - Find Duplicate Keyed Logicals - print // List files that have same leading keys and select/omit statements //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRDUPKEYPo e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D KeySequenBits s 1a D WorkFileQual s 20a D ForCount2 s like(SelectOmitSpec.NumberOfParms) D aa s 5u 0 D cc s 5u 0 D xx s 5u 0 D DbrCnt s 5u 0 D yy s like(FileScopeArry.NumOfKeys) D zz s 10u 0 D ActualPF s 20a D IsSendMessage s n D IsAllEQual s n D IsAllSelect s n D IsPrintOnce s n // setup sort pointer D SortOverlay s 200a based(SortPtr) D SortPtr s * inz(%addr(DS1)) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_OvrPrtf /Define f_DltOvr /Define f_Quscrtus /Define Qdbrtvfd /Define Fild0100DS /Define Qdbldbr /Define f_DspLastSplf /Define f_System /Define f_SndCompMsg /Define Tstbts /Define f_GetDayName /Define f_BuildString /Define Qlgsort /Define f_AddSortKey /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D SelectOmitDS ds inz qualified D Type 7a D Field 10a D Comp 2a D Value 31a D DS1 DS dim(2000) qualified D NumbKeys 3u 0 D FormatCnt 3u 0 D File 10a D Lib 10a D UniqueFlg 1a D KeysArry 13a dim(30) D PrtKeys 104a overlay(DS1: 24) D SelOmtArry 50a dim(30) D DS2 DS likeds(DS1) dim(2000) //--*ENTRY PARMS------------------------------------------- D p_JCRDUPKEYR PR extpgm('JCRDUPKEYR') D 10a const Validity Checking D 20a File and Lib D 8a D p_JCRDUPKEYR PI D p_Mbr 10a const D p_FileQual 20a D p_Output 8a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); f_OvrPrtf('JCRDUPKEYP': *OMIT: %subst(p_FileQual:1:10)); open JCRDUPKEYP; //--------------------------------------------------------- // If selected file is logical, based-on-physical name is extracted // processing continues as if physical had been selected. AllocateSize = f_GetAllocSize01(p_FileQual: '*FIRST '); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds: AllocateSize: ReturnFileQual : 'FILD0100' : p_FileQual: '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 1b if tstbts(Fild0100ds.TypeBits: 2) = 1; ReturnFileQual = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 1e endif; ActualPF = ReturnFileQual; scObjHead = f_BuildString('& & &': %subst(ReturnFileQual: 1: 10): %subst(ReturnFileQual: 11: 10): Fild0100ds.FileText); write PrtHead; write prtdivider; // call API to retrieve data base relation names. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QDBLDBR( UserSpaceName: 'DBRL0100': ReturnFileQual: '*ALL ': '*ALL ': ApiErrDS); // Process list entries in user space. QdbldbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if QdbldbrDS.DependentFile <> '*NONE '; exsr srLoadRecord; QdbldbrPtr += GenericHeader.ListEntrySize; 2e endif; 1e endfor; QdbldbrDS.DependentFile = ActualPF; exsr srLoadRecord; //--------------------------------------------------------- // Idea is start with smallest number of keys and spin through entire list // looking for files with keys in same positions and same select omits // // Sort driver arry ascending by number of keys, // and the compare arry descending by number of keys. ds2(*) = ds1(*); qlgsortDS.RecordLength = %len(ds1(1)); qlgsortDS.RecordCount = DbrCnt; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1:1:9:1); // ascending qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); callp QLGSORT( qlgsortDS: SortOverlay: SortOverlay: qlgsortDS.RecordLength * qlgsortDS.RecordCount: qlgsortDS.RecordLength * qlgsortDS.RecordCount: ApiErrDS); SortPtr = %addr(DS2); qlgSortDS = %subst(qlgSortDS: 1: 80); qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1:1:9:2); // descend callp QLGSORT( qlgsortDS: SortOverlay: SortOverlay: qlgsortDS.RecordLength * qlgsortDS.RecordCount: qlgsortDS.RecordLength * qlgsortDS.RecordCount: ApiErrDS); //--------------------------------------------------------- //--------------------------------------------------------- 1b for aa = 1 to DbrCnt; 2b if ds1(aa).File > *blanks; IsPrintOnce = *on; 3b for cc = 1 to DbrCnt; 4b if ds2(cc).File > *blanks and ds2(cc).File <> ds1(aa).File and ds2(cc).FormatCnt = ds1(aa).FormatCnt; IsAllSelect = *on; 5b for xx = 1 to %elem(ds1.SelOmtArry); 6b if ds2(cc).SelOmtArry(xx) <> ds1(aa).SelOmtArry(xx); IsAllSelect = *off; 5v leave; 6e endif; 5e endfor; 5b if IsAllSelect; IsAllEQual = (ds1(aa).NumbKeys > 0); 6b for xx = 1 to ds1(aa).NumbKeys; 7b if ds2(cc).KeysArry(xx) <> ds1(aa).KeysArry(xx); IsAllEQual = *off; 6v leave; 7e endif; 6e endfor; 6b if IsAllEQual = *on; IsSendMessage = *on; 7b if IsPrintOnce; PrtFile = ds1(aa).File; PrtLib = ds1(aa).Lib; PrtKeys = ds1(aa).PrtKeys; write PrtLine; IsPrintOnce = *off; 7e endif; PrtFile = ds2(cc).File; PrtLib = ds2(cc).Lib; PrtKeys = ds2(cc).PrtKeys; write PrtLine; // remove found file from driver array 7b for xx = 1 to DbrCnt; 8b if ds2(cc).File = ds1(xx).File; clear ds1(xx); 8e endif; 7e endfor; clear ds2(cc); 6e endif; 5e endif; 4e endif; 3e endfor; 3b if not IsPrintOnce; write prtdivider; 3e endif; 2e endif; 1e endfor; 1b if not IsSendMessage; PrtFile = *all'*'; PrtLib = *all'*'; PrtKeys = %trimr(%subst(p_FileQual:1:10)) + ' has no duplicate access paths'; f_sndCompMsg(PrtKeys); write PrtLine; 1e endif; dealloc Fild0100ptr; close JCRDUPKEYP; f_DltOvr('JCRDUPKEYP'); f_DspLastSplf('JCRDUPKEYR': p_Output); *inlr = *on; return; //--------------------------------------------------------- begsr srLoadRecord; WorkFileQual = QdbldbrDS.DependentFile; AllocateSize = f_GetAllocSize01(WorkFileQual: '*FIRST '); 1b if ApiErrDS.BytesReturned = 0; DbrCnt += 1; ds1(DbrCnt).File = %subst(WorkFileQual: 1: 10); ds1(DbrCnt).Lib = %subst(WorkFileQual: 11: 10); Fild0100ptr = %realloc(Fild0100ptr: AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : WorkFileQual : '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); // Check for unique keys required. 2b if Fild0100ds.AccessType = 'KU'; ds1(DbrCnt).uniqueflg = 'U'; 2x else; ds1(DbrCnt).uniqueflg = ' '; 2e endif; // get number of record formats. ds1(DbrCnt).FormatCnt = Fild0100ds.NumRcdFmts; // set offsets fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; cc = FileScopeArry.OffsKeySpecs + 1; // if 1st bit of KeySequenBits = 1, key is descending sequence. ds1(DbrCnt).KeysArry(*) = *blanks; ds1(DbrCnt).SelOmtArry(*) = *blanks; ds1(DbrCnt).NumbKeys = FileScopeArry.NumOfKeys; KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 2b for yy = 1 to FileScopeArry.NumOfKeys; ds1(DbrCnt).KeysArry(yy) = %trimr(KeySpecsDS.KeyFieldName); // check for descending keys. 3b if tstbts(KeySpecsDS.KeySequenBits: 0) > 0; %subst(ds1(DbrCnt).KeysArry(yy): 11: 3) = '(D)'; 3e endif; KeySpecsPtr += 32; 2e endfor; // extract select/omit fields. aa = 0; 2b if FileScopeArry.NumSelectOmit > 0; SelectOmitSpecPtr = Fild0100ptr + FileScopeArry.OffsSelectOmit; 3b for ForCount2 = 1 to (FileScopeArry.NumSelectOmit - 1); 4b if SelectOmitSpec.StatementRule = 'S'; SelectOmitDS.Type = '*SELECT'; 4x elseif SelectOmitSpec.StatementRule = 'O'; SelectOmitDS.Type = '*OMIT '; 4x elseif SelectOmitSpec.StatementRule = 'A'; SelectOmitDS.Type = '*AND '; 4e endif; SelectOmitDS.Field = SelectOmitSpec.FieldName; SelectOmitDS.Comp = SelectOmitSpec.CompRelation; SelectOmitParmPtr = Fild0100ptr + SelectOmitSpec.OffsToParms; // extract select/omit values. 4b for zz = 1 to SelectOmitSpec.NumberOfParms; SelectOmitDS.Value = %subst( SelectOmitParm.ParmValue: 1: SelectOmitParm.ParmLength-20); aa += 1; ds1(DbrCnt).SelOmtArry(aa) = SelectOmitDS; SelectOmitParmPtr = Fild0100ptr + SelectOmitParm.OffsToNext; 4e endfor; SelectOmitSpecPtr += 32; 3e endfor; 2e endif; 1e endif; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCREADDD - Email setup for Esend and Sndsplf PF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R EMAILSETUP A *DS3 WINDOW(3 5 5 61 *NOMSGLIN) A *DS4 WINDOW(3 5 5 61 *NOMSGLIN) A WDWTITLE((*TEXT 'One Time Email Set- A up') (*COLOR WHT) (*DSPATR HI)) A OVERLAY A P_USRPRF 10A O 1 1 A 2 1'Email:' A SCEMAIL 60A B 3 1DSPATR(UL) A 4 1'Enter=Update' COLOR(BLU) ]]> v5r4 *---------------------------------------------------------------- * JCREADDF - Emails addresses for SNDSPLF and ESEND *---------------------------------------------------------------- A R JCREADDFR TEXT('Email Addresses') A JCRUSRPRF 10A COLHDG('User Profile') A JCREMAIL 60A COLHDG('Email') A K JCRUSRPRF ]]> v5r4 //--------------------------------------------------------- // JCREADDR - One time email setup for Esend and Sndsspf // Returns email address if found, if not found add to file //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCREADDF if a e k disk emails for sends FJCREADDD cf e workstn usropn D UsrPrf s 10a inz(*user) //--*ENTRY PARMS------------------------------------------- D p_JCREADDR PR extpgm('JCREADDR ') D 60a D p_JCREADDR PI D p_EmailAddr 60a //--------------------------------------------------------- /free chain UsrPrf jcrEaddfr; 1b if %found; p_EmailAddr = jcrEmail; 1x else; open jcreaddd; exfmt EmailSetup; jcrusrprf = UsrPrf; jcremail = scemail; write jcrEaddfr; p_EmailAddr = jcrEmail; close jcreaddd; 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRFD - File description display driver - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('File Description Display') PARM KWD(MBR) TYPE(*CHAR) CONSTANT('*FIRST ') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*FILE ') PARM KWD(CALLING) TYPE(*CHAR) LEN(10) CONSTANT('JCRFD ') PARM KWD(VIEW) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*) VALUES(* *MBR *DBR) + PROMPT('Initial View:') PARM KWD(KEYSTRING) TYPE(*CHAR) LEN(58) CONSTANT(' ') ]]> v5r4 A*---------------------------------------------------------------- A* JCRFDD - File description display driver - DSPF A*---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A INDARA A CA03 A CA05 A CA06 A CA07 A CA12 A CA13 A CA14 A CA15 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SBFSELATR 1A P A SBFROWATR 1A P A SBFFILEHID 10A H A SBFLIBHID 10A H A SBFSELECT 1 0B 4 2EDTCDE(4) DSPATR(&SBFSELATR) A SBFROW 75A O 4 4DSPATR(&SBFROWATR) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0306) A *DS4 SFLSIZ(0306) A *DS3 SFLPAG(0018) A *DS4 SFLPAG(0018) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A SFILENAME 10A H A SLIBNAME 10A H A SCPROGID 10A O 1 2COLOR(BLU) A SCTITLE 36A O 1 23DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'File:' A DSPATR(HI) A SCOBJHEAD 63A O 2 8 A 2 72SYSNAME A COLOR(BLU) A SCHEADOPT 65A O 3 2COLOR(BLU) A*---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A BLINK A AKEYSELEC 1A P A 23 2'F3=Exit' A COLOR(BLU) A SCKEYSELEC 70A O 23 11DSPATR(&AKEYSELEC) A PRTMSG 20 O 24 7DSPATR(HI) *---------------------------------------------------------------- A R WINDTA3 SFL A SBFROWATR3 1A P A SBFROW3 70A O 2 3DSPATR(&SBFROWATR3) * A R WINCTL3 SFLCTL(WINDTA3) A OVERLAY A 51 SFLDSP A 52 SFLDSPCTL A N51 SFLCLR A N54 SFLEND(*MORE) A *DS3 SFLSIZ(0018) A *DS4 SFLSIZ(0018) A *DS3 SFLPAG(0006) A *DS4 SFLPAG(0006) A *DS3 WINDOW(*DFT 9 75 *NOMSGLIN) A *DS4 WINDOW(*DFT 11 75 *NOMSGLIN) A R WINFOOT3 WINDOW(WINCTL3) OVERLAY A 9 2'F12=Previous' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRFD'.File Description Display (JCRFD) - Help .*-------------------------------------------------------------------- :P.This JCR command provides for viewing most often requested data file information. :P.You may select to view Data Base Relations, Member List Record Formats, or Trigger information by pressing a command key.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRFD/FILE'.File - Help :XH3.File (FILE) :P.File whose description is to be retrieved.:EHELP. :HELP name='JCRFD/VIEW'.View - Help :XH3.View (VIEW) :P.Initial information presented by command. :PARML.:PT.*:PD.Initial presentation is basic file information. :PT.:PK def.*MBR:EPK.:PD.Show subfile of all members in selected file. :PT.:PK def.*DBR:EPK.:PD.Show subfile of data base relations.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRFDMBRD - Expanded work with object descriptions - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A CA03 A CA05 A CA12 A CA13 A CA14 A MOUBTN(*ULP CA13) A MOUBTN(*URP CA14) A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A INDARA A R SBFDTA1 SFL A AOPTIONSFL 1A P A SBFOPTION 1Y 0B 5 2EDTCDE(4) A DSPATR(&AOPTIONSFL) A SCMBR 10A O 5 4 A SCCHGDATE 10A O 5 15 A SCCHGTIME 8A O 5 26 A SCRECS 9Y 0O 5 35EDTCDE(3) A SCRECDLT 9Y 0O 5 45EDTCDE(3) A SCSIZE 9Y 0O 5 55EDTCDE(3) A SCTEXT 13A O 5 65 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0187) A *DS4 SFLSIZ(0187) A *DS3 SFLPAG(0017) A *DS4 SFLPAG(0017) A OVERLAY A RTNCSRLOC(&CURRCD &CURFLD) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A CURRCD 10A H A CURFLD 10A H A AOPTIONS 1A P A 1 2'JCRFDMBRD' A COLOR(BLU) A 1 29'Display Member List' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'File:' A DSPATR(HI) A SCOBJHEAD 63A O 2 8 A 2 72SYSNAME A COLOR(BLU) A SCHEADOPT 78A O 3 2DSPATR(&AOPTIONS) A 4 2'Opt' A DSPATR(HI) A 4 7'Member' A DSPATR(HI) A 4 15'Last Change' A DSPATR(HI) A 4 38'Records' A DSPATR(HI) A 4 48'Deleted' A DSPATR(HI) A 4 57'Size(K)' A DSPATR(HI) A 4 65'Text' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A BLINK A 23 2'F3=Exit' A COLOR(BLU) A 23 11'F5=Refresh' A COLOR(BLU) A 23 24'F13=Sort Ascending' A COLOR(BLU) A SORTDESCEN 19 O 23 45COLOR(BLU) A 23 69'F12=Cancel' A COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 //--------------------------------------------------------- // JCRFDMBRR - File description display driver Member List // call QuslMbr API to load list of member. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRFDMBRD cf e workstn sfile(SBFDTA1: rrn) Infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D HeaderLib s 10a D HeaderObj s 10a D dStamp s 8a D KeyFld s 10a inz('SCMBR ') D SortSequence s 10a inz('Ascending ') D LoadedElements s 10i 0 D DeleteCount s 5u 0 D ForCount2 s 3u 0 D NumberOfRecs s 5u 0 D RRNsave s 5u 0 D dbUtility s 8a //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define DspAtr /Define Infds /Define FunctionKeys /Define Ind /Define Quslmbr /Define f_Qusrmbrd /Define f_GetApiISO /Define f_GetApiHMS /Define Sds /Define UserSpaceHeaderDS /Define f_BuildString /Define f_RunOptionFile /Define f_GetQual /Define f_Quscrtus /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_GetFileUtil /Define f_GetDayName /Define p_JCRFDMBRR /COPY JCRCMDS,JCRCMDSCPY D HeaderSection ds qualified based(HeaderPtr) D FileUsed 10a overlay(HeaderSection:1) D LibUsed 10a overlay(HeaderSection:11) D FileText 30a overlay(HeaderSection:31) // SortArry - load screen fields into sort array. D ds D SortArry 68a dim(9999) D scMbrArry 10a overlay(SortArry:1) D scChgDateArry 10a overlay(SortArry:*next) D scChgTimeArry 8a overlay(SortArry:*next) D scRecsArry 9s 0 overlay(SortArry:*next) D scRecDltArry 9s 0 overlay(SortArry:*next) D scSizeArry 9s 0 overlay(SortArry:*next) D scTextArry 13a overlay(SortArry:*next) //--*CALL PROTOTYPES--------------------------------------- D Qwcrtvca PR extpgm('QWCRTVCA') retrieve current atr D 150a receiver D 10i 0 const receiver length D 8a const api format D 10i 0 const number of keys D 12a list of keys Db like(ApiErrDS) D Qwtchgjb PR extpgm('QWTCHGJB') change current job D 26a const job name *=current D 16a const internal identifier D 8a const api format D 150a receiver Db like(ApiErrDS) D p_AllowOption s 4a inz('*YES') //--*ENTRY PARMS------------------------------------------- D p_JCRFDMBRR PI D p_FileQual 20a //--------------------------------------------------------- /free /IF DEFINED(*V7R1M0) SortDescen = 'F14=Sort Descending'; /ELSE SortDescen = *blanks; /ENDIF IsFirstTime = *on; f_SndStatMsg(f_BuildString('Retrieving & - in progress': f_GetQual(p_FileQual))); evalr scDow = %trimr(f_GetDayName()); DbUtility = '2=' + f_GetFileUtil(); scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 4=Rmvmbr 5=Wrkmbrpdm 9=Clrpfm'; 1b if p_AllowOption = '*NO '; aOptionSfl = %bitor(ND: PR); aOptions = ND; 1x else; aOptionSfl = %bitor(Green: UL); aOptions = Blue; 1e endif; // Create user space/retrieve pointer to user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // Call API to load object name list. begsr srRefreshScreen; sbfOption = 0; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; HeaderObj = %subst(p_FileQual: 1: 10); HeaderLib = %subst(p_FileQual: 11: 10); callp QUSLMBR( UserSpaceName: 'MBRL0100': p_FileQual: '*ALL ': '0': ApiErrDS); // file text information HeaderPtr = GenericHeaderPtr + GenericHeader.OffSetToHeader; scObjHead = %trimr(HeaderSection.FileUsed) + ' ' + %trimr(HeaderSection.LibUsed) + ' ' + HeaderSection.FileText; // Process data from user space by moving pointer. LoadedElements = 0; QuslmbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; QusrmbrdDS = f_Qusrmbrd( p_FileQual: QuslmbrDS.MbrName: 'MBRD0200'); SCMBR = QuslmbrDS.MbrName; SCCHGDATE = f_GetApiISO(QusrmbrdDS.ChangeDateTime); SCCHGTIME = f_GetApiHMS(QusrmbrdDS.ChangeDateTime); SCRECS = QusrmbrdDS.CurrNumberRecs; SCSIZE = (QusrmbrdDS.SizeOfData * QusrmbrdDS.SizeOfDataMLT)/1024; SCRECDLT = QusrmbrdDS.DeletedRecs; SCTEXT = QusrmbrdDS.Text; rrn += 1; LoadedElements += 1; scMbrArry(LoadedElements) = scMbr; scChgDateArry(LoadedElements) = scChgDate; scChgTimeArry(LoadedElements) = scChgTime; scRecsArry(LoadedElements) = scRecs; scRecDltArry(LoadedElements) = scRecDlt; scSizeArry(LoadedElements) = scSize; scTextArry(LoadedElements) = scText; 2b if LoadedElements = 9999; 1v leave; 2e endif; QuslmbrPtr += GenericHeader.ListEntrySize; 1e endfor; RRNsave = rrn; // Allow user to make selection from subfile. exsr srLoadFromSorter; 1b if IsRefresh <> *on or SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; 1b dow not (InfdsFkey = f03); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 2b if not Ind.sfldsp; f_RmvSflMsg(ProgId); f_SndSflMsg(ProgId: 'No members were found.'); 2e endif; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); // refresh 2b if InfdsFkey = f05; IsRefresh = *on; LV leavesr; 2e endif; 2b if SflRecNbr > 0; SflRcdNbr = SflRecNbr; 2x else; SflRcdNbr = 1; 2e endif; // Selected to resort subfile 2b if InfdsFkey = f13 or InfdsFkey = f14; 3b if InfdsFkey = f13; SortSequence = 'Ascending'; 3e endif; 3b if InfdsFkey = f14; SortSequence = 'Descending'; 3e endif; KeyFld = curfld; exsr srSortAndReload; SflRcdNbr = 1; 1i iter; 2e endif; // Find record in subfile user has selected. DeleteCount = 0; 2b if p_AllowOption = '*YES'; readc SBFDTA1; 3b dow not %eof; // as a precaution, limit options to those visible on screen 4b if sbfOption = 1 or sbfOption = 2 or sbfOption = 4 or sbfOption = 5 or sbfOption = 9; f_RunOptionFile( sbfOption: HeaderObj: HeaderLib: '*FIRST ': scmbr: ProgId); // Update subfile to reflect selected changes. 5b if sbfOption = 4; DeleteCount += 1; 5x else; sbfOption = 0; SflRcdNbr = rrn; update SBFDTA1; 5e endif; 4e endif; readc SBFDTA1; 3e enddo; 3b if DeleteCount > 0; exsr srSortAndReload; DeleteCount = 0; 3e endif; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // Read subfile and load records into sorting array. begsr srSortAndReload; NumberOfRecs = RRNsave; 1b if DeleteCount > 0; RRNsave -= DeleteCount; 2b if SflRcdNbr > RRNsave; SflRcdNbr = RRNsave; 2e endif; 1e endif; LoadedElements = 0; 1b for rrn = 1 to NumberOfRecs; chain rrn SBFDTA1; 2b if sbfOption <> 4; //DELETE OPTION LoadedElements += 1; scMbrArry(LoadedElements) = scMbr; scChgDateArry(LoadedElements) = scChgDate; scChgTimeArry(LoadedElements) = scChgTime; scRecsArry(LoadedElements) = scRecs; scRecDltArry(LoadedElements) = scRecDlt; scSizeArry(LoadedElements) = scSize; scTextArry(LoadedElements) = scText; 2e endif; 1e endfor; exsr srLoadFromSorter; rrn = RRNsave; endsr; //--------------------------------------------------------- // Sort array and load back into subfile. begsr srLoadFromSorter; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; 1b if KeyFld = 'SCMBR '; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scMbrArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scMbrArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scMbrArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Member.'); 1x elseif KeyFld = 'SCCHGTIME' or KeyFld = 'SCCHGDATE '; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scChgDateArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scChgDateArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scChgDateArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Change Date/Time.'); 1x elseif KeyFld = 'SCRECS '; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scRecsArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scRecsArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scRecsArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Number Records.'); 1x elseif KeyFld = 'SCRECDLT'; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scRecDltArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scRecDltArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scRecDltArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Deleted Records.'); 1x elseif KeyFld = 'SCSIZE '; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scSizeArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scSizeArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scSizeArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Deleted Records.'); 1x elseif KeyFld = 'SCTEXT'; /IF DEFINED(*V7R1M0) 2b if SortSequence = 'Descending'; sorta(d) %subarr(scTextArry: 1: LoadedElements); 2x else; sorta(a) %subarr(scTextArry: 1: LoadedElements); 2e endif; /ELSE sorta %subarr(scTextArry: 1: LoadedElements); /ENDIF f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) + ' by Last Used Date.'); 1e endif; 1b if LoadedElements >= 9999; f_RmvSflMsg(ProgId); f_SndSflMsg(ProgId: '9999+ objects returned. Narrow your search.'); LoadedElements = 9999; 1e endif; 1b for aa = 1 to LoadedElements; scMbr = scMbrArry(aa); scChgDate = scChgDateArry(aa); scChgTime = scChgTimeArry(aa); scRecs = scRecsArry(aa); scRecDlt = scRecDltArry(aa); scSize = scSizeArry(aa); scText = scTextArry(aa); sbfOption = 0; rrn += 1; write SBFDTA1; 1e endfor; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCRFDP - PRTF File description display driver *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(2) A SCTITLE 36A O 23 A SCDOW 9A O 62 A 72DATE A EDTWRD('0 / / ') A SPACEA(1) A 2'File:' A SCOBJHEAD 63A O 8 A SPACEA(1) A SCHEADOPT 65A O 2 A SPACEA(2) *---------------------------------------------------------------- A R PRTLINE SPACEA(1) A SBFROW 75A 2 ]]> v5r4 //--------------------------------------------------------- // JCRFDR - File description display driver // This program also provides the presentation layer for JCRLKEY and JCRDBR. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRFDD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F sfile(WINDTA3: rrn3) F indds(Ind) FJCRFDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D rrn3 s 5u 0 D BitOffset s 10u 0 inz(2) D WorkFileQual s 20a D Alpha10 s 10a D PfFile s 10a D PfLib s 10a D KeyList s 49a D ForCount1 s like(GenericHeader.ListEntryCount) D ForCount3 s like(FileScopeArry.NumSelectOmit) D ForCount4 s like(SelectOmitSpec.NumberOfParms) D ForCount5 s like(Fild0100ds.NumOfBasedPf) D ForCount6 s like(JoinSpecDS.NumJFlds) D ForCount7 s like(PfAttrDS.NumOfTriggers) D ForCount2 s like(FileScopeArry.NumOfKeys) D IsLF s n D IsDbrView s n D IsMbrView s n D kwork s 14a varying D IsIncludeSO s n D IsThisKeyOK s n D IsValidKeys s n D IsFdScreen s n D IsOption3 s n inz(*off) D KeySortArry s 14a dim(5) ascend D QuickSort s 200a based(QdbldbrPtr) D FileOption s 1p 0 inz D savrcdnbr s like(sflrcdnbr) D dbUtility s 8a D subtext s like(sbfrow) D savFileName s 10a D savLibName s 10a D PrtRrn s 5u 0 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define DspAtr /Define Infds /Define FunctionKeys /Define f_GetApiISO /Define f_GetApiHMS /Define f_Qusrmbrd /Define f_Qusrobjd /Define f_SndCompMsg /Define f_BuildString /Define f_GetFileUtil /Define UserSpaceHeaderDS /Define Ind /Define Sds /Define f_Quscrtus /Define f_GetQual /Define f_GetDayName /Define f_RunOptionFile /Define Qdbldbr /Define Qdbrtvfd /Define Fild0100ds /Define Qlgsort /Define Tstbts /Define f_GetFileUtil /Define f_CenterText /Define f_AddSortKey /Define f_RtvMsgAPI /Define p_JCRFDMBRR /Define f_OvrPrtf /Define f_DltOvr /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // receive keys selected in JCRLKEY utility. D LeadingKeysDS ds 58 qualified D KeyFields 10a dim(5) overlay(LeadingKeysDS:1) D KeyPosition 1s 0 dim(5) overlay(LeadingKeysDS:51) D SelectOmit n overlay(LeadingKeysDS:57) D IsFoundKey n overlay(LeadingKeysDS:58) D SbfRowDS ds qualified D soCon 4a overlay(SbfRowDS:33) inz('s/o:') D soType 7a overlay(SbfRowDS:38) D soFld 10a overlay(SbfRowDS:46) D soComp 2a overlay(SbfRowDS:57) D soValu 32a overlay(SbfRowDS:60) //--*ENTRY PARMS------------------------------------------- D p_JCRFDR PR extpgm('JCRFDR ') D 10a const D 20a D 10a const D 10a const D 4a D 58a D p_JCRFDR PI D p_Mbr 10a const D p_FileQual 20a D p_ObjTyp 10a const D p_CallingCmd 10a const D p_InitialView 4a D p_LeadingKeys 58a //--------------------------------------------------------- /free LeadingKeysDS = p_LeadingKeys; Fild0100ptr = %alloc(4096); DbUtility = '2=' + f_GetFileUtil(); sbfSelAtr = %bitor(ND: PR); aKeySelec = Blue; evalr scDow = %trimr(f_GetDayName()); scKeySelec = 'F6=Prt F7=Include S/O F13=Fields' + ' F14=MbrList F15=' + f_GetFileUtil() + ' F12=Cancel'; scProgid = p_CallingCmd; // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; dealloc Fild0100ptr; 1b if p_CallingCmd <> 'JCRLKEY '; f_SndCompMsg(%trimr(p_CallingCmd) + ' for ' + %trimr(f_GetQual(sFileName + sLibName)) + ' - completed'); 1e endif; *inlr = *on; p_LeadingKeys = LeadingKeysDS; return; //--------------------------------------------------------- begsr srRefreshScreen; 1b if p_CallingCmd = 'JCRLKEY '; IsIncludeSO = LeadingKeysDS.SelectOmit; IsFdScreen = *off; exsr srDataBaseRelations; 1x elseif p_InitialView = '*DBR '; IsFdScreen = *off; IsIncludeSO = *on; IsDbrView = *on; exsr srDataBaseRelations; 1x elseif p_InitialView = '*MBR'; IsMbrView = *on; callp p_JCRFDMBRR(p_FileQual); IsFdScreen = *on; exsr srGetFileInformation; 1x else; IsFdScreen = *on; exsr srGetFileInformation; 1e endif; p_InitialView = *blanks; //--------------------------------------------------------- // Show user screen and allow Fkey selection. SflRcdNbr = 2; 1b dou 1 = 2; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; PrtRrn = Rrn; 2b if p_CallingCmd = 'JCRLKEY '; 3b if rrn = 1; LeadingKeysDS.IsFoundKey = *off; IsExitPgm = *on; LV leavesr; 3x else; LeadingKeysDS.IsFoundkey = *on; 3e endif; 2e endif; 2b if rrn = 1; SflRcdNbr = 1; 2e endif; write SBFCTL1; exfmt SFOOTER1; 2b if InfdsFkey = f03; IsExitPgm = *on; LV leavesr; 2e endif; savrcdnbr = SFLRECNBR; // from infds //--------------------------------------------------------- // depending on what screen user is showing, 2b if InfdsFkey = f05; LV leavesr; 2x elseif InfdsFkey = f12; 3b if (IsDbrView or IsMbrView) and p_CallingCmd = 'JCRFD '; IsDbrView = *off; IsMbrView = *off; IsFdScreen = *on; exsr srGetFileInformation; 1i iter; 3x elseif IsMbrView and p_CallingCmd = 'JCRDBR'; IsDbrView = *on; IsMbrView = *off; exsr srDataBaseRelations; 1i iter; 3x else; IsExitPgm = *on; LV leavesr; 3e endif; 2e endif; IsDbrView = *off; IsMbrView = *off; PrtMsg = *blanks; //--------------------------------------------------------- // print 2b if InfdsFkey = f06; exsr srPrint; //--------------------------------------------------------- // toggle view to include select/omit or exclude select omit 2x elseif InfdsFkey = f07; IsDbrView = *on; IsIncludeSO = not(IsIncludeSO); exsr srDataBaseRelations; //--------------------------------------------------------- 2x elseif InfdsFkey = f13 or InfdsFKey = f15; 3b if InfdsFKey = f13; FileOption = 1; // Field descriptions 3x elseif InfdsFKey = f15; FileOption = 2; // Data base utility 3e endif; f_RunOptionFile(FileOption: sFileName: sLibname: '*FIRST ': '*FIRST ': ProgId); //--------------------------------------------------------- 2x elseif InfdsFkey = f14; callp p_JCRFDMBRR(p_FileQual); IsFdScreen = *on; exsr srGetFileInformation; 2e endif; //--------------------------------------------------------- // find record in subfile user has selected. // values from changed record are sent to a function. // process user selections readc SBFDTA1; 2b dow not %eof; 3b if sbfSelect > 0; 4b if sbfSelect = 3; IsOption3 = *on; savFileName = sFileName; savLibName = sLibName; p_FileQual = sbfFileHid + sbfLibHid; exsr srGetFileInformation; sFileName = savFileName; sLibName = savLibName; // as a precaution, limit options to those visible on screen 4x elseif (sbfSelect = 1 or sbfSelect = 2 or sbfSelect = 7); f_RunOptionFile( sbfSelect: sbfFileHid: sbfLibHid: '*FIRST ': '*FIRST ': ProgId); 4e endif; IsOption3 = *off; SflRcdNbr = rrn; //STAY ON SCREEN sbfSelect = 0; sbfSelAtr = UL; update SBFDTA1; sbfSelAtr = %bitor(ND: PR); 3e endif; readc SBFDTA1; 2e enddo; 1e enddo; endsr; //--------------------------------------------------------- // load bottom of screen with selected key field names begsr srLeadingKeysFooter; IsDbrView = *on; // build string to show on screen 1b for ForCount = 1 to 5; 2b if LeadingKeysDS.KeyFields(ForCount) > *blanks; cc += 1; 3b if LeadingKeysDS.KeyPosition(ForCount) = 0; KeySortArry(cc) = 'X)' + LeadingKeysDS.KeyFields(ForCount); 3x else; KeySortArry(cc) = %char(LeadingKeysDS.KeyPosition(ForCount)) + ')' + LeadingKeysDS.KeyFields(ForCount); 3e endif; 2e endif; 1e endfor; 1b if cc > 1; sorta %subarr(KeySortArry: 1 :cc); 1e endif; clear scKeySelec; 1b for ForCount = 1 to cc; scKeySelec = %trimr(scKeySelec) + ' ' + %trimr(KeySortArry(ForCount)); 1e endfor; aKeySelec = White; endsr; //--------------------------------------------------------- // if user selects option 3 from the data base relationship screen, // I want to load the record formats into a window // otherwise this section loads the file information subfile. //--------------------------------------------------------- begsr srGetFileInformation; 1b if IsOption3; Ind.sfldsp3 = *off; Ind.sfldspctl3 = *off; rrn3 = 0; write WINCTL3; 1x else; sbfRow = *blanks; scHeadOpt = *blanks; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; write SBFCTL1; 1e endif; callp QDBRTVFD( Fild0100ds : 4096: ReturnFileQual : 'FILD0100' : p_FileQual : '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS); sFileName = %subst(ReturnFileQual: 1: 10); sLibName = %subst(ReturnFileQual: 11: 10); PfFile = sFileName; PfLib = sLibName; IsLF = tstbts(Fild0100ds.TypeBits: BitOffset) = 1; PfAttrPtr = Fild0100ptr + Fild0100ds.OffsPFAttr; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; // get based on PF 1b if IsLF; PfFile = FileScopeArry.BasedOnPf; PfLib = FileScopeArry.BasedOnPfLib; 1e endif; scObjHead = f_BuildString('& & &': sFileName: sLibName: Fild0100ds.FileText); 1b if IsOption3; exsr srRow7andRow8; Ind.sfldsp3 = (rrn3 > 0); Ind.sfldspctl3 = *on; write WINCTL3; exfmt WINFOOT3; 1x elseif IsFdScreen; scTitle = f_CenterText('Display File Description': %len(scTitle)); //-ROW 1--------------------------------------------------- // List keys and select/omits 2b if tstbts(FILD0100ds.TypeBits: 6) = 1; // keyed access path sbfRowAtr = Blue; sbfrow = 'Keys__________________'; 3b if FileScopeArry.NumSelectOmit > 0; %subst(sbfrow:24) = 'Select/Omit___________________'; 3x else; %subst(sbfrow:24) = '______________________________'; 3e endif; 3b if FILD0100ds.AccessType = 'KU'; %subst(sbfrow:46) = 'Unique Keys: *YES'; 3e endif; rrn += 1; write sbfDta1; sbfSelAtr = %bitor(ND: PR); exsr srKeys; exsr srLineRow; 2e endif; //--ROW 2-------------------------------------------------- sbfRowAtr = White; %subst(sbfRow:1) = 'Type'; %subst(sbfRow:8) = 'Created'; %subst(sbfRow:20) = 'Last change'; %subst(sbfRow:42) = 'Last Used'; %subst(sbfRow:54) = 'Count'; 2b if not IsLF and PfAttrDS.NumOfTriggers > 0; %subst(sbfRow:61) = 'Triggers'; 2e endif; rrn += 1; write sbfDta1; sbfrow = *blanks; sbfRowAtr = Green; 2b if IsLF; sbfRow = 'LF'; 2x else; sbfRow = 'PF'; 2e endif; QusrObjDS = f_QUSROBJD(ReturnFileQual: '*FILE ': 'OBJD0400'); %subst(sbfrow:7) = f_GetApiISO(QusrobjDS.CreateDateTime); %subst(sbfrow:19) = f_GetApiISO(QusrobjDS.ChangeDateTime); %subst(sbfrow:30) = f_GetApiHMS(QusrobjDS.ChangeDateTime); %subst(sbfrow:42) = f_GetApiISO(QusrobjDS.LastUsedDate); 2b if QusrobjDS.NumDaysUsed > 9999; %subst(sbfrow:54) = '9999'; 2x else; %subst(sbfrow:54) = %char(QusrobjDS.NumDaysUsed); 2e endif; 2b if not IsLF and PfAttrDS.NumOfTriggers > 0; %subst(sbfrow:63) = %char(PfAttrDS.NumOfTriggers); 2e endif; rrn += 1; write sbfDta1; //--ROW 4-------------------------------------------------- sbfRowAtr = White; clear sbfRow; %subst(sbfRow:1) = 'Last Save'; %subst(sbfRow:13) = 'Last Restore'; %subst(sbfRow:27) = 'Member'; 2b if Fild0100ds.NumMbrs >= 1; 3b if Fild0100ds.NumMbrs > 1; %subst(sbfRow:27) = 'First Member'; %subst(sbfRow:68) = 'Members'; 3e endif; %subst(sbfRow:45:7) = 'Records'; %subst(sbfRow:59:7) = 'Deleted'; 2e endif; rrn += 1; write sbfDta1; //--ROW 5-------------------------------------------------- sbfRowAtr = Green; clear sbfRow; %subst(sbfrow:1) = f_GetApiISO(QusrobjDS.SaveDateTime); %subst(sbfrow:13) = f_GetApiISO(QusrobjDS.RestoreDateTime); 2b if Fild0100ds.NumMbrs = 0; %subst(sbfrow:27) = 'File contains no members'; 2x else; QusrmbrdDS = f_Qusrmbrd(ReturnFileQual: '*FIRST ': 'MBRD0200'); %subst(sbfrow:27) = QusrmbrdDS.Mbr; 3b if QusrmbrdDS.CurrNumberRecs > 9999999999; %subst(sbfrow:38) = '9,999,999,999'; 3x else; %subst(sbfrow:38) = %editc(QusrmbrdDS.CurrNumberRecs: '1'); 3e endif; 3b if QusrmbrdDS.DeletedRecs > 9999999999; %subst(sbfrow:52) = '9,999,999,999'; 3x else; %subst(sbfrow:52) = %editc(QusrmbrdDS.DeletedRecs: '1'); 3e endif; 3b if Fild0100ds.NumMbrs > 1; 4b if Fild0100ds.NumMbrs <= 9999999; evalr %subst(sbfrow:66:7) = ' ' + %Char(Fild0100ds.NumMbrs); 4e endif; 3e endif; 2e endif; rrn += 1; write sbfDta1; //--ROW 6-------------------------------------------------- exsr srLineRow; exsr srRow7andRow8; //--ROW 10------------------------------------------------- // Spin through linked list of JoinSpecDSs to get JFLDs (join spec array). 2b if tstbts(Fild0100ds.TypeBits: 2) = 1; 3b if Fild0100ds.NumOfBasedPf > 1; LfSpecificptr = Fild0100ptr + Fild0100ds.OffsLfAttr; 4b if tstbts(LfSpecific.AttrBits: 2) = 1; //1 = JOIN sbfRow = 'Join Fields'; sbfRowAtr = White; rrn += 1; write sbfDta1; sbfRowAtr = Green; JoinSpecPtr = Fild0100ptr + LfSpecific.JoinOffset; 5b dou JoinSpecDS.NextLink = 0; JoinSpecArryPtr = Fild0100ptr + JoinSpecDS.OffsToJSA; 6b for ForCount6 = 1 to JoinSpecDS.NumJFlds; clear sbfrow; 7b if JoinSpecArryDS.FromNumber > 0; sbfrow = %char(JoinSpecArryDS.FromNumber); 7e endif; %subst(sbfrow:5) = JoinSpecArryDS.FromField; 7b if JoinSpecArryDS.ToNumber > 0; %subst(sbfrow:17) = %char(JoinSpecArryDS.ToNumber); 7e endif; %subst(sbfrow:25) = JoinSpecArryDS.ToField; rrn += 1; write sbfDta1; JoinSpecArryPtr += 48; 6e endfor; 6b if JoinSpecDS.NextLink <> 0; JoinSpecPtr = Fild0100ptr + JoinSpecDS.NextLink; 6e endif; 5e enddo; 4e endif; 3e endif; 2e endif; exsr srLineRow; //--------------------------------------------------------- // TRIGGERS //--------------------------------------------------------- 2b if not IsLF and PfAttrDS.NumOfTriggers > 0; sbfRowAtr = White; TriggerPtr = Fild0100ptr + PfAttrDS.OffsTriggers; sbfSelAtr = %bitor(ND: PR); sbfrow = 'Program'; %subst(sbfrow:12) = 'Library'; %subst(sbfrow:24) = 'Event'; %subst(sbfrow:34) = 'Time'; rrn += 1; write sbfDta1; sbfRowAtr = Green; 3b for ForCount7 = 1 to PfAttrDS.NumOfTriggers; sbfrow = TriggerDS.TPrgNam; %subst(sbfrow:12) = TriggerDS.TPrgLib; 4b if TriggerDS.TEvent = '1'; %subst(sbfrow:24) = 'INSERT'; 4x elseif TriggerDS.TEvent = '2'; %subst(sbfrow:24) = 'DELETE'; 4x elseif TriggerDS.TEvent = '3'; %subst(sbfrow:24) = 'UPDATE'; 4e endif; 4b if TriggerDS.TTime = '1'; %subst(sbfrow:34) = 'AFTER'; 4x else; %subst(sbfrow:34) = 'BEFORE'; 4e endif; rrn += 1; write SBFDTA1; TriggerPtr += 48; 3e endfor; 2e endif; 1e endif; endsr; //--ROW 7-------------------------------------------------- // Record Formats: // Either load rows 7 & 8 with record format information for File // description screen, or load window for option 3 on data base relations screen. //--------------------------------------------------------- begsr srRow7andRow8; 1b if IsOption3; sbfRowAtr3 = White; 1x else; sbfRowAtr = White; 1e endif; clear SubText; 1b if Fild0100ds.NumOfBasedPf = 1; SubText = 'RcdFmt'; 1x else; SubText = 'RcdFmts'; 1e endif; 1b if IsLF; %subst(SubText:13) = 'Over Physical File'; 1e endif; 1b if IsOption3; sbfRow3 = SubText; rrn3 += 1; write winDta3; 1x else; sbfRow = SubText; rrn += 1; write sbfDta1; 1e endif; //--ROW 8-------------------------------------------------- 1b if IsOption3; sbfRowAtr3 = Green; 1x else; sbfRowAtr = Green; 1e endif; 1b for ForCount5 = 1 to Fild0100ds.NumOfBasedPf; SubText= FileScopeArry.RcdFmt; 2b if IsLF; %subst(SubText:13) = FileScopeArry.BasedOnPf; %subst(SubText:24) = FileScopeArry.BasedOnPfLib; // to get PF object description text QusrObjDS = f_QUSROBJD(FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib: '*FILE '); %subst(SubText:35) = QusrObjDS.Text; 2e endif; fscopePtr += 160; 2b if IsOption3; sbfRow3 = SubText; rrn3 += 1; write winDta3; 2x else; sbfRow = SubText; rrn += 1; write sbfDta1; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr srDataBaseRelations; IsFdScreen = *off; sbfSelAtr = %bitor(ND: PR); exsr srGetFileInformation; 1b If IsIncludeSO; scTitle = 'INCLUDE Select/Omit Logicals'; %subst(scKeySelec: 11: 7) = 'Exclude'; 1x else; scTitle = 'EXCLUDE Select/Omit Logicals'; %subst(scKeySelec: 11: 7) = 'Include'; 1e endif; 1b if p_CallingCmd = 'JCRLKEY '; exsr srLeadingKeysFooter; 1e endif; sbfRowAtr = White; sbfRow = 'File'; %subst(sbfRow:12) = 'Library'; %subst(sbfRow:21) = 'Fmts U Keys'; rrn += 1; write SBFDTA1; sbfRowAtr = Green; clear sbfRow; // call API to retrieve data base relation names. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QDBLDBR( UserSpaceName: 'DBRL0100': PfFile + PfLib: '*ALL ': '*ALL ': ApiErrDS); QdbldbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; // sort by file name qlgsortDS.RecordLength = GenericHeader.ListEntrySize; qlgsortDS.RecordCount = GenericHeader.ListEntryCount; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(21: 20); qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); callp QLGSORT( qlgsortDS: QuickSort: QuickSort: GenericHeader.ListEntryCount * GenericHeader.ListEntrySize: GenericHeader.ListEntryCount * GenericHeader.ListEntrySize: ApiErrDS); // Process list entries in user space. 1b for ForCount1 = 0 to GenericHeader.ListEntryCount; sbfSelAtr = UL; // put PF first in output. 2b if ForCount1 > 0; WorkFileQual = %subst(QuickSort: 21: 20); 2x else; WorkFileQual = PfFile + PfLib; 2e endif; 2b if WorkFileQual > *blanks and WorkFileQual <> '*NONE '; PfFile = %subst(WorkFileQual: 1: 10); PfLib = %subst(WorkFileQual: 11: 10); callp QDBRTVFD( Fild0100ds: 4096: ReturnFileQual: 'FILD0100' : WorkFileQual : '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); 3b if ApiErrDS.BytesReturned > 0; sbfSelAtr = %bitor(ND: PR); KeyList = '**' + f_RtvMsgApi( ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); %subst(sbfrow:1) = PfFile; %subst(sbfrow:12) = PfLib; rrn += 1; write SBFDTA1; 3x else; // set offsets fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 4b if not(IsIncludeSO) and FileScopeArry.NumSelectOmit > 0 // or Fild0100ds.AccessType='AR' or Fild0100ds.AccessType='EV'; 5b if ForCount1 > 0; QdbldbrPtr += GenericHeader.ListEntrySize; 5e endif; 1i iter; 4e endif; //--------------------------------------------------------- exsr srKeys; 3e endif; 2e endif; 2b if ForCount1 > 0; QdbldbrPtr += GenericHeader.ListEntrySize; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // If this utility is called from JCRLKEY // (find desired access path). then there are // two arrays to process. // LeadingKeysDS.KeyFields will contain key name(s) // LeadingKeysDS.KeyPosition will contain required position in key list. // if LeadingKeysDS.KeyPosition(cc) = 0, then field in any position. //--------------------------------------------------------- begsr srKeys; 1b if p_CallingCmd = 'JCRLKEY '; bb = FileScopeArry.OffsKeySpecs; IsValidKeys = *on; 2b for cc = 1 to %elem(LeadingKeysDS.KeyFields); 3b if LeadingKeysDS.KeyFields(cc) = *blanks; 2v leave; 3e endif; FileScopeArry.OffsKeySpecs = bb; IsThisKeyOK = *off; KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 3b for ForCount2 = 1 to FileScopeArry.NumOfKeys; 4b if LeadingKeysDS.KeyFields(cc) = KeySpecsDS.KeyFieldName and (LeadingKeysDS.KeyPosition(cc) = 0 or LeadingKeysDS.KeyPosition(cc) = ForCount2); IsThisKeyOK = *on; 3v leave; 4e endif; KeySpecsPtr += 32; 3e endfor; 3b if not IsThisKeyOK; IsValidKeys = *off; 2v leave; 3e endif; 2e endfor; 2b if not IsValidKeys; LV leavesr; 2e endif; FileScopeArry.OffsKeySpecs = bb; 1e endif; //--------------------------------------------------------- sbfRowAtr = Green; clear sbfRow; clear KeyList; sbfFileHid = PfFile; sbfLibHid = PfLib; 1b if IsDbrView; scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 3=Record Formats'; %subst(sbfrow:1) = PfFile; %subst(sbfrow:12) = PfLib; %subst(sbfrow:23) = %char(Fild0100ds.NumRcdFmts); 2b if FILD0100ds.AccessType = 'KU'; %subst(sbfrow:25) = 'U'; 2e endif; 1e endif; // Note: some join lfs do not return an offset to // to file scope array. IBM has been notified. 1b if Fild0100ds.OffsFileScope > 0 and tstbts(Fild0100ds.TypeBits: 6) = 1; // keyed access path KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 2b for ForCount3 = 1 to FileScopeArry.NumOfKeys; kwork = %trimr(KeySpecsDS.KeyFieldName); // check for descending keys. 3b if tstbts(KeySpecsDS.KeySequenBits: 0) > 0; kwork = kwork + '(D)'; 3e endif; // If keys will not fit on one line, drop down to second line. // note on the file description display the keys start at the beginning of the // subfile record. If viewing data base relations, the data starts in the // middle of the data. 3b if (IsDbrView and %len(%trimr(KeyList)) + (%len(kwork) + 2) > %size(KeyList)) or (not isDbrView and %len(%trimr(sbfRow)) + (%len(kwork) + 2) > %size(sbfRow)); 4b if IsDbrView; %subst(sbfrow:26) = KeyList; 4e endif; rrn += 1; write sbfDta1; clear sbfRow; clear KeyList; sbfSelAtr = %bitor(ND: PR); 3e endif; 3b if IsDbrView; KeyList = %trimr(KeyList) + ' ' + kwork; 3x else; sbfRow = %trimr(sbfRow) + ' ' + kwork; 3e endif; KeySpecsPtr += 32; 2e endfor; 2b if IsDbrView; %subst(sbfrow:26) = KeyList; 2e endif; 1e endif; rrn += 1; write sbfDta1; sbfSelAtr = %bitor(ND: PR); //--------------------------------------------------------- // extract select/omit fields. 1b if Fild0100ds.OffsFileScope > 0 and FileScopeArry.NumSelectOmit > 0; %subst(sbfRow:25:11) = 'Select/Omit'; SbfRowDS.soCon = 's/o:'; SelectOmitSpecPtr = Fild0100ptr + FileScopeArry.OffsSelectOmit; 2b for ForCount3 = 1 to FileScopeArry.NumSelectOmit; 3b if SelectOmitSpec.StatementRule = 'S'; SbfRowDS.soType = '*SELECT'; 3x elseif SelectOmitSpec.StatementRule = 'O'; SbfRowDS.soType = '*OMIT '; 3x elseif SelectOmitSpec.StatementRule = 'A'; SbfRowDS.soType = '*AND '; 3e endif; SbfRowDS.soFld = SelectOmitSpec.FieldName; //field name SbfRowDS.soComp = SelectOmitSpec.CompRelation; //EQ,NE,GT,LT,ETC SelectOmitParmPtr = Fild0100ptr + SelectOmitSpec.OffsToParms; //--------------------------------------------------------- // extract select/omit values. 3b for ForCount4 = 1 to SelectOmitSpec.NumberOfParms; SbfRowDS.soValu = %subst( SelectOmitParm.ParmValue: 1: SelectOmitParm.ParmLength-20); sbfRow = SbfRowDS; rrn += 1; write sbfDta1; clear SbfRowDS.soCon; SelectOmitParmPtr = Fild0100ptr + SelectOmitParm.OffsToNext; 3e endfor; SelectOmitSpecPtr += 32; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- begsr srLineRow; sbfRowAtr = Blue; sbfrow = *all'_'; rrn += 1; write sbfDta1; endsr; //--------------------------------------------------------- begsr srPrint; f_OvrPrtf('JCRFDP ': *OMIT: 'JCRFDP '); open JCRFDP; write PrtHead; 1b for ForCount = 1 to PrtRrn; chain ForCount SBFDTA1; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; write PrtLine; 1e endfor; close JCRFDP; f_DltOvr('JCRFDP '); // Send print completed message PrtMsg = 'Print Completed'; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRFFD - File Field Descriptions - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('File Field Descriptions') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(RCDFMT) TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Record Format:') PARM KWD(UNPACK) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*NO) VALUES(*NO *YES) PROMPT('Show unpacked format:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT *OUTFILE *SRC) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) PROMPT('Output member options:') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or add records') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE') (*EQ '*SRC ')) NBRTRUE(*EQ 1) ]]> v5r4 *---------------------------------------------------------------- * JCRFFDD - File Field Descriptions - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A INDARA A CA03 A CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A FLDTEXT50 50A H A FLDALIAS 10A H A SBTXT 35A O 7 2 A SBKEY 3A O 7 38 A SBFIELD 10A O 7 42 A SBDATATYPE 1A O 7 54 A SBLENGTH 5Y 0O 7 56EDTCDE(4) A SBDECIMAL 1A O 7 63 A SBFROMPOS 5Y 0O 7 66EDTCDE(4) A SBTOPOS 5Y 0O 7 72EDTCDE(4) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0300) A *DS4 SFLSIZ(0300) A *DS3 SFLPAG(0015) A *DS4 SFLPAG(0015) A OVERLAY A CA04 A CA06 A CA07 A CA08 A CA09 A CA10 A CA11 A RTNCSRLOC(&CURRCD &CURFLD) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A CURRCD 10A H A CURFLD 10A H A 1 2'JCRFFD' A COLOR(BLU) A MSGUNPACK 9A O 1 11 A 1 23'File Field Description' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'File:' A COLOR(WHT) A SCOBJHEAD 63A O 2 8 A 2 72SYSNAME A COLOR(BLU) A 3 2'Keys:' A COLOR(WHT) A KEYLIST 70A O 3 8 A 4 2'RcdFmt:' A COLOR(WHT) A SCRCDFMT 10A O 4 10 A MULTIFMTS 25A O 4 21COLOR(BLU) A 4 52'RecLen:' A COLOR(WHT) A RECORDLEN 5Y 0O 4 60EDTCDE(4) A 4 67'Fields:' A COLOR(WHT) A FIELDCOUNT 4Y 0O 4 75EDTCDE(4) A 5 2'Search:' A SEARCHTXT 26A B 5 10 A SEARCHFLD 10A B 5 42DSPATR(PC) A SEARCHTYP 1A B 5 54 A SEARCHLEN 5Y 0B 5 56EDTCDE(4) A 6 2'Text ' A DSPATR(HI) A DSPATR(UL) A 6 38'Key' A DSPATR(HI) A DSPATR(UL) A FLDORALIAS 9A O 6 42DSPATR(HI) A DSPATR(UL) A 6 52'Type' A DSPATR(HI) A DSPATR(UL) A 6 58'Len' A DSPATR(HI) A DSPATR(UL) A 6 62'Dec' A DSPATR(HI) A DSPATR(UL) A 6 68'Location' A DSPATR(HI) A DSPATR(UL) *---------------------------------------------------------------- A R SFOOTER1 A AF4KEY 1A P A AF7KEY 1A P A AF8KEY 1A P A 23 2'F3=Exit' A COLOR(BLU) A 23 11'F4=Record Formats' A DSPATR(&AF4KEY) A 23 31'F6=Print' A COLOR(BLU) A 23 42'F7=Select/Omit' A DSPATR(&AF7KEY) A 23 59'F8=Toggle ALIAS' A DSPATR(&AF8KEY) A 24 2'F9=Field Sort' A COLOR(BLU) A 24 21'F10=Location Sort' A COLOR(BLU) A 24 42'F11=Key Sort' A COLOR(BLU) A MESSAGE1 21A O 24 59DSPATR(HI) *---------------------------------------------------------------- A R ASSUME ASSUME A 1 2' ' DSPATR(ND) *---------------------------------------------------------------- A R WINDTA3 SFL A SELECT3 1A B 2 2 A SBFRCDFMT 10A O 2 4 *---------------------------------------------------------------- A R WINCTL3 SFLCTL(WINDTA3) OVERLAY A SFLPAG(05) SFLSIZ(15) A WINDOW(4 24 8 15 *NOMSGLIN) A 51 SFLDSP A 52 SFLDSPCTL A N51 SFLCLR A N54 SFLEND(*MORE) A WDWTITLE((*TEXT 'Select Rcdfmt') + A (*COLOR WHT) (*DSPATR HI)) A 1 2'X = Select' COLOR(BLU) A R WINFOOT3 WINDOW(WINCTL3) OVERLAY A 8 2'F12=Previous' COLOR(BLU) *---------------------------------------------------------------- A R WINDTA4 SFL A SOTYPE 7A O 2 3 A SOFLD 10A O 2 11 A SOCOMP 2A O 2 22 A SOVALU 32A O 2 25 A R WINCTL4 SFLCTL(WINDTA4) OVERLAY A 61 SFLDSP A 62 SFLDSPCTL A N61 SFLCLR A N64 SFLEND(*MORE) A SFLPAG(09) SFLSIZ(18) A WINDOW(5 2 12 61 *NOMSGLIN) A WDWTITLE((*TEXT 'Select / Omit Stat- A ements') (*COLOR WHT) (*DSPATR HI)) A R WINFOOT4 WINDOW(WINCTL4) OVERLAY A 12 50'F12=Previous' COLOR(BLU) ]]> v5r4 *---------------------------------------------------------------- * JCRFFDF - File Field Descriptions - PF *---------------------------------------------------------------- A R JCRFFDFR TEXT('File Field Descriptions') A FLDTEXT50 50A COLHDG('Text') A SBKEY 3A COLHDG('Sequence Key') A SBFIELD 10A COLHDG('Name') A SBDATATYPE 1A COLHDG('Attribute') A SBLENGTH 5S 0 COLHDG('Length') A SBDECIMAL 1 COLHDG('Decimals') A SBFROMPOS 5S 0 COLHDG('From') A SBTOPOS 5S 0 COLHDG('To') A FLDALIAS 10A COLHDG('Alias') A FROMFILE 10A COLHDG('File') A FILELIB 10A COLHDG('Library') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRFFD'.File Field Descriptions (JCRFFD) - Help .*-------------------------------------------------------------------- :P.This JCR command generates list of field level information from selected data file. This display allows you to sort on any column and you can toggle between field names and alias names. Also included are options to select which record format to view. :P.If information is put into *SRC, RPGLE source code to initialize each file field will be generated in selected member. :NT.Max record length, Max number of keys and Max number of fields are displayed if you have selected record format from multi-record format file.:ENT. :P.The command has special extension that shows what file would look like if numeric fields where unpacked.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRFFD/FILE'.File - Help :XH3.File (FILE) :P.Name and library of file to be selected.:EHELP. :HELP name='JCRFFD/RCDFMT'.Record Format - Help :XH3.Record Format (RCDFMT) :P.Allows selection of record format for multi-record format files.:EHELP. :HELP name='JCRFFD/UNPACK'.Show unpacked format - Help :XH3.Show unpacked format (UNPACK) :P.Display/report is to use starting and ending positions of data field as is, or as if packed fields were defined as zoned and starting and ending positions adjusted accordingly. :P.This option was originally added to allow display of field positions as they would have been seen by Unix or ASCII machine. All fields are unpacked and converted to ASCII before transmission. :PARML.:PT.:PK def.*NO:EPK.:PD.Data fields to be displayed exactly as defined in database file. :PT.*YES :PD.Starting and ending position of data fields are to be altered to show where they would be if data fields were unpacked.:EPARML.:EHELP. :HELP name='JCRFFD/SRCMBR'.RPGLE Source Member Name - Help :XH3.RPGLE Source Member Name (SCRMBR) :P.RPGLE source member where code will be generated to initialize file fields. :P.I added this option to help with conversion programs. If converting something to hypothetical file B, this option allows me to put every field name in File B in a program so I can make sure I am loading all fields.:EHELP. :HELP name='JCRFFD/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source member.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRFFD/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.Name and library of file where field descriptions to be loaded. :P.This option was added to facilitate downloading file layouts to PC.:EHELP. :HELP name='JCRFFD/OUTMBR'.Out Member Options- Help :XH3.Output (OUTMBR) :P.Database file member that receives output of command. :P.The possible name values are: :P.:PARML.:PT.:PK def.*FIRST:EPK.:PD.The first member in file receives output. If it does not exist, the system creates member with name of file specified in :HP2.File to receive output:EHP2. prompt (OUTFILE parameter). :PT.member-name :PD.Specify name of file member that receives output. If it does not exist, the system creates it.:EPARML. :P.The possible values for how information is stored are: :P.:PARML.:PT.:PK def.*REPLACE:EPK.:PD.The system clears existing member and adds records. :PT.*ADD :PD.The system adds new records to end of existing records.:EPARML.:EHELP. :HELP name='JCRFFD/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print or display field data. :PARML.:PT.:PK def.*PRINT:EPK.:PD.Results to be printed. :PT.* :PD.Results to be displayed on-screen. :PT.:PK def.*OUTFILE:EPK. :PD.Results are placed in data file.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRFFDP - File Field Descriptions - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A INDARA A R PRTHEAD1 SKIPB(1) SPACEA(1) A 2'JCRFFD' A 19'File Field Descriptions' A 09 45'**** UNPACKED FORMAT ****' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) *--- A 2'Format:' A SCRCDFMT 10A O 10 A 22'File:' A SCOBJHEAD 63A O 28SPACEA(1) *---------------------------------------------------------------- A R PRTKEYS SPACEA(1) A 2'Keys :' A KEYLIST 70A O 10 *---------------------------------------------------------------- A R PRTHEAD2 SPACEA(2) A 3'File Type' A 20'Record Length' A 43'Number of Keys' A 62'Number of Fields' SPACEA(1) *--- A FILETYPE4 4A O 5 A 09 20'*UNPACK CALC' A N09 RECORDLEN 5 0O 24EDTCDE(4) A NUMBOFKEYS 4S 0O 47EDTCDE(4) A FIELDCOUNT 4 0O 67EDTCDE(4) *---------------------------------------------------------------- A R PRTSELOMT SPACEA(1) A PRINTSO 4A O 5 A SOTYPE 7A O 12 A SOFLD 10A O 20 A SOCOMP 2A O 31 A SOVALU 32A O 34 *---------------------------------------------------------------- A R PRTHEAD3 SPACEB(1) SPACEA(1) A 3'Text' A 50'Key' A FLDORALIAS 9A 55 A 67'Type' A 73'Length' A 82'Dec' A 89'Location' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A FLDTEXT45 45A O 3 A SBKEY 3A 50 A SBFIELD 10A O 55 A SBDATATYPE 1A O 69 A SBLENGTH 5S 0O 73EDTCDE(4) A SBDECIMAL 1A O 83 A SBFROMPOS 5S 0O 88EDTCDE(4) A SBTOPOS 5S 0O 94EDTCDE(4) *---------------------------------------------------------------- A R PRTPAGEBRK SKIPB(2) A 1' ' ]]> v5r4 //--------------------------------------------------------- // JCRFFDR - File Field Descriptions - print/display // call API to retrieve file field descriptions, // load entries to array and QLGSORT them in user selected sequence. // Output information to media type selected by user. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRFFDP o e printer oflind(IsOverFlow) usropn F indds(indp) FJCRFFDD cf e workstn sfile(SBFDTA1: rrn1) infds(Infds) F sfile(WINDTA3: rrn3) indds(Ind) F sfile(WINDTA4: rrn4) usropn FJCRFFDF o e disk extfile(extOfile) extmbr(ExtOMbr) F usropn FRPGSRC o f 112 disk extfile(extOfile) extmbr(ExtOMbr) F usropn //--*STAND ALONE------------------------------------------- D FileActual s 10a D LibActual s 10a D KeyFldsArry s 10a dim(50) D KeySeqArry s 1a dim(50) D SwapName s 10a D SortByFld s 10a D SearchKey s 3a D extOMbr s 10a D Rpg4Line s 20a D SortOverlay s 200a based(SortPtr) D KeyCount s like(FileScopeArry.NumOfKeys) D SoCount s like(FileScopeArry.NumSelectOmit) D ParmCount s like(SelectOmitSpec.NumberOfParms) D RcdFmtCount s like(Fild0100ds.NumRcdFmts) D LengthOfBuffer s 10i 0 D Rpg4Seqno s 6s 2 D NextFrom s 5u 0 inz(1) D rrn1 s 5u 0 D rrn3 s 5u 0 D rrn4 s 5u 0 D IsToggleAlias s n D IsSearch s n D IsFiltered s n D fscopePtrSave s * D PrtRrn s 5u 0 inz(0) d xx s 5u 0 inz(0) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Dspatr /Define Infds /Define FunctionKeys /Define Ind /Define f_BuildString /Define Qdbrtvfd /Define Fild0100ds /Define Qlgsort /Define Quslfld /Define Tstbts /Define UserSpaceHeaderDS /Define f_AddSortKey /Define f_DspLastSplf /Define f_GetQual /Define f_OvrPrtf /Define f_Dltovr /Define f_GetDayName /Define f_Quscrtus /Define f_SndCompMsg /Define p_JCRFFDR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D indp ds qualified print file indicator D IsUnPacked n overlay(indp:09) inz D ScreenFieldDS e ds extname(JCRFFDF) inz //--*ENTRY PARMS------------------------------------------- D p_JCRFFDR PI D p_FileQual 20a D p_RcdFmt 10a D p_UnPack 4a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free GenericHeaderPtr = f_Quscrtus(UserSpaceName); // Open appropriate output file depend on type selected. 1b if p_Output = '* '; //DISPLAY open JCRFFDD; evalr scDow = %trimr(f_GetDayName()); 1x elseif p_Output = '*PRINT '; f_OvrPrtf('JCRFFDP ': *OMIT: %subst(p_FileQual: 1: 10)); open JCRFFDP; evalr scDow = %trimr(f_GetDayName()); indp.IsUnPacked = (p_UnPack = '*YES'); //set prtf indicator 1x elseif p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRFFDF; 1x elseif p_Output = '*SRC '; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open RPGSRC; 1e endif; FldOrAlias = 'Field'; IsFirstTime = *on; //--------------------------------------------------------- // Load file Header information / get offset to key array // API can return data longer than will fit in RPG variable //--------------------------------------------------------- AllocateSize = f_GetAllocSize01(p_FileQual: p_RcdFmt); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : p_FileQual : p_RcdFmt : '0' : '*FILETYPE ': '*EXT ': ApiErrDS); FileActual = %subst(p_FileQual: 1: 10); LibActual = %subst(ReturnFileQual: 11: 10); scObjHead = f_BuildString('& & &': FileActual: LibActual: Fild0100ds.FileText); RecordLen = Fild0100ds.FileRecLen; FieldCount = Fild0100ds.NumOfFlds; // extract bit info for file type FileType4 = '*PF '; 1b if tstbts(Fild0100ds.TypeBits: 2) = 1; FileType4 = '*LF '; 1e endif; exsr srLoadRcdFmtInfo; //--------------------------------------------------------- 1b if p_Output = '* '; exsr srProcessSubfile; f_SndCompMsg('JCRFFD for ' + %trimr(f_GetQual(FileActual + LibActual)) + ' - completed'); 1x elseif p_Output = '*PRINT '; f_Dltovr('JCRFFDP '); close JCRFFDP; f_DspLastSplf('JCRFFDR ': p_Output); 1x elseif p_Output = '*OUTFILE '; close JCRFFDF; f_SndCompMsg('*Outfile ' + %trimr(extOfile) + ' generated by JCRFFD.'); 1e endif; dealloc Fild0100ptr; *inlr = *on; return; write assume; //--------------------------------------------------------- begsr srProcessSubfile; 1b if Fild0100ds.NumRcdFmts > 1; MultiFmts = 'Press F4 to select format'; aF4key = Blue; 1x else; MultiFmts = *blanks; aF4key = ND; 1e endif; 1b if p_UnPack = '*NO '; MSGUNPACK = *blanks; 1x else; MSGUNPACK = '*UNPACKED'; RecordLen = sbToPos; 1e endif; FldOrAlias = 'Field'; 1b if FileScopeArry.NumSelectOmit > 0; aF7key = Blue; 1x else; aF7key = ND; 1e endif; 1b dow not (InfdsFkey = f03); Ind.sfldsp = rrn1 > 0; Ind.sfldspctl = *on; write SFOOTER1; exfmt SBFCTL1; Message1 = *blanks; IsSearch = *off; 2b if InfdsFkey = f03 or InfdsFkey = f12; LV leavesr; 2x elseif InfdsFkey = f04 and Fild0100ds.NumRcdFmts > 1; exsr srPromptRcdFmt; 2x elseif InfdsFkey = F06; exsr srPrintScreen; Message1 = '** Print Completed **'; 2x elseif InfdsFkey = F07 and FileScopeArry.NumSelectOmit > 0; exsr srSelectOmit; 2x elseif InfdsFkey = f08; IsToggleAlias = *on; 3b if FldOrAlias = 'Field'; // swap column headings FldOrAlias = 'ALIAS'; 3x else; FldOrAlias = 'Field'; 3e endif; 3b for rrn1 = 1 to GenericHeader.ListEntryCount; chain rrn1 SBFDTA1; 4b if FldAlias > *blanks; SwapName = sbField; sbField = FldAlias; FldAlias = SwapName; 4e endif; update SBFDTA1 %fields(FldAlias: sbField); 3e endfor; 2x elseif InfdsFkey = f09; SortByFld = 'SBFIELD '; exsr srResequence; 2x elseif InfdsFkey = f10; SortByFld = 'SBFROMPOS '; exsr srResequence; 2x elseif InfdsFkey = f11; SortByFld = 'SBKEY '; SearchKey = 'Key'; IsSearch = *on; exsr srResequence; SearchKey = *blanks; 2x elseif SearchTxt > *blanks or SearchFld > *blanks or SearchTyp > *blanks or SearchLen > 0; IsSearch = *on; SortByFld = *blanks; exsr srResequence; 2x else; SortByFld = *blanks; exsr srResequence; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- begsr srReadUserSpace; aF8Key = ND; FromFile = FileActual; FileLib = LibActual; QuslfldPtr = GenericHeaderPtr + GenericHeader.OffSetToList; SortPtr = QuslfldPtr; 1b for ForCount = 1 to GenericHeader.ListEntryCount; sbField = QuslfldDS.FieldName; sbDataType = QuslfldDS.FieldType; FldText50 = QuslfldDS.FieldText; FldAlias = QuslfldDS.AliasName; 2b if QuslfldDS.AliasName > *blanks; aF8Key = Blue; 2e endif; 2b if FldText50 = *blanks and FldAlias > *blanks; // show alias if no text FldText50 = FldAlias; 2e endif; // Determine if field Key field and A or Descending. aa = %lookup(sbField: KeyFldsArry: 1: KeyCount); 2b if aa > 0; sbKey = KeySeqArry(aa) + %char(aa); 2x else; clear sbKey; 2e endif; //--------------------------------------------------------- // Calculate ending position of each field. // If field is alpha, field length is loaded from // QuslfldDS.FieldLengthA field. if field is numeric, number of // digits and number of decimals are loaded. if data type // is packed, type field is blanked for printing. 2b if sbDataType = 'A' or sbDataType = 'Z' or sbDataType = 'T' or sbDataType = 'L'; sbLength = QuslfldDS.FieldLengthA; sbDecimal = *blanks; 2x else; sbLength = QuslfldDS.FieldLengthN; sbDecimal = %triml(%editc(QuslfldDS.DecimalPos:'3')); 3b if p_UnPack = '*YES'; sbDataType = *blanks; 3e endif; 2e endif; 2b if p_UnPack = '*NO '; sbFromPos = QuslfldDS.InputPosition; sbToPos = QuslfldDS.OutputPosition + QuslfldDS.FieldLengthA - 1; 2x else; // calculate from and to positions if *un-packed sbFromPos = NextFrom; NextFrom = sbFromPos + sbLength; sbToPos = NextFrom - 1; 2e endif; // write to selected output type. 2b if p_Output = '* '; %subst(QuslfldDS:101: 90) = ScreenFieldDS; sbTxt = FldText50; rrn1 += 1; PrtRrn += 1; write SBFDTA1; 2x elseif p_Output = '*PRINT '; FldText45 = FldText50; write PrtDetail; 3b if IsOverFlow; write PrtPageBrk; IsOverFlow = *off; 3e endif; 2x elseif p_Output = '*OUTFILE'; write JCRFFDFR; 2x elseif p_Output = '*SRC '; Rpg4Line = 'clear ' + %trimr(sbField) + ';'; Rpg4Seqno += 1; except Rpg4Src; 2e endif; QuslfldPtr += GenericHeader.ListEntrySize; 1e endfor; endsr; //--------------------------------------------------------- // get pointer to file scope array for selected record format begsr srLoadRcdFmtInfo; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 1b for RcdFmtCount = 1 to Fild0100ds.NumRcdFmts; 2b if p_RcdFmt = '*FIRST ' or p_RcdFmt = FileScopeArry.RcdFmt; 1v leave; 2e endif; fscopePtr += 160; //next record format 1e endfor; // load field definitions for record format callp QUSLFLD( UserSpaceName: 'FLDL0100': p_FileQual: FileScopeArry.RcdFmt: '0': ApiErrDS); // Load Key Fields array for checking against scRcdFmt = FileScopeArry.RcdFmt; KeyList = '*NONE'; 1b if tstbts(Fild0100ds.TypeBits: 6) = 1; KeyList = *blanks; KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 2b for KeyCount = 1 to FileScopeArry.NumOfKeys; KeyList = %trimr(KeyList) + ' ' + KeySpecsDS.KeyFieldName; KeyFldsArry(KeyCount) = KeySpecsDS.KeyFieldName; // check for descending keys. 3b if tstbts(KeySpecsDS.KeySequenBits: 0) > 0; KeyList = %trimr(KeyList) + '(D)'; KeySeqArry(KeyCount) = 'D'; 3x else; KeySeqArry(KeyCount) = 'A'; 3e endif; KeySpecsPtr += 32; 2e endfor; KeyList = %triml(KeyList); 1e endif; NumbOfKeys = FileScopeArry.NumOfKeys; 1b if p_Output = '*PRINT '; write PrtHead1; write PrtKeys; write PrtHead2; 2b if FileScopeArry.NumSelectOmit > 0; printso = 'S/O:'; exsr srSelectOmit; 2e endif; write PrtHead3; 1e endif; exsr srReadUserSpace; endsr; //--------------------------------------------------------- begsr srPromptRcdFmt; 1b if IsFirstTime; IsFirstTime = *off; Ind.sfldsp3 = *off; Ind.sfldspctl3 = *off; write WINCTL3; rrn3 = 0; clear select3; // load record formats fscopePtrSave = fscopePtr; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 2b for RcdFmtCount = 1 to Fild0100ds.NumRcdFmts; SbfRcdFmt = FileScopeArry.RcdFmt; rrn3 += 1; write WINDTA3; fscopePtr += 160; //next record format 2e endfor; fscopePtr = fscopePtrSave; 1e endif; Ind.sfldsp3 = (rrn3 > 0); Ind.sfldspctl3 = *on; write WINCTL3; exfmt WINFOOT3; readc WINDTA3; 1b if not %eof and select3 > *blanks; p_RcdFmt = SbfRcdFmt; // rrn1 = 0; //Ind.sfldsp = *off; //Ind.sfldspctl = *off; //write SBFCTL1; select3 = *blanks; update WINDTA3; exsr srLoadRcdFmtInfo; 1e endif; endsr; //--------------------------------------------------------- begsr srSelectOmit; 1b if p_Output = '* ' and InfdsFkey <> F06; Ind.sfldsp4 = *off; Ind.sfldspctl4 = *off; write WINCTL4; rrn4 = 0; 1e endif; SelectOmitSpecPtr = Fild0100ptr + FileScopeArry.OffsSelectOmit; 1b for SoCount = 1 to (FileScopeArry.NumSelectOmit - 1); 2b if SelectOmitSpec.StatementRule = 'S'; soType = '*SELECT'; 2x elseif SelectOmitSpec.StatementRule = 'O'; soType = '*OMIT '; 2x elseif SelectOmitSpec.StatementRule = 'A'; soType = '*AND '; 2e endif; sofld = SelectOmitSpec.FieldName; //field name socomp = SelectOmitSpec.CompRelation; //EQ,NE,GT,LT,ETC SelectOmitParmPtr = Fild0100ptr + SelectOmitSpec.OffsToParms; // extract select/omit values. 2b for ParmCount = 1 to SelectOmitSpec.NumberOfParms; sovalu = %subst(SelectOmitParm.ParmValue: 1: SelectOmitParm.ParmLength-20); 3b if p_Output = '* ' and InfdsFkey <> F06; rrn4 += 1; write WINDTA4; 3x else; write PrtSelOmt; printso = *blanks; 3e endif; SelectOmitParmPtr = Fild0100ptr + SelectOmitParm.OffsToNext; 2e endfor; SelectOmitSpecPtr += 32; 1e endfor; 1b if p_Output = '* ' and InfdsFkey <> F06; Ind.sfldsp4 = (rrn4 > 0); Ind.sfldspctl4 = *on; write WINCTL4; exfmt WINFOOT4; 1e endif; endsr; //--------------------------------------------------------- begsr srPrintScreen; f_OvrPrtf('JCRFFDP ': *OMIT: %subst(p_FileQual: 1: 10)); open JCRFFDP; write PrtHead1; write PrtKeys; write PrtHead2; 1b if FileScopeArry.NumSelectOmit > 0; printso = 'S/O:'; exsr srSelectOmit; 1e endif; write PrtHead3; 1b for xx = 1 to PrtRrn; chain xx SBFDTA1; FldText45 = FldText50; write PrtDetail; 2b if IsOverFlow; write PrtPageBrk; IsOverFlow = *off; 2e endif; 1e endfor; close JCRFFDP; f_Dltovr('JCRFFDP '); endsr; //--------------------------------------------------------- // Sort user space then reload subfile begsr srResequence; rrn1 = 0; PrtRrn = 0; ind = *off; write SBFCTL1; 1b if IsSearch; 2b if SearchFld > *blanks; SortByFld = 'SBFIELD '; 2x elseif SearchTxt > *blanks; SortByFld = 'SBTEXT '; 2x elseif SearchKey > *blanks; SortByFld = 'SBKEY '; 2e endif; 1e endif; qlgSortDS = %subst(qlgSortDS: 1: 80); //drop off keys qlgsortDS.RecordLength = GenericHeader.ListEntrySize; qlgsortDS.RecordCount = GenericHeader.ListEntryCount; 1b if SortByFld = 'SBFIELD '; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(154: 10); 1x elseif SortByFld = 'SBFROMPOS '; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(171: 5: 2: 1); 1x elseif SortByFld = 'SBTEXT '; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(101: 50); 1x elseif SortByFld = 'SBKEY '; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(151: 3: 6: 1); 1e endif; qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); LengthOfBuffer = GenericHeader.ListEntryCount * GenericHeader.ListEntrySize; callp QLGSORT( qlgsortDS: SortOverlay: SortOverlay: LengthOfBuffer: LengthOfBuffer: ApiErrDS); QuslfldPtr = SortPtr; 1b for ForCount = 1 to GenericHeader.ListEntryCount; ScreenFieldDS = %subst(Quslfldds:101); IsFiltered = *on; 2b if IsSearch; 3b if SearchFld > *blanks; IsFiltered = %scan(%trimr(SearchFld): sbField) > 0; 3x elseif SearchKey > *blanks; IsFiltered = (Sbkey > *blanks); 3x elseif SearchTyp > *blanks; IsFiltered = (sbDataType = SearchTyp); 3x elseif SearchLen > 0; IsFiltered = (sbLength = SearchLen); 3x elseif SearchTxt > *blanks; IsFiltered = %scan(%trimr(SearchTxt): %xlate(lo: up: FldText50)) > 0; 3e endif; 2e endif; 2b if IsFiltered; sbTxt = FldText50; rrn1 += 1; PrtRrn += 1; write SBFDTA1; 2e endif; QuslfldPtr += GenericHeader.ListEntrySize; 1e endfor; endsr; /end-free ORPGSRC e Rpg4Src O Rpg4Seqno 6 O 12 '000000' O Rpg4Line 40 ]]> v5r4 //--------------------------------------------------------- // JCRFFDRV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define Qdbrtvfd /Define ApiErrDS /Define f_CheckMbr /Define f_CheckObj /Define f_OutFileCrtDupObj /Define f_RtvMsgAPI /Define f_SndEscapeMsg /Define p_JCRFFDR /Define p_JCRFFDRV /COPY JCRCMDS,JCRCMDSCPY D Alpha8 s 8a //--*ENTRY PARMS------------------------------------------- D p_JCRFFDRV PI D p_FileQual 20a D p_RcdFmt 10a D p_UnPack 4a D p_Output 8a D p_OutFileQual 20a D p_MbrOpt 22a //--------------------------------------------------------- /free 1b if %subst(p_FileQual: 11: 10) <> '*LIBL '; f_CheckObj(%subst(p_FileQual: 11: 10) + 'QSYS ':'*LIB '); 1e endif; // check record format name callp QDBRTVFD( Alpha8: 8: ReturnFileQual: 'FILD0200' : p_FileQual: p_RcdFmt : '0': '*LCL ': '*EXT ': ApiErrDS ); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; 1b if p_Output = '*SRC '; f_CheckMbr(p_OutFileQual: %subst(p_MbrOpt: 3: 10)); 1e endif; 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_MbrOpt: 'JCRFFDF '); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRFREESS - Side-by-side fixed /free source compare - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Side-by-side Fixed/Free Cmp') PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('RPG member name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(* ) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRFREESS'.Side-by-side Fixed/Free Cmp (JCRFREESS) - Help .*-------------------------------------------------------------------- :P.This JCR command shows original RPG4 columnar calc specs on left and what code would look like in /Free format on right side. :P.Opcodes with ????????? means this is not valid in /free and must be re-written. You may be surprised at the number of deprecated opcdes as IBM dropped a bunch of bad legacy stuff. :P.It is strongly recommended you clean up the code so no ?????????? are showing before making any attempt to convert to free. :P.Summary page is produced at bottom of each report showing each opcode that could not be converted and number of times it was used in the code.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRFREESS/SRCMBR'.RPG member name - Help :XH3.RPG member name (SRCMBR) :P.Member for which compare is to be generated.:EHELP. :HELP name='JCRFREESS/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP name='JCRFREESS/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRFREESSP - Side-by-side fixed /free source compare - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRFREESS' A 23'Side-by-side Fixed/Free Compare' A SCDOW 9A O 100 A 110DATE EDTWRD(' / / ') SPACEA(1) *--- A 2'Mbr:' A SCOBJHEAD 105A O 7SPACEA(2) *--- A 1'Seqno' A 10'Factor 1' A 25'Opcode' A 36'Factor 2' A 51'Result Field' A 65'RI' A 75'/FREE Conversion attempt' A SPACEA(1) *--- A 8'----------------------------------- A ------------------------------' A 75'----------------------------------- A ------------------------------------ A ------------------------------------ A --------' *---------------------------------------------------------------- A R PRTCSPEC SPACEA(1) A SEQNO 6 2O 1EDTCDE(4) A F1 14A O 10 A OP 10A O 25 A F2 14A O 36 A RF 14A O 51 A RSI 6A O 66 A 73'|' A LINEOFCODE 112A O 75 *---------------------------------------------------------------- A R PRTSUMHEAD SKIPB(1) SPACEA(2) A 2'JCRFREESS' A 16'Summary of OPCODES that will requi- A re manual conversion' A SCDOW 9A O 100 A 110DATE EDTWRD(' / / ') SPACEA(1) *--- A 3'Member:' A P_SRCMBR 10A O 11 A 26' Source File:' A P_SRCFIL 10A O 40 A 57'Source Library:' A P_SRCLIB 10A O 73SPACEA(2) *--- A 3'Opcode' A 11'Number times used' *---------------------------------------------------------------- A R PRTSUMDET SPACEA(1) A SUMOPCOD 10A O 3 A SUMCOUNT 5 0O 14EDTCDE(4) ]]> v5r4 //--------------------------------------------------------- // JCRFREESSR - Side-by-side fixed /free source compare // read Rpg source code // scan for structure keywords // print converted columnar code to free format. // print summary of opcodes requiring manual change //--------------------------------------------------------- // Note: Originally designed to be conversion program between columnar // and /free. In the process, I realized just how impossible that was going to be without // massive rewrites of our legacy code. I blow my nose on any tool says // they can 'easily' convert RPG into /free. // Any lines with ???????????????????? are invalid in /free and must be re-written. // Final page of report is summary/count of invalid opcodes. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FV4SRC if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn FJCRFREESSPo e printer oflind(*in01) usropn //--*STAND ALONE------------------------------------------- D ee s like(LevelsDeep) D ff s like(LevelsDeep) D F2upper s like(f2) D OpUpsave s like(OpUp) D RFupper s like(SrcDS.ResultField) D Work s like(SrcDS.Src112) D WorkUpper s like(SrcDS.Src112) D xx s like(LevelsDeep) D yy s like(LevelsDeep) D OpCodeArry s 10a dim(200) D LF2 s 14a D LineOfCode s 112a D zz s 14a D CountArry s 5u 0 dim(200) D LevelsDeep s 5u 0 D DownOneLevel s n D IsCalcSpec s n D IsCallp s n D IsCasxx s n D IsWhenIndent s n D UpOneLevel s n D IsFree s n D IsSQL s n //--*COPY DEFINES------------------------------------------ /Define SrcDs /Define Constants /Define f_DspLastSplf /Define f_GetQual /Define f_IsValidMbrType /Define f_GetDayName /Define f_BuildString /Define f_System /Define f_Qusrmbrd /Define f_Dltovr /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D OpUp ds 10 D DoIfWh 2a overlay(OpUp:1) D EndOpcode 3a overlay(OpUp:1) //--*ENTRY PARMS------------------------------------------- D p_JCRFREESSR PR extpgm('JCRFREESSR') D 10a D 20a D 8a D p_JCRFREESSR PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_Output 8a //--*INPUT PARMS------------------------------------------- Iv4Src ns I a 1 112 SrcDs //--------------------------------------------------------- /free QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); 1b If QusrmbrdDS.MbrType = 'RPGLE ' or QusrmbrdDS.MbrType = 'SQLRPGLE '; %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; scObjHead = f_BuildString('& & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); extIfile = f_GetQual(p_SrcFilQual); f_System('OVRPRTF FILE(JCRFREESSP) ' + 'SPLFNAME(' + %trimr(p_SrcMbr) + ') ' + 'PRTTXT(*BLANK) OVRSCOPE(*JOB)'); open v4Src; open JCRFREESSp; evalr scDow = %trimr(f_GetDayName()); write PrtHead; //--------------------------------------------------------- read v4Src; 2b dow not %eof; Seqno = SrcDS.SeqNum6; F1 = SrcDS.Factor1; OP = SrcDS.OpCode; F2 = SrcDS.Factor2; RF = SrcDS.ResultField; RSI = SrcDS.ResultingInd; 3b if SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c' or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'p'; 2v leave; 3e endif; // see if inside /free section 3b if SrcDS.Asterisk = '/'; SrcDS.FreeForm = %xlate(lo: up: SrcDS.FreeForm); 4b if SrcDS.FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 4x elseif SrcDS.FreeForm = '/END-FREE'; IsFree = *off; 4e endif; 4b if SrcDS.FreeForm = '/EXEC SQL'; IsSQL = *on; IsCalcSpec = *on; 4x elseif SrcDS.FreeForm = '/END-EXEC'; IsSQL = *off; 4e endif; 3e endif; 3b if SrcDS.SpecType = 'C' or SrcDS.SpecType = 'c'; IsCalcSpec = *on; 3e endif; 3b if SrcDS.SpecType = 'O' or SrcDS.SpecType = 'o' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'd' or SrcDS.SpecType = 'F' or SrcDS.SpecType = 'f'; IsCalcSpec = *off; 3e endif; 3b if IsCalcSpec; DownOneLevel = *off; UpOneLevel = *off; 4b if not (SrcDS.Asterisk = '+' or SrcDS.Asterisk = '/'); 5b if SrcDS.OpCode > *blanks; IsCallp = *off; 5e endif; OpUp = %xlate(lo: up: SrcDS.OpCode); 5b if SrcDS.Asterisk = '*'; 5x elseif EndOpcode = 'CAS'; IsCasxx = *on; 5x elseif DoIfWh = 'DO' or DoIfWh = 'IF' or OpUp = 'SELECT ' or OpUp = 'BEGSR ' or OpUp = 'FOR ' or OpUp = 'MONITOR ' or %subst(OpUp: 1: 4) = 'FOR('; DownOneLevel = *on; // Set Flag if END is found 5x elseif EndOpcode = 'END'; 6b if not IsCasxx; UpOneLevel = *on; 6e endif; IsCasxx = *off; 5e endif; 4e endif; // Convert EVERYTHING to free format clear Work; clear LineOfCode; IsComment = *off; 4b if IsFree or IsSql; Work = SrcDS.Src112; 4x elseif SrcDS.Asterisk = '*'; 5b if %subst(SrcDS.Src112: 8) = *blanks; Work = *blanks; 5x else; Work = '// ' + %triml(%subst(SrcDS.Src112: 8)); IsComment = *on; 5e endif; 4x elseif SrcDS.SlashComment = '/E' or // i hate ejects SrcDS.SlashComment = '/e'; Work = *blanks; //--------------------------------------------------------- // All DO statements must be converted to FOR opcodes // There are 5 variations of on DO // DO = FOR JCRCNT = 1 to 1 // DO xx = FOR JCRCNT = 1 to xx // DO xx yy = FOR yy = 1 to xx // aa DO xx = FOR JCRCNT = aa to xx // aa DO xx yy = FOR yy = aa to xx // Counter field JCRCNT is provided to make FOR work //--------------------------------------------------------- 4x elseif OpUp = 'DO '; 5b if SrcDS.Factor1 > *blanks //aa DO xx yy and SrcDS.Factor2 > *blanks and SrcDS.ResultField > *blanks; Work = 'for ' + %trimr(SrcDS.ResultField) + ' = ' + %trimr(SrcDS.Factor1) + ' to ' + SrcDS.Factor2; 5x elseif SrcDS.Factor1 > *blanks //aa DO xx and SrcDS.Factor2 > *blanks and SrcDS.ResultField = *blanks; Work = 'for JCRCNT = ' + %trimr(SrcDS.Factor1) + ' to ' + SrcDS.Factor2; 5x elseif SrcDS.Factor1 = *blanks //DO xx yy and SrcDS.Factor2 > *blanks and SrcDS.ResultField > *blanks; Work = 'for ' + %trimr(SrcDS.ResultField) + ' = 1 to ' + SrcDS.Factor2; 5x elseif SrcDS.Factor1 = *blanks //DO xx and SrcDS.Factor2 > *blanks and SrcDS.ResultField = *blanks; Work = 'for JCRCNT = 1 to ' + SrcDS.Factor2; 5x elseif SrcDS.Factor1 = *blanks //DO and SrcDS.Factor2 = *blanks and SrcDS.ResultField = *blanks; Work = 'dou ''''1'''''; 5e endif; 4x elseif %subst(OpUp: 1: 6) = 'ADDDUR' or %subst(OpUp: 1: 6) = 'SUBDUR'; exsr srADDDUR; 4x elseif %subst(OpUp: 1: 6) = 'EXTRCT'; Work = 'eval ' + %trimr(SrcDS.ResultField) + ' = %subdt(' + %trimr(SrcDS.Factor2) + ')'; 4x elseif %subst(OpUp: 1: 5) = 'CHECK'; Work = 'eval ' + %trimr(SrcDS.ResultField) + ' = %' + %trimr(SrcDS.OpCode) + '(' + %trimr(SrcDS.Factor1) + ':' + %trimr(SrcDS.Factor2) + ')'; 4x elseif %subst(OpUp: 1: 5) = 'XLATE'; Work = 'eval ' + %trimr(SrcDS.ResultField) + ' = %' + %trimr(SrcDS.OpCode) + '(' + %trimr(SrcDS.Factor1) + ':' + %trimr(SrcDS.Factor2) + ')'; 4x elseif %subst(OpUp: 1: 6) = 'LOOKUP'; exsr srLOOKUP; 4x elseif %subst(OpUp: 1: 5) = 'XFOOT'; exsr srXFOOT; 4x elseif %subst(OpUp: 1: 5) = 'OCCUR'; exsr srOCCUR; //--------------------------------------------------------- // FACTOR1 OP FACTOR2 RESULT conversions. // FACTOR1 OP FACTOR2 // FACTOR1 OP // end result is opcode Factor1 Factor2 Result 4x elseif %subst(OpUp: 1: 3) = 'ACQ' or OpUp = 'BEGSR ' or OpUp = 'MONITOR ' or OpUp = 'ON-ERROR ' or %subst(OpUp: 1: 5) = 'CHAIN' or %subst(OpUp: 1: 6) = 'COMMIT' or %subst(OpUp: 1: 6) = 'DELETE' or %subst(OpUp: 1: 5) = 'DSPLY' or %subst(OpUp: 1: 4) = 'DUMP' or %subst(OpUp: 1: 4) = 'POST' or %subst(OpUp: 1: 3) = 'END' or %subst(OpUp: 1: 3) = 'IN ' or %subst(OpUp: 1: 3) = 'IN(' or %subst(OpUp: 1: 4) = 'NEXT' or %subst(OpUp: 1: 3) = 'OUT' or %subst(OpUp: 1: 4) = 'POST' or %subst(OpUp: 1: 5) = 'READE' or %subst(OpUp: 1: 6) = 'READPE' or %subst(OpUp: 1: 3) = 'REL' or %subst(OpUp: 1: 5) = 'RESET' or OpUp = 'CLEAR ' or %subst(OpUp: 1: 5) = 'ROLBK' or %subst(OpUp: 1: 5) = 'SETGT' or %subst(OpUp: 1: 5) = 'SETLL' or %subst(OpUp: 1: 5) = 'TEST ' or %subst(OpUp: 1: 5) = 'TEST(' or %subst(OpUp: 1: 6) = 'UNLOCK'; 5b if SrcDS.Factor1 = *blanks; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 5x else; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor1) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 5e endif; // resulting ind errors 5b if SrcDS.ResultingInd > *blanks; Work = %trimr(Work) + ' ??' + %trim(SrcDS.ResultingInd) + '????????????????'; OpUpsave = OpUp; OpUp = 'ResultInd'; exsr srLoadError; OpUp = OpUpsave; 5e endif; //--------------------------------------------------------- // opcode FACTOR2 RESULT conversions. // opcode FACTOR2 // end result is Opcode Factor2 Result 4x elseif OpUp = 'EXCEPT ' or OpUp = 'EXFMT ' or OpUp = 'EXSR ' or OpUp = 'ELSE ' or OpUp = 'ELSEIF ' or OpUp = 'FORCE ' or OpUp = 'ITER ' or OpUp = 'LEAVE ' or OpUp = 'LEAVESR' or OpUp = 'OTHER ' or %subst(OpUp: 1: 5) = 'CLOSE' or %subst(OpUp: 1: 4) = 'OPEN' or %subst(OpUp: 1: 5) = 'READ ' or %subst(OpUp: 1: 5) = 'READ(' or %subst(OpUp: 1: 5) = 'READC' or %subst(OpUp: 1: 5) = 'READP' or OpUp = 'SELECT ' or OpUp = 'SORTA ' or %subst(OpUp: 1: 6) = 'UPDATE' or %subst(OpUp: 1: 5) = 'WRITE' or %subst(OpUp: 1: 4) = 'FEOD'; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 5b if SrcDS.ResultingInd > *blanks; Work = %trimr(Work) + ' ??' + %trim(SrcDS.ResultingInd) + '????????????????'; OpUpsave = OpUp; OpUp = 'ResultInd'; exsr srLoadError; OpUp = OpUpsave; 5e endif; //--------------------------------------------------------- // Opcode RESULT field simple compressions 4x elseif %subst(OpUp: 1:7) = 'DEALLOC'; Work = %trimr(SrcDS.OpCode) + ' ' + SrcDS.ResultField; //--------------------------------------------------------- // opcode Extended Factor2 compressions // Will need to revisit this for + signs to line up code. 4x elseif (%subst(OpUp: 1: 4) = 'DOU ' or %subst(OpUp: 1: 4) = 'DOU(' or %subst(OpUp: 1: 4) = 'DOW ' or %subst(OpUp: 1: 4) = 'DOW(' or %subst(OpUp: 1: 5) = 'CALLP') or %subst(OpUp: 1: 4) = 'EVAL' or %subst(OpUp: 1: 4) = 'FOR ' or %subst(OpUp: 1: 4) = 'FOR(' or %subst(OpUp: 1: 3) = 'IF ' or %subst(OpUp: 1: 3) = 'IF(' or %subst(OpUp: 1: 6) = 'RETURN' or %subst(OpUp: 1: 5) = 'WHEN ' or %subst(OpUp: 1: 5) = 'WHEN('; Work = %trimr(SrcDS.OpCode) + ' ' + SrcDS.ExtendFactor2; // get position for callp parms to line up with factor2 bb = %scan(SrcDS.ExtendFactor2: Work); 5b if %subst(OpUp: 1: 5) = 'CALLP'; IsCallp = *on; 5e endif; 4x else; //--------------------------------------------------------- 5b if OpUp = *blanks; 6b if not IsCallp; Work = SrcDS.ExtendFactor2; 6x else; clear Work; %subst(Work: bb) = %trimr(SrcDS.ExtendFactor2); 6e endif; 5x else; exsr srLoadError; Work = %trimr(SrcDS.OpCode) + ' ?????????????????????????'; 5e endif; 4e endif; exsr srOutput; 3e endif; read v4Src; 2e enddo; write PrtSumHead; 2b for ff = 1 to ee; sumopcod = OpCodeArry(ff); sumCount = CountArry(ff); write PrtSumDet; 2e endfor; close v4Src; close JCRFREESSp; f_DltOvr('JCRFREESSP'); f_DspLastSplf('JCRFREESSR': p_Output); 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Save opcodes not converted and number of times used for summary report. begsr srLoadError; ff = %lookup(OpUp: OpCodeArry); 1b if ff > 0; CountArry(ff) += 1; 1x else; ee += 1; OpCodeArry(ee) = OpUp; CountArry(ee) = 1; 1e endif; endsr; //--------------------------------------------------------- begsr srADDDUR; f2upper = %xlate(lo: up: SrcDS.Factor2); rfupper = %xlate(lo: up: SrcDS.ResultField); Work = 'eval'; 1b if OpUp = 'ADDDUR(E)' or OpUp = 'SUBDUR(E)'; Work = 'eval(e)'; 1e endif; xx = %scan(':': SrcDS.Factor2); 1b if xx > 0; Work = %trimr(Work) + ' ' + %trimr(SrcDS.ResultField) + ' ='; 2b if SrcDS.Factor1 = *blank; Work = %trimr(Work) + ' ' + SrcDS.ResultField; 2x else; Work = %trimr(Work) + ' ' + SrcDS.Factor1; 2e endif; 2b if %subst(OpUp: 1: 6) = 'ADDDUR'; Work = %trimr(Work) + ' + '; 2x else; Work = %trimr(Work) + ' - '; 2e endif; xx = %scan(':': SrcDS.Factor2); 2b if %subst(F2upper: xx + 1) = '*MSECONDS' or %subst(F2upper: xx + 1) = '*MS'; Work = %trimr(Work) + ' %mseconds('; 2x elseif %subst(F2upper: xx + 1) = '*SECONDS' or %subst(F2upper: xx + 1) = '*S'; Work = %trimr(Work) + ' %seconds('; 2x elseif %subst(F2upper: xx + 1) = '*MINUTES' or %subst(F2upper: xx + 1) = '*MN'; Work = %trimr(Work) + ' %minutes('; 2x elseif %subst(F2upper: xx + 1) = '*HOURS' or %subst(F2upper: xx + 1) = '*H'; Work = %trimr(Work) + ' %hours('; 2x elseif %subst(F2upper: xx + 1) = '*DAYS' or %subst(F2upper: xx + 1) = '*D'; Work = %trimr(Work) + ' %days('; 2x elseif %subst(F2upper: xx + 1) = '*MONTHS' or %subst(F2upper: xx + 1) = '*M'; Work = %trimr(Work) + ' %months('; 2x elseif %subst(F2upper: xx + 1) = '*YEARS' or %subst(F2upper: xx + 1) = '*Y'; Work = %trimr(Work) + ' %year('; 2e endif; Work = %trimr(Work) + %subst(SrcDS.Factor2: 1: xx - 1) + ')'; 1x else; //--------------------------------------------------------- // Process DIFF statements // first extract field from RF xx = %scan(':': SrcDS.ResultField); Work = %trimr(Work) + ' ' + %subst(SrcDS.ResultField: 1: xx - 1) + ' = %diff(' + %trimr(SrcDS.Factor1) + ':' + %trimr(SrcDS.Factor2) + ':' + %trimr(%subst(SrcDS.ResultField: xx + 1)) + ')'; 1e endif; endsr; //--------------------------------------------------------- begsr srLOOKUP; clear zz; lf2 = SrcDS.Factor2; f2upper = %xlate(lo: up: SrcDS.Factor2); Work = 'eval'; 1b if %subst(F2upper: 1: 3) = 'TAB'; Work = 'eval *in' + %trim(SrcDS.ResultingInd) + ' = %tlookup'; 1x else; xx = %scan('(': SrcDS.Factor2); 2b if xx = 0; 3b if (SrcDS.ResultingInd) > *blanks; Work = 'eval *in' + %trim(SrcDS.ResultingInd) + ' = %lookup'; 3x else; Work = 'eval JCRInt = %lookup'; 3e endif; 2x else; yy = %scan(')': SrcDS.Factor2: xx); lf2 = %subst(SrcDS.Factor2: 1: xx - 1); zz = %subst(SrcDS.Factor2: xx + 1: yy - (xx + 1)); Work = 'eval ' + %trimr(zz) + ' = %lookup'; 2e endif; 1e endif; // Now look at indicators assigned and tack on type lookup. 1b if SrcDS.EQind > *blanks and SrcDS.HIind = *blanks and SrcDS.LOind = *blanks; Work = %trimr(Work) + 'EQ('; 1x elseif SrcDS.EQind = *blanks and SrcDS.HIind > *blanks and SrcDS.LOind = *blanks; Work = %trimr(Work) + 'GT('; 1x elseif SrcDS.EQind = *blanks and SrcDS.HIind = *blanks and SrcDS.LOind > *blanks; Work = %trimr(Work) + 'LT('; 1x elseif SrcDS.EQind > *blanks and SrcDS.HIind > *blanks and SrcDS.LOind = *blanks; Work = %trimr(Work) + 'GE('; 1x elseif SrcDS.EQind > *blanks and SrcDS.HIind = *blanks and SrcDS.LOind > *blanks; Work = %trimr(Work) + 'LE('; 1x else; Work = %trimr(Work) + '??('; 1e endif; Work = %trimr(Work) + %trimr(SrcDS.Factor1) + ':' + %trimr(lf2); 1b if %subst(F2upper: 1: 3) <> 'TAB'; 2b if zz = *blanks; Work = %trimr(Work) + ')'; 2x else; Work = %trimr(Work) + ':' + %trimr(zz) + ')'; 2e endif; 1x else; 2b if SrcDS.ResultField = *blanks; Work = %trimr(Work) + ')'; 2x else; Work = %trimr(Work) + ':' + %trimr(SrcDS.ResultField) + ')'; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srXFOOT; Work = 'eval'; xx = %scan('(': SrcDS.OpCode); 1b if xx > 0; Work = %trimr(Work) + %subst(SrcDS.OpCode: xx); 1e endif; Work = %trimr(Work) + ' ' + %trimr(SrcDS.ResultField) + ' = %xfoot(' + %trimr(SrcDS.Factor2) + ')'; endsr; //--------------------------------------------------------- begsr srOCCUR; Work = 'eval'; xx = %scan('(': SrcDS.OpCode); 1b if xx > 0; Work = %trimr(Work) + %subst(SrcDS.OpCode: xx); 1e endif; 1b if SrcDS.Factor1 > *blanks; Work = %trimr(Work) + ' %occur(' + %trimr(SrcDS.Factor2) + ') = ' + SrcDS.Factor1; 1x else; Work = %trimr(Work) + ' ' + %trimr(SrcDS.ResultField) + ' = %occur(' + %trimr(SrcDS.Factor2) + ')'; 1e endif; endsr; //--------------------------------------------------------- begsr srOutput; 1b if UpOneLevel; LevelsDeep -= 1; 1e endif; // deal with indenting code under WHEN, OTHER statement. 1b if (OpUp = 'WHEN ' or OpUp = 'OTHER') and IsWhenIndent = *on; LevelsDeep -= 1; 1e endif; clear LineOfCode; xx = 1; 1b for yy = 1 to LevelsDeep; 2b if xx <= 109; // less than 37 levels deep %subst(LineOfCode: xx: 3) = ' '; 2e endif; xx += 3; 1e endfor; // deal with indenting code under WHEN, OTHER statement. 1b if OpUp = 'WHEN ' or OpUp = 'OTHER'; LevelsDeep += 1; IsWhenIndent = *on; 1e endif; // deal with lines ending in AND , OR , + , or : %subst(LineOfCode: xx) = Work; WorkUpper = %xlate(lo: up: Work); aa = %checkr(' ': WorkUpper); 1b if LineOfCode > *blanks and (aa > 3 and not IsComment and not IsSQL and not (%subst(WorkUpper: aa: 1) = '+' or %subst(WorkUpper: aa: 1) = ':' or %subst(WorkUpper: aa: 1) = '<' or %subst(WorkUpper: aa: 1) = '>' or %subst(WorkUpper: aa: 1) = '=' or %subst(WorkUpper: aa: 1) = '(' or %subst(WorkUpper: aa - 3: 4) = ' AND' or %subst(WorkUpper: aa - 2: 3) = ' OR')); LineOfCode = %trimr(LineOfCode) + ';'; 1e endif; // Tack on comment field 1b if SrcDS.SrcComment > *blanks and not IsComment; 2b if %subst(LineOfCode: 91: 2) = ' '; //leave comments as is %subst(LineOfCode: 91: 2) = '//'; %subst(LineOfCode: 93: 20) = SrcDS.SrcComment; 2x else; LineOfCode = %trimr(LineOfCode) + ' // ' + SrcDS.SrcComment; 2e endif; 1e endif; 1b if DownOneLevel; //INDENT? LevelsDeep += 1; 1e endif; 1b if SrcDS.SlashComment > *blanks and not (%subst(SrcDS.SlashComment: 1: 1) = '/' or %subst(SrcDS.SlashComment: 1: 1) = '+' or %subst(SrcDS.SlashComment: 1: 1) = '*'); LineOfCode = '??' + SrcDS.SlashComment + '??????? ' + LineOfCode; OpUpsave = OpUp; OpUp = 'LevelInd'; exsr srLoadError; OpUp = OpUpsave; 1e endif; 1b if SrcDS.Conditioning > *blanks and not (%subst(SrcDS.SlashComment: 1: 1) = '/' or %subst(SrcDS.SlashComment: 1: 1) = '+' or %subst(SrcDS.SlashComment: 1: 1) = '*'); LineOfCode = '??' + SrcDS.Conditioning + '??????? ' + LineOfCode; OpUpsave = OpUp; OpUp = 'ConditInd'; exsr srLoadError; OpUp = OpUpsave; 1e endif; 1b if OpUp = 'KLIST ' or OpUp = 'KFLD '; LineOfCode = SrcDS.Src112; 1e endif; write PrtCspec; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRFSET - Scan File Set Where Used - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Scan File Set Where Used') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File Name:') FILE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(1) MAX(9) + PROMPT('Source File(s):') SRCFILE: ELEM TYPE(*NAME) LEN(10) SPCVAL((*HISTORY)) + CHOICE('File Name or F4 for predefined') + PROMPT('File Name:') ELEM TYPE(*NAME) LEN(10) PROMPT(' Library:') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL, name, generic*') PROMPT(' Mbr:') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL,RPGLE,RPG,CLP,DSPF,etc.') + PROMPT(' Mbr Type:') PARM KWD(IUO) TYPE(*CHAR) LEN(1) RSTD(*YES) + DFT(*ALL) VALUES(I O U) SPCVAL((*ALL + 'X')) MIN(0) PROMPT('Usage:') PARM KWD(LISTLEVEL) TYPE(*CHAR) LEN(6) RSTD(*YES) + DFT(*FIRST) VALUES(*FIRST *ALL) + PROMPT('List occurrences in each mbr:') PARM KWD(LFSAMELIB) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Only + LFs in samelib as PF:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *OUTFILE *) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) + PROMPT('Output mbr options') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Mbr to receive + output:') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or + add records:') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) NBRTRUE(*EQ 1) ]]> v5r4 *---------------------------------------------------------------- * JCRFSETF- Scan File Set Where Used outfile support - PF *---------------------------------------------------------------- A R JCRFSETFR TEXT('File Set Where Used') A SRCLIB 10A COLHDG('Source library') A SRCFIL 10A COLHDG('Source file') A LISTMBR 10A COLHDG('Source mbr') A MBRTYPE 10A COLHDG('Mbr Type') A SRCUSAGE 1A COLHDG('File Usage') A SRCTXT 40A COLHDG('Text') A SRCSEQ 6S 2 COLHDG('Sequence') A SRCDTA 100A COLHDG('Source') A SRCCHGDAT 6S 0 COLHDG('Change Date') A SCANFILE 10A COLHDG('Original File') A SBASEDON 10A COLHDG('Based on File') * --------------------------------------------------------------------- * Following fields are not used by JCRFSET utility. * I also use this file for reporting Implementer objects that * are on existing requests and who has it checked out. * --------------------------------------------------------------------- A IMDRNB 7 0 COLHDG('IMP Design Number') A IMMOCC 7 COLHDG('IMP Object Type') A IMDRIN 3 COLHDG('IMP User Initials') A IMCULB 10 COLHDG('IMP Locked to Lib') A K LISTMBR ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRFSET'.Scan File Set Where Used (JCRFSET) - Help .*-------------------------------------------------------------------- :P.This JCR command scans up to nine source files for your selected data file. Utility retrieves all PF and LF file names associated with selected data file and scans for those names in selected source members. :P.End result is either print or outfile of all source members that use selected file or one of logicals associated with physical.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRFSET/FILE'.File Name - Help :XH3.File Name (FILENAME) :P.File name for which data base relations will be retrieved and scanned in the selected source.:EHELP. :HELP name='JCRFSET/SRCFILE'.Source File(s) - Help :XH3.Source File(s) (SRCFILE) :P.Name and library of source physical file or list of files (up to nine) that should be searched by the command. :NT.You can associate groups of files with a keyword in program JCRSMLTRD.:ENT.:EHELP. :HELP name='JCRFSET/IUO'.Usage - Help :XH3.Usage (IUO) :P.Select how the file is is used in the program :UL COMPACT.:LI.*ALL all types file usage will be returned :LI.I Input files :LI.O Output files :LI.U Update files :EUL.:EHELP. :HELP name='JCRFSET/LISTLEVEL'.List occurrences in each mbr - Help :XH3.List occurrences in each mbr (LISTLEVEL) :P.Stop search at first file or scan for all uses of dependent files in the program. :PARML.:PT.:PK def.*FIRST:EPK. :PD.Only first occurrence of the found string is listed. Useful for getting list of programs that contain one of the search strings. :PT.*ALL :PD.Every occurrence of search string in source member is listed. There will be same number of programs as with the *FIRST option, but same program might be listed multiple times depending on how many times search string is found in the source.:EPARML.:EHELP. :HELP name='JCRFSET/LFSAMELIB'.Only LFs in samelib as PF - Help :XH3.Only LFs in samelib as PF (LFSAMELIB) :P.The value is useful on a test system where a LF could exist in multiple libraries. :PARML.:PT.:PK def.*YES:EPK.:PD.Only scan for LFs in the same library as the PF. :PT.*NO :PD.Scan for all LFs (note you could get multiple hits for same named logical) :EPARML.:EHELP. :HELP name='JCRFSET/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.Output to print file or data file. :PARML.:PT.:PK def.*PRINT:EPK.:PD.Generate report listing. :PT.*OUTFILE :PD.Output is redirected to selected data file. (see OUTFILE help). :PT.* :PD.Report listing is shown interactively. Could tie up your interactive session for long periods of time if scanning large number of members.:EPARML.:EHELP. :HELP name='JCRFSET/OUTFILE'.File to receive output - Help :XH3.File to receive output (OUTFILE) :P.Name and library of database file to which output of command is directed. If file does not exist, this command creates database file in specified library. :P.:NT.If new file is created, text describing that file is "Outfile for JCRFSET utility". The database format (JCRFSETFR) of output file is same as that used in supplied file database JCRFSETF.:ENT. :P.JCRFSETF cannot be specified as outfile to receive output. :P.The possible library values are: :P.:PARML.:PT.:PK def.*LIBL:EPK.:PD.All libraries in job library list are searched until first match is found. :PT.*CURLIB :PD.The current library for job is used to locate file. If no library is specified as current library for job, QGPL is used. :PT.library-name :PD.Specify library where file is located.:EPARML.:EHELP. :HELP name='JCRFSET/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.Database file member that receives output from the command.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRFSETP - Scan File Set Where Used - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A INDARA A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRFSET' A 20'Scan File Set Where Used' A SCDOW 9A O 82 A 92DATE EDTWRD(' / / ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 1'File Set:' A SCOBJHEAD 63A O 11SPACEA(2) *----------------------------------------------------- A 20'Library' A 32'File' A 44'Member' A 56'Type' A R PRTHEAD2 SPACEA(1) A N10 1'Scan Source List:' A SRCLIB 10A O 20 A SRCFIL 10A O 32 A SRCMBR 10A O 44 A SRCMBRTYP 10A 56 *----------------------------------------------------- A R PRTHEAD4 SPACEA(1) A 1'Library' A 12'File' A 26'Member' A 40'Text' A 86'Seqno' A 95'Source Data' A 178'Chg Date' SPACEA(1) *--- A 1'----------' A 12'----------' A 26'----------' A 40'----------------------------------- A ------' A 86'-------' A 95'----------------------------------- A ------------------------------------ A -----------' A 178'--------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SRCLIB 10A O 1 A SRCFIL 10A O 12 A LISTMBR 10A O 26 A SRCTXT 40A 40 A SRCSEQ 6 2O 86EDTCDE(4) A SRCDTA80 80A O 95 A 20 SRCCHGDAT 6 0 178EDTWRD('0 / / ') A 192' ' ]]> v5r4 //--------------------------------------------------------- // JCRFSETR - Scan File Set Where Used // load data base relations for selected file in userspace1. // load selected member names into userspace2. // read source member and scan for all occurrences in userspace1. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FMBRSRC if f 112 disk extfile(extIfile) usropn F extmbr(OpenMbr) infds(Infds) FJCRFSETF o e disk extfile(extOfile) extmbr(ExtOMbr) F usropn FJCRFSETP o e printer oflind(IsOverFlow) indds(Ind) F usropn //--*STAND ALONE------------------------------------------- D BasedOnPfQual s 20a D extOMbr s 10a D OpenMbr s 10a D PhysicalFile s 10a D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(SrcListPtr) D ForCount3 s 5u 0 D PrintOffset s 3u 0 D IsClMbr s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define f_BlankCommentsCL /Define Ind /Define Infds /Define SrcDS /Define Qdbldbr /Define Qdbrtvfd /Define f_GetDayName /Define f_BuildString /Define Fild0100ds /Define Quslmbr /Define Tstbts /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_GetQual /Define f_Quscrtus /Define f_OvrPrtf /Define f_DltOvr /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D LdaDS ds DTAARA(*LDA) qualified D SrcFiles 398a D DataFileQual 20a D ActualLib 10a overlay(DataFileQual:11) D FileUsage 1a D Listlvl 6a D LfSameLib 4a D Output 8a D OutFileQual 20a D OutMbrOpt 22a // Get source file/lib/mbr names selected D InnerListDS ds based(InnerListPtr) D SrcFil 10a overlay(InnerListDS:3) D SrcLib 10a overlay(InnerListDS:*next) D SrcMbr 10a overlay(InnerListDS:*next) D SrcMbrTyp 10a overlay(InnerListDS:*next) //--*ENTRY PARMS *NONE* ----------------------------------- // LDA is used for long parms //--*INPUT SPECS------------------------------------------- IMBRSRC ns I a 1 112 SrcDS //--------------------------------------------------------- /free in LdaDS; //* Use pointers to overlay input parms with DS values. SrcListPtr = %addr(LdaDS.SrcFiles); evalr scDow = %trimr(f_GetDayName()); // open either print file or outfile depending. 1b if LdaDS.OutPut = '* '; LdaDS.OutPut = '*PRINT '; 1e endif; 1b if LdaDS.Output = '*PRINT '; f_OvrPrtf('JCRFSETP ': *OMIT: %subst(LdaDS.DataFileQual: 1: 10)); open JCRFSETP; 1x elseif LdaDS.Output = '*OUTFILE'; extOmbr = %subst(LdaDS.OutMbrOpt: 3: 10); extOfile = f_GetQual(LdaDS.OutFileQual); open JCRFSETF; clear imdrnb; clear immocc; clear imdrin; clear imculb; 1e endif; // Create user spaces/retrieve pointer to user spaces. GenericHeaderPtr = f_Quscrtus(UserSpaceName); GenericHeaderPtr2 = f_Quscrtus(UserSpaceName2); // if selected file is LF, the based-on-PF name is found // and processing continues as if PF had been selected. AllocateSize = f_GetAllocSize01(LdaDS.DataFileQual: '*FIRST '); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : LdaDS.DataFileQual : '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS); LdaDS.DataFileQual = ReturnFileQual; //actual file lib BasedOnPfQual = ReturnFileQual; //physical file 1b if tstbts(Fild0100ds.TypeBits: 2) = 1; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; BasedOnPfQual = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 1e endif; PhysicalFile = %subst(BasedOnPfQual: 1: 10); scanFile = LdaDS.DataFileQual; dealloc Fild0100ptr; //--------------------------------------------------------- 1b if LdaDS.Output = '*PRINT '; scObjHead = f_BuildString('& & &': %subst(ReturnFileQual: 1: 10): %subst(ReturnFileQual: 11: 10): Fild0100ds.FileText); write PrtHead; // print one line per selected source file // Spin down number of offsets to list entries. // Inner list pointer (start of list + displacement pointer) moves DS through list DisplacePtr = SrcListPtr; 2b for ForCount3 = 1 to NumOfLists; DisplacePtr += 2; InnerListPtr = SrcListPtr + Displacement; write PrtHead2; Ind.HeadingSwitch = *on; 2e endfor; write PrtHead4; 1e endif; //--------------------------------------------------------- // call API to retrieve data base relation names. callp QDBLDBR( UserSpaceName2: 'DBRL0100': BasedOnPfQual: '*ALL ': '*ALL ': ApiErrDS); // load user space with list of mbr names for selected files DisplacePtr = SrcListPtr; 1b for ForCount3 = 1 to NumOfLists; DisplacePtr += 2; InnerListPtr = SrcListPtr + Displacement; extIfile = f_GetQual(SrcFil + SrcLib); callp QUSLMBR( UserSpaceName: 'MBRL0200': SrcFil + SrcLib: SrcMbr: '0': ApiErrDS); // Process members in user space QuslmbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 2b for ForCount = 1 to GenericHeader.ListEntryCount; // member type selection 3b if SrcMbrTyp = '*ALL ' or SrcMbrTyp = QuslmbrDS.MbrType; OpenMbr = QuslmbrDS.MbrName; open MBRSRC; 4b if %subst(QuslmbrDS.MbrType: 1: 2) = 'CL'; exsr srReadClpMbr; 4x elseif %subst(QuslmbrDS.MbrType: 1: 2) = 'RP' or %subst(QuslmbrDS.MbrType: 1: 2) = 'SQ'; exsr srReadRpgMbr; 4e endif; close MBRSRC; 3e endif; QuslmbrPtr += GenericHeader.ListEntrySize; 2e endfor; 1e endfor; // close either print file or outfile 1b if LdaDS.Output = '*PRINT '; close JCRFSETP; f_DltOvr('JCRFSETP '); 1x elseif LdaDS.Output = '*OUTFILE'; close JCRFSETF; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // read through member scanning for each data base relation. begsr srReadRpgMbr; IsClMbr = *off; read MBRSRC; 1b dow not %eof; // If 92 record length, blank out any garbage from 93 to 112 2b if InfdsRecLen = 92; %subst(SrcDS: 93) = *blanks; 2e endif; 2b if SrcDS.SpecType = 'd' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'i' or SrcDS.SpecType = 'I' or SrcDS.SpecType = 'c' or SrcDS.SpecType = 'C' or SrcDS.SpecType = 'o' or SrcDS.SpecType = 'O' or SrcDS.SpecType = 'p' or SrcDS.SpecType = 'P' or SrcDS.SlashComment = '/f' or SrcDS.SlashComment = '/F' or SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c'; LV leavesr; 2x elseif SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/'; 2x elseif SrcDS.SpecType = 'f' or SrcDS.SpecType = 'F'; SrcDS.fFileName = %xlate(lo: up: SrcDS.fFileName); // Rpg3 is 2 characters shorter than Rpg4. 3b if QuslmbrDS.MbrType = 'RPG ' or QuslmbrDS.MbrType = 'SQLRPG '; %subst(SrcDS.fFileName: 9: 2) = *blanks; 3e endif; // check and see if PF is used first, 3b if SrcDS.fFileName = PhysicalFile; sbasedon = PhysicalFile; 4b if LdaDS.FileUsage = 'X' or SrcDS.fUsage = LdaDS.FileUsage; exsr srPrintLine; 5b if LdaDS.ListLvl = '*FIRST'; LV leavesr; 5e endif; 4e endif; 3x else; // spin through DBRL user space // looking for file name matches QdbldbrPtr = GenericHeaderPtr2 + GenericHeader2.OffSetToList; 4b for ForCount2= 1 to GenericHeader2.ListEntryCount; 5b if (LdaDS.LfSameLib = '*YES' and LdaDS.ActualLib = QdbldbrDS.DependentLib) or LdaDS.LfSameLib = '*NO '; 6b if SrcDS.fFileName = QdbldbrDS.DependentLF; sbasedon = QdbldbrDS.DependentLF; 7b if LdaDS.FileUsage = 'X' or SrcDS.fUsage = LdaDS.FileUsage; exsr srPrintLine; 8b if LdaDS.ListLvl = '*FIRST'; LV leavesr; 8e endif; 7e endif; 6e endif; 5e endif; QdbldbrPtr += GenericHeader2.ListEntrySize; 4e endfor; 3e endif; 2e endif; read MBRSRC; 1e enddo; endsr; //--------------------------------------------------------- // read through QCLSRC scanning for each DBRL selected. scan for DCLF, if found blank out // all comments in that line of source. scan again for DCLF in case it was commented out, if // found, proceed with source search. begsr srReadClpMbr; IsClMbr = *on; read MBRSRC; 1b dow not %eof; // If 92 record length, blank out any garbage from 93 to 112 2b if InfdsRecLen = 92; %subst(SrcDS: 93) = *blanks; 2e endif; SrcDS.Src112 = %xlate(lo: up: SrcDS.Src112); 2b if %scan('DCLF':SrcDS.Src112) > 0; SrcDS.Src112 = f_BlankCommentsCL(SrcDS.Src112); cc = %scan('DCLF':SrcDS.Src112); 3b if cc > 0; //--------------------------------------------------------- // check and see if PF is used first //--------------------------------------------------------- // if you have short file name like MON for example, I need // to check for MON) or MON space. // This will not help if your file name is MSG // but it should clean up a lot of scans. 4b if %scan(%trimr(PhysicalFile) + ' ': SrcDS.Src112) > 0 or %scan(%trimr(PhysicalFile) + ')': SrcDS.Src112) > 0; sbasedon = PhysicalFile; exsr srPrintLine; LV leavesr; 4x else; // spin through DBRL user space looking for file name matches QdbldbrPtr = GenericHeaderPtr2 + GenericHeader2.OffSetToList; 5b if QdbldbrDS.DependentLF <> '*NONE '; 6b for ForCount2= 1 to GenericHeader2.ListEntryCount; 7b if %scan(%trimr(QdbldbrDS.DependentLF) + ' ': SrcDS.Src112) > 0 or %scan(%trimr(QdbldbrDS.DependentLF) + ')': SrcDS.Src112) > 0; sbasedon = QdbldbrDS.DependentLF; exsr srPrintLine; LV leavesr; 7e endif; QdbldbrPtr += GenericHeader2.ListEntrySize; 6e endfor; 5e endif; 4e endif; 3e endif; 2e endif; read MBRSRC; 1e enddo; endsr; //--------------------------------------------------------- // Print detail line. begsr srPrintLine; Ind.IsChangedDate = (SrcDS.SrcChgDat > 0); SrcChgDat = SrcDS.SrcChgDat; SrcSeq = SrcDS.SeqNum6; ListMbr = QuslmbrDS.MbrName; MbrType = QuslmbrDS.MbrType; SrcTxt = QuslmbrDS.Text; 1b if not IsClMbr; SrcUsage = %xlate(lo: up: SrcDS.fUsage); 1x else; SrcUsage = 'I'; 1e endif; 1b if LdaDS.Output = '*PRINT '; SrcDta80 = SrcDS.Src112; write PrtDetail; 1x else; SrcDta = SrcDS.Src112; write JCRFSETFR; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRFSETRS - Scan File Set Where Used - submitter // Save existing *LDA // Load long list variables to *LDA // SBMJOB // Reset *LDA to previous value. //--------------------------------------------------------- /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_SbmJob /Define f_Pgm /Define f_RtvMsgAPI /Define f_SndCompMsg /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D SavLda s like(LdaDS) //--*DATA STRUCTURES--------------------------------------- D LdaDS uds DTAARA(*LDA) qualified D SrcFiles 398a D DataFileQual 20a D FileUsage 1a D Listlvl 6a D LfSameLib 4a D Output 8a D OutFileQual 20a D OutMbrOpt 22a //--*CALL PROTOTYPES--------------------------------------- D p_JCRSMLTRD PR extpgm('JCRSMLTRD') predefined lists D p_JCRFSETR PR extpgm('JCRFSETR ') //--*ENTRY PARMS------------------------------------------- D p_JCRFSETRS PR extpgm('JCRFSETRS') D 20a D 398a D 1a file usage D 6a scan first or all D 4a LF in samelib as PF D 8a D 20a D 22a D p_JCRFSETRS PI D p_DtaFileQual 20a D p_SrcFiles 398a D P_FileUsage 1a D p_Listlvl 6a D p_LfSameLib 4a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free SavLda = LdaDs; LdaDs.srcFiles = p_SrcFiles; LdaDS.DataFileQual = p_DtaFileQual; LdaDS.Output = p_Output; LdaDS.OutFileQual = p_OutFileQual; LdaDS.OutMbrOpt = p_OutMbrOpt; LdaDS.FileUsage = p_FileUsage; LdaDS.Listlvl = p_Listlvl; LdaDS.LfSameLib = p_LfSameLib; out LdaDS; callp p_JCRSMLTRD(); // CHECK PREDEFINED LISTS 1b if p_Output = '* '; callp p_JCRFSETR(); // interactive show spooled file f_DspLastSplf('JCRFSETR ': p_Output); 1x else; f_SbmJob(f_Pgm('JCRFSETR ': '*LIBL '): 'QBATCH '); f_SndCompMsg(f_RtvMsgApi('CPC1221': ApiErrDS.MsgReplaceVal)); 1e endif; // replace overlaid LDA LdaDs = SavLda; out LdaDS; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRFSETRV - Validity checking program // If File already exists, do open to verify no level checks and record format is same. //--------------------------------------------------------- /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_OutFileCrtDupObj /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D ForCount s like(NumOfLists) D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(p_SrcListPtr) //--*DATA STRUCTURES--------------------------------------- // Get number of source files selected and source File/Lib/Mbr names D MixedListDS ds based(MixedListDSPtr) qualified D SrcFile 10a overlay(MixedListDS:3) D SrcLib 10a overlay(MixedListDS:*next) D SrcMbr 10a overlay(MixedListDS:*next) D SrcMbrTyp 10a overlay(MixedListDS:*next) //--*ENTRY PARMS------------------------------------------- D p_JCRFSETRV PR extpgm('JCRFSETRV') D 20a data file and lib D 398a source list D 1a file usage D 6a scan first or all D 4a Lf in samelib as PF D 8a *print or *outfile D 20a output file and lib D 22a member options D p_JCRFSETRV PI D p_DtaFileQual 20a D p_SrcList 398a D P_FileUsage 1a D p_Listlvl 6a D p_LfSameLib 4a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free f_CheckObj(p_DtaFileQual : '*FILE '); p_SrcListPtr = %addr(p_SrcList); DisplacePtr = p_SrcListPtr; 1b for ForCount = 1 to NumOfLists; DisplacePtr += 2; MixedListDSPtr = p_SrcListPtr + Displacement; 2b if %subst(MixedListDs.SrcFile: 1: 1) <> '*'; f_CheckMbr(MixedListDs.SrcFile + MixedListDs.SrcLib : '*FIRST '); 2e endif; 1e endfor; 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRFSETF '); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRF7 - seu exit program - split/combine lines. // To activate on your system. // 1. strpdm and edit source member. // 2. Press F13 to Change Session Defaults. // 3. Page down then change // User exit program JCRF7______ *REGFAC, *NONE, Name // Library. . . JCRCMDS___ Name // where JCRF7=your program name and JCRCMDS=your library name //--------------------------------------------------------- // Program Summary: // If cursor is on line with data past cursor position, // press F7 to split line into two lines. // If cursor is on line with no data past cursor position, // press F7 to combine current and next line. // note: combining will not delete second line. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D SrcLine1 s 100a D SrcLine2 s 100a D xx s 3u 0 //--*DATA STRUCTURES--------------------------------------- D HeadInfo ds based(PtrHeadx) D HeadRecordLen 10i 0 overlay(HeadInfo:1) D HeadCursorPos 10i 0 overlay(HeadInfo:9) D HeadF7Key 1a overlay(HeadInfo:61) D ReturnInfo ds based(PtrRetnx) D ReturnCode 1a overlay(ReturnInfo:1) D ReturnRec 10i 0 overlay(ReturnInfo:5) D SrcLines ds based(PtrLinex) D SrcLine1_100 100a overlay(SrcLines:21) D SrcLine2_100 100a overlay(SrcLines:141) D SrcLine1_80 80a overlay(SrcLines:21) D SrcLine2_80 80a overlay(SrcLines:121) //--*ENTRY PARMS------------------------------------------- D p_JCRF7 PR extpgm('JCRF7') D * Headings Pointer D * Return Code Pointer D * Line Info Pointer D p_JCRF7 PI D p_PtrHead * D p_PtrRetn * D p_PtrLine * //--------------------------------------------------------- /free PtrHeadx = p_PtrHead; PtrRetnx = p_PtrRetn; PtrLinex = p_PtrLine; // F7 was pressed and good cursor position 1b if HeadF7Key = '7' and HeadCursorPos > *zero; 2b if HeadRecordLen = 80; SrcLine1 = SrcLine1_80; SrcLine2 = SrcLine2_80; 2x else; SrcLine1 = SrcLine1_100; SrcLine2 = SrcLine2_100; 2e endif; 2b if %subst(SrcLine1: HeadCursorPos) > *blanks; exsr srSplitLine; 2x else; exsr srMergeLine; 2e endif; 2b if HeadRecordLen = 80; SrcLine1_80 = SrcLine1; SrcLine2_80 = SrcLine2; 2x else; SrcLine1_100 = SrcLine1; SrcLine2_100 = SrcLine2; 2e endif; ReturnCode = *off; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // SPLIT LINE // if position 6 is equal blanks, assume I am in /free zone and align // split line up with 1st character after 6. // if position 6 > *blanks, drop straight down to next line. begsr srSplitLine; 1b if %subst(SrcLine1: 6: 1) = *blanks; //assume free //find 1st character on top statement to //line up split code xx = %check(' ': SrcLine1: 7); 2b if xx = 0; xx = 8; 2e endif; 1x else; //not free xx = HeadCursorPos; 1e endif; clear SrcLine2; %subst(SrcLine2: xx) = %subst(SrcLine1: HeadCursorPos); 1b if HeadCursorPos = 1; SrcLine1 = *blanks; 1x else; SrcLine1 = %subst(SrcLine1: 1: HeadCursorPos - 1); 1e endif; ReturnRec = 2; endsr; //--------------------------------------------------------- // Merge line at cursor begsr srMergeLine; %subst(SrcLine1: HeadCursorPos) = %triml(SrcLine2); 1b if HeadCursorPos = 1; SrcLine2 = *blanks; 1x else; SrcLine2 = %subst(SrcLine2: %len(SrcLine2) - (HeadCursorPos - 2)); 1e endif; ReturnRec = 1; 1b if SrcLine2 > *blanks; ReturnRec = 2; 1e endif; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRGAMES - Games selection menu - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('JCR Games Selection Menu') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRGAMESC - Games selection menu - CMDPGM */ /*--------------------------------------------------------------------------*/ PGM DCLF FILE(JCRGAMESD) MONMSG MSGID(CPF0000) CHGVAR VAR(&SCLIN) VALUE(02) CHGVAR VAR(&SCPOS) VALUE(04) CALL PGM(JCRDAYNAMR) PARM(&SCDOW) DOUNTIL COND('0') SNDRCVF RCDFMT(SCREEN) WAIT(*YES) SELECT WHEN COND((&IN03) *OR (&IN12)) THEN(DO) RETURN SNDRCVF RCDFMT(ASSUME) ENDDO WHEN COND(&SCOPTION = '1') THEN(CALL PGM(JCRGMBLJ)) WHEN COND(&SCOPTION = '2') THEN(CALL PGM(JCRGMBTL)) WHEN COND(&SCOPTION = '3') THEN(CALL PGM(JCRGMCRB)) WHEN COND(&SCOPTION = '4') THEN(CALL PGM(JCRGMPOK)) WHEN COND(&SCOPTION = '5') THEN(CALL PGM(JCRGMPYR)) WHEN COND(&SCOPTION = '6') THEN(CALL PGM(JCRGMRCB)) WHEN COND(&SCOPTION = '7') THEN(CALL PGM(JCRGMTIC)) WHEN COND(&SCOPTION = '8') THEN(CALL PGM(JCRGMYAT)) WHEN COND(&SCOPTION = '9') THEN(CALL PGM(JCRGMMINE)) OTHERWISE ENDSELECT ENDDO ENDPGM ]]> v5r4 *---------------------------------------------------------------- * JCRGAMESD- JCR games selection menu - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT CA03(03) CA12(12) A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN OVERLAY A *DS3 WINDOW(&SCLIN &SCPOS 13 31) A *DS4 WINDOW(&SCLIN &SCPOS 14 31) A SCLIN 2S 0P A SCPOS 2S 0P A 1 2'JCRGAMES' A COLOR(BLU) A SCDOW 9A O 1 14COLOR(BLU) A 1 24DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 24SYSNAME A COLOR(BLU) A 3 2'1. Black Jack 21' A 4 2'2. Battle Ship' A 5 2'3. Cribbage' A 6 2'4. Draw Poker' A 7 2'5. Pyramid Solitaire' A 8 2'6. RubiksCube' A 9 2'7. Tic / Tac / Toe' A 10 2'8. Yahtzee' A 11 2'9. Erdos Tibor MineSweeper' A SCOPTION 1A B 12 2 A 12 5'Option' A 12 25'F3=Exit' COLOR(BLU) *---------------------------------------------------------------- A R ASSUME ASSUME A 1 2' ' DSPATR(ND) ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRGENPR - Generate callp prototype - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate Call Prototype') PARM KWD(INSERTINTO) TYPE(*NAME) LEN(10) MIN(1) + KEYPARM(*YES) PROMPT('Insert Prototype + into SrcMbr:') PARM KWD(INSERTSRCF) TYPE(SRCFILE) KEYPARM(*YES) + PROMPT('Insert Source File:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(TOCALLPGM) TYPE(PGM) MIN(1) + KEYPARM(*YES) PROMPT('Create Prototype to + call Obj:') PGM: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(SRCFIL) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source File:') PARM KWD(SRCLIB) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source Lib:') PARM KWD(SRCMBR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Source Mbr:') PARM KWD(PGMATR) TYPE(*CHAR) LEN(10) KEYPARM(*NO) PROMPT('Program Attribute:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRGENPR'.Generate Call Prototype (JCRGENPR) - Help .*-------------------------------------------------------------------- :P.This JCR command generates RPG4 call prototype definitions in selected source. :P.After execution, call prototype code will be at bottom of your source. You will need to move source to proper place in your code. :P.Conditions::UL COMPACT. :LI.Called program source code must be available for compile into QTEMP.:EUL. :P.The command uses a prompt override program (pop) to retrieve where source code was that compiled your program. :NT.Be aware that if field is only defined in DSPF the attributes could possibly be returned as signed when it really is packed.:ENT. :NT.You must prompt JCRGENPR command for POP to work properly.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRGENPR/INSERTINTO'.Insert Prototype into SrcMbr (INSERTINTO) - Help :XH3.Insert Prototype into SrcMbr (INSERTINTO) :P.Member name to be updated with prototype source code.:EHELP. :HELP name='JCRGENPR/INSERTSRCF'.Source file - Help :XH3.Source file (INSERTSRCF) :P.Source file containing RPG source member to be updated.:EHELP. :HELP name='JCRGENPR/TOCALLPGM'.Create Prototype to call Obj - Help :XH3.Create Prototype to call Obj (TOCALLPGM) :P.Program and library to be call prototyped.:EHELP. :HELP name='JCRGENPR/SRCFIL'.Source file - Help :XH3.Source file (SRCFIL) :P.Source file containing source.:EHELP. :HELP name='JCRGENPR/SRCLIB'.Source Library - Help :XH3.Source library (SRCLIB) :P.Library where source file is located.:EHELP. :HELP name='JCRGENPR/SRCMBR'.Source Member - Help :XH3.Source Member (SRCMBR) :P.Source member.:EHELP. :HELP name='JCRGENPR/PGMATR'.Program attribute - Help :XH3.Program Attribute (PGMATR) :P.Type of program object.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRGENPRO - prompt override program // Use object parm to call APIs Qclrpgmi-Retrieve Pgm Info or Qbnlpgmi-List ILE Pgm Info // to retrieve where Src file was located when program was compiled. Original Source // File, Lib and Mbr are returned to command. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define Qbnlpgmi /Define Qclrpgmi /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D QclrpgmiDS ds 528 qualified D SrcAttrb 10a overlay(QclrpgmiDS:39) D SrcFile 10a overlay(QclrpgmiDS:62) D SrcLib 10a overlay(QclrpgmiDS:72) D SrcMbr 10a overlay(QclrpgmiDS:82) D QbnlpgmiDS ds qualified based(QbnlpgmiPTR) D SrcFile 10a overlay(QbnlpgmiDS:41) D SrcLib 10a overlay(QbnlpgmiDS:51) D SrcMbr 10a overlay(QbnlpgmiDS:61) D SrcAttrb 10a overlay(QbnlpgmiDS:71) D AlphaBin ds qualified D ShortBin 1 2b 0 inz(5700) //--*ENTRY PARMS------------------------------------------- D p_JCRGENPRO PR extpgm('JCRGENPRO') D 20a Command Name and Lib D 10a D 20a D 20a Program Name and Lib D 5700a Return String D p_JCRGENPRO PI D p_CmdQual 20a D a 10a D b 20a D p_PgmQual 20a D p_RtnString 5700a //--------------------------------------------------------- /free // call retrieve program information API to get attribute callp QCLRPGMI( QclrpgmiDS: 528: 'PGMI0100': p_PgmQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; QclrpgmiDS.SrcFile = 'OBJECTxxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; 1x else; // If ILE, create / get pointer ILE user space 2b if QclrpgmiDS.SrcAttrb = 'RPGLE ' or QclrpgmiDS.SrcAttrb = 'SQLRPGLE ' or QclrpgmiDS.SrcAttrb = 'CLLE '; GenericHeaderPtr2 = f_Quscrtus(UserSpaceName2); // if ILE, call API to get Src callp QBNLPGMI( UserSpaceName2: 'PGML0100': p_PgmQual: ApiErrDS); 3b if ApiErrDS.BytesReturned > 0; //Src not available QclrpgmiDS.SrcFile = 'SOURCExxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; 3x else; QbnlpgmiPTR = GenericHeaderPtr2 + GenericHeader2.OffsetToList; QclrpgmiDS.SrcFile = QbnlpgmiDS.SrcFile; QclrpgmiDS.SrcLib = QbnlpgmiDS.SrcLib; QclrpgmiDS.SrcMbr = QbnlpgmiDS.SrcMbr; QclrpgmiDS.SrcAttrb = QbnlpgmiDS.SrcAttrb; 3e endif; 2e endif; 1e endif; // build prompt string to return to command p_RtnString = AlphaBin + '??SRCFIL(' + %trimr(QclrpgmiDS.SrcFile) + ')' + ' ??SRCLIB(' + %trimr(QclrpgmiDS.SrcLib) + ')' + ' ??SRCMBR(' + %trimr(QclrpgmiDS.SrcMbr) + ')' + ' ??PGMATR(' + %trimr(QclrpgmiDS.SrcAttrb) + ')'; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRGENPRR - generate callp prototypes // Call programs to read compile listings and generate prototype. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGETFLDFif f 132 disk extfile('QTEMP/JCRGETFLDF') usropn FPROTOSRC o f 112 disk extfile(extOsrc) F extmbr(p_InsertInMbr) usropn //--*STAND ALONE------------------------------------------- D CallMbrTxt s 50a D extOsrc s 21a D Seqnum s 6s 2 D SrcOut s 97a D WorkField s 11a D dFieldNameSav s like(SrcDS.dFieldName) D ExtendedName s like(SrcDS.Src57) D Alpha6 s 6a D Decimals s 2a D ExtractTypeFlg s 6a D FieldAttribute s 1a D Length s 10a D ParmName s 14a D IsAllDone s n D IsExtractParm s n D IsProcIntFace s n //--*DATA STRUCTURES--------------------------------------- D SrcDS DS qualified inz D dFieldName 9 23a D Src57 9 65a D Asterisk 9 9a D SpecType 8 8a D EndOfSource 20 44a D ProtoProcedur 25 28a D SourceListing 27 53a D OpCode 28 37a D dProtoProcedur 25 28a D ResultField 52 65a D dKeyWord 46 82a D Factor1 14 27a //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define f_GetQual /Define f_Qusrmbrd /Define f_SndCompMsg /Define f_SndEscapeMsg /Define FieldsArry /Define FieldsAttrDS /Define p_JCRGETCLPR /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRGENPRR PR extpgm('JCRGENPRR ') D 10a D 20a D 20a D 10a D 10a D 10a D 10a D p_JCRGENPRR PI D p_InsertInMbr 10a D p_InsertFileQual... D 20a D p_PgmQual 20a D p_SrcFil 10a D p_SrcLib 10a D p_SrcMbr 10a D p_Pgmatr 10a //--*INPUT SPECS------------------------------------------- IJCRGETFLDFns I a 1 132 SrcDS //--------------------------------------------------------- /free extOsrc = f_GetQual(p_InsertFileQual); open PROTOSRC; QusrmbrdDS = f_Qusrmbrd(p_SrcFil + p_SrcLib: p_SrcMbr: 'MBRD0100'); CallMbrTxt = QusrmbrdDS.Text; SrcOut = ' //-----' + %trim(CallMbrTxt) + ' ------'; Seqnum += 10; except WriteCode; SrcOut = ' D p_' + p_SrcMbr + ' PR ' + 'extpgm(' + qs + %trimr(p_SrcMbr) + qs + ')'; Seqnum += 10; except WriteCode; 1b if %subst(p_PgmAtr: 1: 2) = 'CL'; exsr srCL; 1x elseif p_PgmAtr = 'RPGLE ' or p_PgmAtr = 'SQLRPGLE '; exsr srRPG; 1e endif; close PROTOSRC; f_SndCompMsg('JCRGENPR Protoype for ' + %trimr(p_SrcMbr) + ' in member ' + %trimr(p_InsertInMbr) + ' - completed.'); *inlr = *on; return; //--------------------------------------------------------- // Generate callp prototype from CL. // Called program returns CL entry parms and field attributes //--------------------------------------------------------- // Get field attributes from JCRGETFLDR. // Read RPG source code. // Find *ENTRY factor 1 or Main procedure. // Extract parm field names and get attributes from loaded arrays. // Generate Rpgle prototype source code in outfile. begsr srRPG; // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity); 1b if DiagSeverity > '20'; // p_DiagSeverity = DiagSeverity; // *inlr = *on; // return; 1e endif; //--------------------------------------------------------- // Read compile listing generated by called program. open JCRGETFLDF; 1b dou SrcDS.SourceListing = 'S o u r c e L i s t i n g'; read JCRGETFLDF; 1e enddo; read JCRGETFLDF; 1b dow not %eof; 2b if not(SrcDS.Asterisk = '/' // or SrcDS.Asterisk = '+' or SrcDS.Asterisk = '*'); SrcDS = %xlate(lo: up: SrcDS); //--------------------------------------------------------- // Check for conditions that indicate all parms are processed. IsAllDone = *off; // compile time array or 1st Ospec will exit program. 3b if SrcDS.EndOfSource = 'E N D O F S O U R C E' or SrcDS.SpecType = 'O'; IsAllDone = *on; 3e endif; 3b if ExtractTypeFlg = 'MAIN ' and (SrcDS.SpecType = 'C' or SrcDS.SpecType = 'I' or (SrcDS.SpecType = 'D ' and SrcDS.dProtoProcedur <> *blanks)); IsAllDone = *on; 3e endif; 3b if ExtractTypeFlg = '*ENTRY' and ((SrcDS.SpecType = 'C' and SrcDS.OpCode <> 'PARM ') or SrcDS.SpecType = 'O '); IsAllDone = *on; 3e endif; 3b if IsAllDone; 1v leave; 3e endif; //--------------------------------------------------------- 3b if not IsExtractParm; exsr srDeterminePEP; 3x else; exsr srDoParmFields; 3e endif; 2e endif; read JCRGETFLDF; 1e enddo; close JCRGETFLDF; endsr; //--------------------------------------------------------- // Process parms begsr srDoParmFields; 1b if ExtractTypeFlg = 'MAIN ' and SrcDS.SpecType = 'D'; aa = %scan(' ': %triml(SrcDS.Src57): 1); SrcDS.ResultField = %subst(%triml(SrcDS.Src57): 1: aa - 1); SrcDS.OpCode = 'PARM '; 1e endif; 1b if SrcDS.OpCode = 'PARM '; aa = %lookup(SrcDS.ResultField : FieldsNameArry: 1: FieldsArry_NumberOfEntries); 2b if aa > 0; FieldsAttrDS = FieldsAttrArry(aa); 2e endif; //--------------------------------------------------------- // Generate KEYWORD text. Length = *blanks; Decimals = *blanks; ParmName = SrcDS.ResultField; 2b if FieldsAttrDS.DataType = 'L' or FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z' or FieldsAttrDS.DataType = 'N' or FieldsAttrDS.DataType = '*'; FieldAttribute = FieldsAttrDS.DataType; 2x else; Decimals = FieldsAttrDS.DecimalPos; evalr Length = ' ' + %char(FieldsAttrDS.Length); FieldAttribute = %xlate(up: lo: FieldsAttrDS.DataType); 2e endif; SrcOut = ' D'; %subst(SrcOut: 27) = Length; %subst(SrcOut: 37) = FieldAttribute; %subst(SrcOut: 38) = Decimals; %subst(SrcOut: 78) = ParmName; Seqnum += 10; except WriteCode; 1e endif; endsr; //--------------------------------------------------------- // Determine PEP or Procedure Entry Point. // 1. Check for *ENTRY or // 2. Prototype with same EXTPGM name as program // 3. Prototype with same name as program. begsr srDeterminePEP; // search for prototype definition with same name as source member. 1b if SrcDS.SpecType = 'D'; IsProcIntFace = *off; aa = %scan('...': SrcDS.Src57); 2b if aa > 0; %subst(SrcDS.Src57: aa + 3) = *blanks; ExtendedName = %triml(SrcDS.Src57); // see if same as program name aa = %scan('...': Extendedname); 3b if aa > 0 and %triml(%subst(ExtendedName: 1: aa - 1)) = p_SrcMbr; IsProcIntFace = *on; 3e endif; read JCRGETFLDF; SrcDS = %xlate(lo: up: SrcDS); 2x else; 3b if %triml(SrcDS.dFieldName) = p_SrcMbr; IsProcIntFace = *on; dFieldNameSav = %triml(SrcDS.dFieldName); 3e endif; 2e endif; Alpha6 = %triml(SrcDS.dKeyword); 2b if Alpha6 = 'EXTPGM'; aa = %scan(qs: SrcDS.dKeyword); bb = %scan(qs: SrcDS.dKeyword: aa + 1); 3b if p_SrcMbr = %subst(SrcDS.dKeyword: aa + 1: bb - (aa + 1)); IsProcIntFace = *on; dFieldNameSav = %triml(SrcDS.dFieldName); 3e endif; 2e endif; 2b if IsProcIntFace; // read through source until find // PI procedure interface with same name as Prototype read JCRGETFLDF; 3b dow not %eof; SrcDS = %xlate(lo: up: SrcDS); aa = %scan('...': SrcDS.Src57); //drop trailing ... 4b if aa > 0; %subst(SrcDS.Src57: aa + 3) = *blanks; 4e endif; 4b if %triml(SrcDS.dFieldName) = dFieldNameSav or ExtendedName = %triml(SrcDS.Src57); 5b if SrcDS.dProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 5x else; read JCRGETFLDF; SrcDS = %xlate(lo: up: SrcDS); 6b if SrcDS.dProtoProcedur = ' PI '; IsExtractParm = *on; ExtractTypeFlg = 'MAIN '; LV leavesr; 6e endif; 5e endif; 4e endif; read JCRGETFLDF; 3e enddo; 2e endif; 1x elseif SrcDS.SpecType = 'C' and SrcDS.Factor1 = '*ENTRY '; IsExtractParm = *on; ExtractTypeFlg = '*ENTRY'; 1e endif; endsr; //--------------------------------------------------------- // Generate callp prototype from CL. // Called program returns CL entry parms and field attributes //--------------------------------------------------------- begsr srCL; callp p_JCRGETCLPR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity); 1b if DiagSeverity > '20'; *inlr = *on; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; //--------------------------------------------------------- // Unload imported array into RPGLE prototype code 1b for aa = 1 to FieldsArry_NumberOfEntries; Seqnum += 10; SrcOut = ' D'; FieldsAttrDS = FieldsAttrArry(aa); %subst(SrcOut: 36) = %char(FieldsAttrDS.Length); 2b if FieldsAttrDS.DataType = 'C'; %subst(SrcOut: 37) = 'a'; 2x elseif FieldsAttrDS.DataType = 'D'; %subst(SrcOut: 37) = 'p'; 2x elseif FieldsAttrDS.DataType = 'L'; %subst(SrcOut: 37) = 'n'; 2x else; %subst(SrcOut: 37) = FieldsAttrDS.DataType; 2e endif; %subst(SrcOut: 38) = FieldsAttrDS.DecimalPos; %subst(SrcOut: 78) = %subst(FieldsNameArry(aa) : 2: 10); except WriteCode; 1e endfor; endsr; /end-free Oprotosrc e WriteCode O Seqnum 6 O SrcOut 112 ]]> v5r4 //--------------------------------------------------------- // JCRGENPRV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_IsValidMbr /Define f_OutFileAddPfm /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRGENPRV PR extpgm('JCRGENPRV ') D 10a D 20a D 20a D 10a D 10a D 10a D 10a D p_JCRGENPRV PI D p_InsertInMbr 10a D p_InsertFileQual... D 20a D p_PgmQual 20a D p_SrcFil 10a D p_SrcLib 10a D p_SrcMbr 10a D p_Pgmatr 10a //--------------------------------------------------------- /free f_CheckObj(p_PgmQual : '*PGM '); f_CheckObj(p_InsertFileQual : '*FILE '); f_CheckMbr(p_SrcFil + p_SrcLib: p_SrcMbr ); 1b if Not f_IsValidMbr( %subst(p_InsertFileQual: 1: 10): %subst(p_InsertFileQual: 11: 10): p_InsertInMbr); f_OutFileAddPfm(p_InsertFileQual: p_InsertInMbr: 'RPGLE ': 'X': p_SrcFil + p_SrcLib: p_SrcMbr); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRGETCLPR - load EXPORT array with field name and attributes // Generate diagnostic source listing // Read spooled file // Load JCRCMDSSRV clipboard array with field names and attributes //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGETCLPFif f 132 disk usropn //--*STAND ALONE------------------------------------------- D xx s 10u 0 D ii s 10u 0 D CountClParms s 10u 0 D ArryOfClParms s 11a dim(500) D aaa s 200a D IsLookForSeverity... D s n D IsFoundVar s n D IsPGM s n D DiagSeverity s 2a //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define FieldsAttrDS /Define f_IsValidMbr /Define Constants /Define f_GetQual /Define f_System /Define f_Qusrmbrd /Define f_BlankCommentsCL /Define p_JCRGETCLPR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRGETCLPR PI D p_SrcFilQual 20a const D p_SrcMbr 10a D p_DiagSeverity 2a //--*INPUT SPECS------------------------------------------- IJCRGETCLPFaa I a 2 2 iAmp I a 2 12 iFieldName I a 2 19 iDeclaredVar I a 10 109 iSourceCode I a 34 76 iEndOfXref I a 39 61 iStartOfSource I a 43 43 iDataType I a 44 68 iEndOfSource I a 58 62 iFieldLength I a 64 64 iFieldDecimals /free //--------------------------------------------------------- // generate diagnostic listing and copy to data file p_DiagSeverity = '00'; FieldsArry_NumberOfEntries = 0; 1b if f_IsValidMbr('JCRGETCLPF': 'QTEMP '); f_system('CLRPFM QTEMP/JCRGETCLPF'); 1x else; f_System('CRTPF FILE(QTEMP/JCRGETCLPF) RCDLEN(132)'); 1e endif; f_system('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)'); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); 1b if QusrmbrdDS.MbrType = 'CLP '; f_system('CRTCLPGM PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*SOURCE *XREF *NOGEN)'); 1x else; f_system('CRTBNDCL PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*XREF) OUTPUT(*PRINT)'); f_system('DLTPGM PGM(QTEMP/' + p_SrcMbr + ')'); 1e endif; f_system('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETCLPF) SPLNBR(*LAST)'); f_system('DLTOVR FILE(' + p_SrcMbr + ')'); //--------------------------------------------------------- // read listing aa = 0; cc = 0; CountClParms = 0; open JCRGETCLPF; read JCRGETCLPF; 1b dow not %eof; %subst(iSourceCode:95) = *blanks; iSourceCode = f_BlankCommentsCL(iSourceCode); iSourceCode = %xlate(lo: up: iSourceCode); // get to the PGM command 2b if not IsPgm and (%subst(iSourceCode: 1: 4) = 'PGM ' or %scan(' PGM ': iSourceCode) > 0); IsPgm = *on; 2e endif; // Now extract anything with a & in front up to a space or ) 2b if IsPgm; 3b if %scan(' DCL ': iSourceCode) > 0 or %scan(' DCLF ': iSourceCode) > 0 or %subst(iSourceCode: 1: 4) = 'DCL ' or %subst(iSourceCode: 1: 4) = 'DCLF ' or iEndOfSource = 'E N D O F S O U R C E'; 1v leave; 3e endif; IsFoundVar = *off; 3b for aa = 1 to %len(iSourceCode); 4b if %subst(iSourceCode:aa:1) = '&'; IsFoundVar = *on; CountClParms += 1; cc = 0; 4e endif; 4b if IsFoundVar; 5b if %subst(iSourceCode:aa:1) = ' ' or %subst(iSourceCode:aa:1) = ')'; IsFoundVar = *off; 5x else; cc += 1; %subst(ArryOfClParms(CountClParms) :cc :1) = %subst(iSourceCode: aa: 1); 5e endif; 4e endif; 3e endfor; 2e endif; read JCRGETCLPF; 1e enddo; 1b if CountClParms = 0; *inlr = *on; return; 1e endif; 1b dou iDeclaredVar = 'Declared Variables'; read JCRGETCLPF; 1e enddo; 1b dou iEndOfXref = 'E N D O F C R O S S R E F E R E N C E'; read JCRGETCLPF; 2b if iAmp = '&'; // only extract parm fields xx = %lookup(iFieldName : ArryOfClParms: 1: CountClParms); 3b if xx > 0; FieldsArry_NumberOfEntries += 1; FieldsNameArry(xx) = iFieldName; clear FieldsAttrDS; FieldsAttrDS.DataType = iDataType; FieldsAttrDS.Length = %uns(iFieldLength); evalr FieldsAttrDS.DecimalPos = ' ' + iFieldDecimals; FieldsAttrArry(xx) = FieldsAttrDS; 3e endif; 2e endif; 1e enddo; close JCRGETCLPF; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRGETFLDR - load EXPORT array with field name and attributes // Generate diagnostic source listing // Read spooled file // Load JCRCMDSSRV clipboard array with field names and attributes //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGETFLDFif f 132 disk usropn //--*STAND ALONE------------------------------------------- D aa s 10u 0 D readcount s 10u 0 D xx s 10u 0 D ii s 10u 0 D xOpen s 3u 0 D xComma s 3u 0 D xAster s 3u 0 D xClose s 3u 0 D FileNameArry s 10a dim(12767) D FileFldsArry s 15a dim(12767) D FileFldTxtArry s dim(12767) like(iFieldText) D SqlSeverity s 2a D FileName s 10a D FileSeq s 3a D IsGlobalRef s n inz(*off) D SavName s 100a D SavProcName s 100a D SavQualified s 100a D SavDim s 15a D IsUnReferenced s n D IsQualified s n D IsLookForSeverity... D s n D IsServicePgm s n D char8 s 8a //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define FieldsAttrDS /Define f_IsValidMbr /Define f_GetQual /Define f_System /Define f_Qusrmbrd /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRGETFLDR PI D p_SrcFilQual 20a const D p_SrcMbr 10a D p_DiagSeverity 2a //--*INPUT SPECS------------------------------------------- IJCRGETFLDFaa I a 1 1 iNotReferenced I a 1 2 iSqlSeverity I a 1 6 iFileFldSeq I a 1 38 iCheckComplete I a 2 8 iMsgSummary I a 4 12 iSQLlevel I a 7 7 iEqual I a 7 30 iGlobalRef I a 8 8 iFileType I a 9 38 iExternalForma I a 10 11 iQualified I a 10 19 iDFieldName E DS field I a 10 26 iFldShort I a 10 132 iFldLong I a 32 41 iOFieldName Output File Field I a 28 45 iGlobDefn I a 28 28 iGlobAttr1 P, A, S, U, etc. I a 27 29 iGlobAttr3 DS I a 29 45 iGlobLen (3,0) I a 41 132 iFSname File or subproc name I a 50 80 iReference I a 51 65 iIFieldName Input File Field I a 61 62 iDiagSeverity I a 83 121 iFieldText I a 120 123 iPage I a 122 124 iFileSeq /free //--------------------------------------------------------- // generate diagnostic listing and copy to data file p_DiagSeverity = '00'; 1b if f_IsValidMbr('JCRGETFLDF': 'QTEMP '); f_system('CLRPFM QTEMP/JCRGETFLDF'); 1x else; f_System('CRTPF FILE(QTEMP/JCRGETFLDF) RCDLEN(132) SIZE(*NOMAX)'); 1e endif; f_system('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)'); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); //--------------------------------------------------------- // Thanks again IBM. SQLRPGLE CRTSQLRPGI does not generated an unreferenced // listing. But I need to get the severity of the SQL compile. // If SQL, I will do a diag of SQL, then do a CRTBNDRPG to get the unreferenced listing. //--------------------------------------------------------- 1b if QusrmbrdDS.MbrType = 'SQLRPGLE'; f_system('CRTSQLRPGI OBJ(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*NOXREF *NOGEN) OUTPUT(*PRINT)' + ' COMPILEOPT('+'''DFTACTGRP(*NO)'''+')'); f_system('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); open JCRGETFLDF; setgt *hival JCRGETFLDF; readp JCRGETFLDF; 2b dow not %eof; 3b if iSQLlevel = 'level sev'; SqlSeverity = iSqlSeverity ; 2v leave; 3e endif; 3b if iCheckComplete = 'No errors found in source '; f_system('DLTSPLF FILE(' + p_SrcMbr + ') SPLNBR(*LAST)'); SqlSeverity = '00'; 2v leave; 3e endif; readp JCRGETFLDF; 2e enddo; close JCRGETFLDF; 1e endif; //--------------------------------------------------------- f_system('CRTBNDRPG PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*XREF *NOGEN *SHOWCPY *EXPDDS *NOSHOWSKP)' + ' DFTACTGRP(*NO)'); f_system('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); f_system('DLTOVR FILE(' + p_SrcMbr + ')'); //--------------------------------------------------------- // read listing open JCRGETFLDF; read JCRGETFLDF; readCount += 1; 1b dow not %eof; 2b if iGlobalRef = 'Indicator References:'; IsLookForSeverity = *on; 2e endif; 2b if not IsLookForSeverity; 3b if IsGlobalRef; exsr srGlobalDefinitions; 3x else; exsr srFileFieldDefitions; 3e endif; 3b if iGlobalRef = 'Global Field References:'; IsGlobalRef = *on; 3e endif; 2e endif; 2b if IMsgSummary = 'RNF1304'; IsServicePgm = *on; 2e endif; 2b if iCheckComplete = 'Diagnostic check of source is complete'; 3b if not IsServicePgm; p_DiagSeverity = iDiagSeverity; 3e endif; 1v leave; 2e endif; read JCRGETFLDF; readCount += 1; 1e enddo; 1b if QusrmbrdDS.MbrType = 'SQLRPGLE'; p_DiagSeverity = SqlSeverity; 1e endif; //--------------------------------------------------------- 1b if p_DiagSeverity <= '20'; f_system('DLTSPLF FILE(' + p_SrcMbr + ') SPLNBR(*LAST)'); 1e endif; 1b if ii > 1; sorta %subarr(FieldsArry: 1: ii); 1e endif; FieldsArry_NumberOfEntries = ii; close JCRGETFLDF; *inlr = *on; return; //--------------------------------------------------------- // Load up all the file field sequence numbers to reference later //--------------------------------------------------------- begsr srFileFieldDefitions; 1b if iExternalForma = '* External format . . . . . :'; aa = %scan('/':iFSname); FileName = %subst(iFSname: aa+1); FileSeq = iFileSeq; 2b dou iEqual = '='; read JCRGETFLDF; readCount += 1; 3b if iGlobalRef = 'Global Field References:'; 2v leave; 3e endif; 3b if iGlobalRef = 'Indicator References:'; IsLookForSeverity = *on; LV leavesr; 3e endif; 2e enddo; 1e endif; 1b if iEqual = '='; xx += 1; FileNameArry(xx) = FileName; 2b if iFileType = 'D'; FileFldsArry(xx) = iDFieldName; 2x elseif iFileType = 'I'; FileFldsArry(xx) = iIFieldName; 2x elseif iFileType = 'O'; FileFldsArry(xx) = iOFieldName; 2e endif; FileFldTxtArry(xx) = iFieldText; 1e endif; endsr; //--------------------------------------------------------- begsr srGlobalDefinitions; 1b if iGlobalRef = 'Field References for sub'; SavProcName = iFSname; 1e endif; 1b if iFldLong = 'No references in the source.'; IsLookForSeverity = *on; LV leavesr; 1e endif; 1b if iGlobAttr3 = ' A(' or iGlobAttr3 = ' B(' or iGlobAttr3 = ' F(' or iGlobAttr3 = ' G(' or iGlobAttr3 = ' I(' or iGlobAttr3 = ' N(' or iGlobAttr3 = ' P(' or iGlobAttr3 = ' S(' or iGlobAttr3 = ' D(' or iGlobAttr3 = ' T(' or iGlobAttr3 = ' U(' or iGlobAttr3 = ' Z(' or iGlobAttr3 = ' *(' or iGlobAttr3 = ' DS' or iGlobAttr3 = ' CO'; IsUnReferenced = *off; //--------------------------------------------------------- // Extract the field name for these attributes. // The field name could be on the same line // RULER1ARRY(19) A(10) // or read backwards a line // FIELDSARRY_NUMBEROFENTRIES... // U(5,0) 384D 1252 // or if on a page break, spread across several lines // // If field name is not on same line, save rrn, read backwards // until I find ... for long field name //--------------------------------------------------------- Savname = *blanks; 2b if iDFieldName > *blanks; IsQualified = %subst(iFldShort:1 :1) = ' '; SavName = %triml(iFldShort); 3b if iNotReferenced = '*'; IsUnReferenced = *on; 3e endif; 2x else; // find long field name reading backwards readp JCRGETFLDF; 3b dow not %eof; aa = %scan('...': iFldLong); 4b if aa > 0; SavName = %triml(%subst(iFldLong: 1: aa - 1)); 5b if iNotReferenced = '*'; IsUnReferenced = *on; 5e endif; chain readcount JCRGETFLDF; // reposition 3v leave; 4e endif; readp JCRGETFLDF; 3e enddo; 2e endif; //--------------------------------------------------------- // load attributes from current record before looking for field name clear FieldsAttrDS; FieldsAttrDS.DecimalPos = *blanks; //-------------------------- 2b if iGlobAttr3 = ' DS'; FieldsAttrDS.DataType = 'A'; 2x elseif iGlobAttr3 = ' CO'; FieldsAttrDS.DataType = 'C'; 2x else; FieldsAttrDS.DataType = iGlobAttr1; 2e endif; //-------------------------- // Alpha sizes are (6) Numeric are (6,0) Date&Time are (8*ISO-) 2b if iGlobAttr3 <> ' CO'; xOpen = %scan('(': iGlobLen); xComma = %scan(',': iGlobLen); xAster = %scan('*': iGlobLen); xClose = %scan(')': iGlobLen); 3b if xAster > 0; // date or time char8 = %subst(iGlobLen: xOpen + 1: (xAster - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); FieldsAttrDS.Text = %subst(iGlobLen: xAster + 1: (xClose - xAster)- 1); 3x elseif xComma > 0; // numeric char8 = %subst(iGlobLen: xOpen + 1: (xComma - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); evalr FieldsAttrDS.DecimalPos = ' ' + %subst(iGlobLen: xComma + 1: (xClose - xComma)- 1); 3x else; // alpha char8 = %subst(iGlobLen: xOpen + 1: (xClose - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); 3e endif; 2e endif; 2b if iGlobAttr3 = ' DS'; FieldsAttrDS.Text = 'DS'; SavQualified = SavName; 2x elseif iGlobAttr3 = ' CO'; FieldsAttrDS.Text = 'CONST'; FieldsAttrDS.DecimalPos = *blanks; //--------------------------------------------------------- // Constants do not show as unreferenced (thanks IBM). // Also the reference numbers are in variable position // based on the number of source statements in the code (Thanks Again). // 0123456789012345 // 3000016M 012900M 7000016 // I am going to start in 50, look for first non-blank, then first blank // and check everything after that for blanks. // In above example, I will look for the first space after the 3, position 8 // if everything after position 8 is blank, then unreferenced. //--------------------------------------------------------- aa = %check(' ':iReference); aa = %scan(' ':iReference: aa); 3b if %subst(iReference: aa) = *blanks; LV leavesr; 3e endif; 2e endif; 2b if IsQualified; FieldsAttrDS.Text = SavQualified; 2e endif; //-------------------------- // Now that the name is extracted, see if file defined field 2b if Savname > *blanks; aa = %lookup(SavName: FileFldsArry: 1: xx); 3b if aa > 0; FieldsAttrDS.FromFile = FileNameArry(aa); FieldsAttrDS.Text = FileFldTxtArry(aa); 3e endif; 2e endif; //-------------------------- // DIM values are stored in field names between (10) = DIM 10 // compress the DIM out of the field name SavDim = *blanks; xOpen = %scan('(': SavName); 2b if xOpen > 0; xClose = %scan(')': SavName); SavDim = 'DIM' + %subst(SavName: xOpen: (xClose - xOpen)+1); SavName = %subst(SavName:1: xOpen - 1); FieldsAttrDS.Text = SavDim; 2e endif; //-------------------------- 2b if SavProcName > *blanks; FieldsAttrDS.Text = SavProcName; 2e endif; //--------------------------------------------------------------- // The JCRCALL (generate call prompt) may need the unreferenced // field definitions as an unreferenced field could be in the PR. //--------------------------------------------------------------- 2b if IsUnreferenced; FieldsAttrDS.Text = '*NOT REFERENCED'; 2e endif; //-------------------------- 2b if %subst(SavName:1:1) <> '*'; // skip indicatiors 3b if ii = 0 or %lookup(SavName: FieldsNameArry: 1: ii) = 0; ii += 1; FieldsNameArry(ii) = SavName; FieldsAttrArry(ii) = FieldsAttrDS; 3e endif; 2e endif; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRGETFLDR - load EXPORT array with field name and attributes // Generate diagnostic source listing // Read spooled file // Load JCRCMDSSRV clipboard array with field names and attributes //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGETFLDFif f 132 disk usropn //--*STAND ALONE------------------------------------------- D aa s 10u 0 D readcount s 10u 0 D xx s 10u 0 D ii s 10u 0 D xOpen s 3u 0 D xComma s 3u 0 D xAster s 3u 0 D xClose s 3u 0 D FileNameArry s 10a dim(12767) D FileFldsArry s 15a dim(12767) D FileFldTxtArry s dim(12767) like(iFieldText) D SqlSeverity s 2a D FileName s 10a D FileSeq s 3a D IsGlobalRef s n inz(*off) D SavName s 100a D SavProcName s 100a D SavQualified s 100a D SavDim s 15a D IsUnReferenced s n D IsQualified s n D IsLookForSeverity... D s n D IsServicePgm s n D char8 s 8a //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define FieldsAttrDS /Define f_IsValidMbr /Define f_GetQual /Define f_System /Define f_Qusrmbrd /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRGETFLDR PI D p_SrcFilQual 20a const D p_SrcMbr 10a D p_DiagSeverity 2a //--*INPUT SPECS------------------------------------------- IJCRGETFLDFaa I a 1 1 iNotReferenced I a 1 2 iSqlSeverity I a 1 6 iFileFldSeq I a 1 38 iCheckComplete I a 2 8 iMsgSummary I a 4 12 iSQLlevel I a 7 7 iEqual I a 7 30 iGlobalRef I a 8 8 iFileType I a 9 38 iExternalForma I a 10 11 iQualified I a 10 19 iDFieldName E DS field I a 10 26 iFldShort I a 10 132 iFldLong I a 32 41 iOFieldName Output File Field I a 28 45 iGlobDefn I a 28 28 iGlobAttr1 P, A, S, U, etc. I a 27 29 iGlobAttr3 DS I a 29 45 iGlobLen (3,0) I a 41 132 iFSname File or subproc name I a 50 80 iReference I a 51 65 iIFieldName Input File Field I a 61 62 iDiagSeverity I a 83 121 iFieldText I a 120 123 iPage I a 122 124 iFileSeq /free //--------------------------------------------------------- // generate diagnostic listing and copy to data file p_DiagSeverity = '00'; 1b if f_IsValidMbr('JCRGETFLDF': 'QTEMP '); f_system('CLRPFM QTEMP/JCRGETFLDF'); 1x else; f_System('CRTPF FILE(QTEMP/JCRGETFLDF) RCDLEN(132) SIZE(*NOMAX)'); 1e endif; f_system('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)'); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); //--------------------------------------------------------- // Thanks again IBM. SQLRPGLE CRTSQLRPGI does not generated an unreferenced // listing. But I need to get the severity of the SQL compile. // If SQL, I will do a diag of SQL, then do a CRTBNDRPG to get the unreferenced listing. //--------------------------------------------------------- 1b if QusrmbrdDS.MbrType = 'SQLRPGLE'; f_system('CRTSQLRPGI OBJ(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*NOXREF *NOGEN) OUTPUT(*PRINT)'); f_system('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); open JCRGETFLDF; setgt *hival JCRGETFLDF; readp JCRGETFLDF; 2b dow not %eof; 3b if iSQLlevel = 'level sev'; SqlSeverity = iSqlSeverity ; 2v leave; 3e endif; 3b if iCheckComplete = 'No errors found in source '; f_system('DLTSPLF FILE(' + p_SrcMbr + ') SPLNBR(*LAST)'); SqlSeverity = '00'; 2v leave; 3e endif; readp JCRGETFLDF; 2e enddo; close JCRGETFLDF; 1e endif; //--------------------------------------------------------- f_system('CRTBNDRPG PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*XREF *NOGEN *SHOWCPY *EXPDDS *NOSHOWSKP)'); f_system('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); f_system('DLTOVR FILE(' + p_SrcMbr + ')'); //--------------------------------------------------------- // read listing open JCRGETFLDF; read JCRGETFLDF; readCount += 1; 1b dow not %eof; 2b if iGlobalRef = 'Indicator References:'; IsLookForSeverity = *on; 2e endif; 2b if not IsLookForSeverity; 3b if IsGlobalRef; exsr srGlobalDefinitions; 3x else; exsr srFileFieldDefitions; 3e endif; 3b if iGlobalRef = 'Global Field References:'; IsGlobalRef = *on; 3e endif; 2e endif; 2b if IMsgSummary = 'RNF1304'; IsServicePgm = *on; 2e endif; 2b if iCheckComplete = 'Diagnostic check of source is complete'; 3b if not IsServicePgm; p_DiagSeverity = iDiagSeverity; 3e endif; 1v leave; 2e endif; read JCRGETFLDF; readCount += 1; 1e enddo; 1b if QusrmbrdDS.MbrType = 'SQLRPGLE'; p_DiagSeverity = SqlSeverity; 1e endif; //--------------------------------------------------------- 1b if p_DiagSeverity <= '20'; f_system('DLTSPLF FILE(' + p_SrcMbr + ') SPLNBR(*LAST)'); 1e endif; 1b if ii > 1; sorta %subarr(FieldsArry: 1: ii); 1e endif; FieldsArry_NumberOfEntries = ii; close JCRGETFLDF; *inlr = *on; return; //--------------------------------------------------------- // Load up all the file field sequence numbers to reference later //--------------------------------------------------------- begsr srFileFieldDefitions; 1b if iExternalForma = '* External format . . . . . :'; aa = %scan('/':iFSname); FileName = %subst(iFSname: aa+1); FileSeq = iFileSeq; 2b dou iEqual = '='; read JCRGETFLDF; readCount += 1; 3b if iGlobalRef = 'Global Field References:'; 2v leave; 3e endif; 3b if iGlobalRef = 'Indicator References:'; IsLookForSeverity = *on; LV leavesr; 3e endif; 2e enddo; 1e endif; 1b if iEqual = '='; xx += 1; FileNameArry(xx) = FileName; 2b if iFileType = 'D'; FileFldsArry(xx) = iDFieldName; 2x elseif iFileType = 'I'; FileFldsArry(xx) = iIFieldName; 2x elseif iFileType = 'O'; FileFldsArry(xx) = iOFieldName; 2e endif; FileFldTxtArry(xx) = iFieldText; 1e endif; endsr; //--------------------------------------------------------- begsr srGlobalDefinitions; 1b if iGlobalRef = 'Field References for sub'; SavProcName = iFSname; 1e endif; 1b if iFldLong = 'No references in the source.'; IsLookForSeverity = *on; LV leavesr; 1e endif; 1b if iGlobAttr3 = ' A(' or iGlobAttr3 = ' B(' or iGlobAttr3 = ' F(' or iGlobAttr3 = ' G(' or iGlobAttr3 = ' I(' or iGlobAttr3 = ' N(' or iGlobAttr3 = ' P(' or iGlobAttr3 = ' S(' or iGlobAttr3 = ' D(' or iGlobAttr3 = ' T(' or iGlobAttr3 = ' U(' or iGlobAttr3 = ' Z(' or iGlobAttr3 = ' *(' or iGlobAttr3 = ' DS' or iGlobAttr3 = ' CO'; IsUnReferenced = *off; //--------------------------------------------------------- // Extract the field name for these attributes. // The field name could be on the same line // RULER1ARRY(19) A(10) // or read backwards a line // FIELDSARRY_NUMBEROFENTRIES... // U(5,0) 384D 1252 // or if on a page break, spread across several lines // // If field name is not on same line, save rrn, read backwards // until I find ... for long field name //--------------------------------------------------------- Savname = *blanks; 2b if iDFieldName > *blanks; IsQualified = %subst(iFldShort:1 :1) = ' '; SavName = %triml(iFldShort); 3b if iNotReferenced = '*'; IsUnReferenced = *on; 3e endif; 2x else; // find long field name reading backwards readp JCRGETFLDF; 3b dow not %eof; aa = %scan('...': iFldLong); 4b if aa > 0; SavName = %triml(%subst(iFldLong: 1: aa - 1)); 5b if iNotReferenced = '*'; IsUnReferenced = *on; 5e endif; chain readcount JCRGETFLDF; // reposition 3v leave; 4e endif; readp JCRGETFLDF; 3e enddo; 2e endif; //--------------------------------------------------------- // load attributes from current record before looking for field name clear FieldsAttrDS; FieldsAttrDS.DecimalPos = *blanks; //-------------------------- 2b if iGlobAttr3 = ' DS'; FieldsAttrDS.DataType = 'A'; 2x elseif iGlobAttr3 = ' CO'; FieldsAttrDS.DataType = 'C'; 2x else; FieldsAttrDS.DataType = iGlobAttr1; 2e endif; //-------------------------- // Alpha sizes are (6) Numeric are (6,0) Date&Time are (8*ISO-) 2b if iGlobAttr3 <> ' CO'; xOpen = %scan('(': iGlobLen); xComma = %scan(',': iGlobLen); xAster = %scan('*': iGlobLen); xClose = %scan(')': iGlobLen); 3b if xAster > 0; // date or time char8 = %subst(iGlobLen: xOpen + 1: (xAster - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); FieldsAttrDS.Text = %subst(iGlobLen: xAster + 1: (xClose - xAster)- 1); 3x elseif xComma > 0; // numeric char8 = %subst(iGlobLen: xOpen + 1: (xComma - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); evalr FieldsAttrDS.DecimalPos = ' ' + %subst(iGlobLen: xComma + 1: (xClose - xComma)- 1); 3x else; // alpha char8 = %subst(iGlobLen: xOpen + 1: (xClose - xOpen) - 1); FieldsAttrDS.Length = %uns(char8); 3e endif; 2e endif; 2b if iGlobAttr3 = ' DS'; FieldsAttrDS.Text = 'DS'; SavQualified = SavName; 2x elseif iGlobAttr3 = ' CO'; FieldsAttrDS.Text = 'CONST'; FieldsAttrDS.DecimalPos = *blanks; //--------------------------------------------------------- // Constants do not show as unreferenced (thanks IBM). // Also the reference numbers are in variable position // based on the number of source statements in the code (Thanks Again). // 0123456789012345 // 3000016M 012900M 7000016 // I am going to start in 50, look for first non-blank, then first blank // and check everything after that for blanks. // In above example, I will look for the first space after the 3, position 8 // if everything after position 8 is blank, then unreferenced. //--------------------------------------------------------- aa = %check(' ':iReference); aa = %scan(' ':iReference: aa); 3b if %subst(iReference: aa) = *blanks; LV leavesr; 3e endif; 2e endif; 2b if IsQualified; FieldsAttrDS.Text = SavQualified; 2e endif; //-------------------------- // Now that the name is extracted, see if file defined field 2b if Savname > *blanks; aa = %lookup(SavName: FileFldsArry: 1: xx); 3b if aa > 0; FieldsAttrDS.FromFile = FileNameArry(aa); FieldsAttrDS.Text = FileFldTxtArry(aa); 3e endif; 2e endif; //-------------------------- // DIM values are stored in field names between (10) = DIM 10 // compress the DIM out of the field name SavDim = *blanks; xOpen = %scan('(': SavName); 2b if xOpen > 0; xClose = %scan(')': SavName); SavDim = 'DIM' + %subst(SavName: xOpen: (xClose - xOpen)+1); SavName = %subst(SavName:1: xOpen - 1); FieldsAttrDS.Text = SavDim; 2e endif; //-------------------------- 2b if SavProcName > *blanks; FieldsAttrDS.Text = SavProcName; 2e endif; //--------------------------------------------------------------- // The JCRCALL (generate call prompt) may need the unreferenced // field definitions as an unreferenced field could be in the PR. //--------------------------------------------------------------- 2b if IsUnreferenced; FieldsAttrDS.Text = '*NOT REFERENCED'; 2e endif; //-------------------------- 2b if %subst(SavName:1:1) <> '*'; // skip indicatiors 3b if ii = 0 or %lookup(SavName: FieldsNameArry: 1: ii) = 0; ii += 1; FieldsNameArry(ii) = SavName; FieldsAttrArry(ii) = FieldsAttrDS; 3e endif; 2e endif; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRGMBLJ - Black Jack //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMBLJD cf e workstn infds(Infds) indds(Ind) //--*STAND ALONE------------------------------------------- D YouHave s 3u 0 D DealerShow s 3u 0 D yy s 3u 0 D yyAlpha s 3a D Color s 1a D CardFace s 2a D DealerDownCrd s 2a D DeckArry s 2a dim(52) D hh s 3u 0 D Dealer s 3u 0 inz(1) D Player s 3u 0 inz(2) D Card s 3u 0 D Row s 3u 0 D Col s 3u 0 D Deal s 3u 0 D xx s 3u 0 D HandValue s 3u 0 D NxtCardDealt s 3u 0 D NxtDealerCard s 3u 0 D NxtPlayerCard s 3u 0 D IsCompleted s n //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetCardFace /Define f_ShuffleDeck /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Define 4D array for card faces and screen field attributes D Hand ds dim(2) qualified based(ptr) D Card likeds(CardDS) dim(6) D CardDS ds qualified D Row dim(3) likeds(ColumnDS) D ColumnDS ds qualified D Col 1a dim(3) D ptr s * inz(%addr(s0111)) D HandA ds dim(2) likeds(Hand) based(ptr2) D ptr2 s * inz(%addr(s0111a)) // 2D array for Card ID attributes at top and bottom of card D CardIdA ds dim(2) qualified D Card 1a dim(6) // 2D array for Card ID values D CardId ds dim(2) qualified D Card 2a dim(6) // 2D array for card outline border attributes D BorderA ds dim(2) qualified based(ptr5) D Card 1a dim(6) D ptr5 s * inz(%addr(Border1A)) // accumulators // Define 2D arrays for large hand values D Big ds dim(7) qualified large characters D Col 1a dim(4) D BigA ds dim(7) likeds(Big) D Deal10s ds dim(7) likeds(Big) based(ptr8) 10s D ptr8 s * inz(%addr(D111)) D Deal10sA ds dim(7) likeds(Big) based(ptr9) D ptr9 s * inz(%addr(D111a)) D Deal1s ds dim(7) likeds(Big) based(ptr10) 1s D ptr10 s * inz(%addr(D211)) D Deal1sA ds dim(7) likeds(Big) based(ptr11) D ptr11 s * inz(%addr(D211a)) D User10s ds dim(7) likeds(Big) based(ptr13) 10s D ptr13 s * inz(%addr(U111)) D User10sA ds dim(7) likeds(Big) based(ptr14) D ptr14 s * inz(%addr(U111a)) D User1s ds dim(7) likeds(Big) based(ptr15) 1s D ptr15 s * inz(%addr(U211)) D User1sA ds dim(7) likeds(Big) based(ptr16) D ptr16 s * inz(%addr(U211a)) //--*FUNCTION PROTOTYPES----------------------------------- D f_LoadBig PR 4a dim(7) D 3u 0 // map screen fields into DS so arrays can manipulate values D screenDS ds // card value sum D D111 D D112 D D113 D D114 D D121 D D122 D D123 D D124 D D131 D D132 D D133 D D134 D D141 D D142 D D143 D D144 D D151 D D152 D D153 D D154 D D161 D D162 D D163 D D164 D D171 D D172 D D173 D D174 D D211 D D212 D D213 D D214 D D221 D D222 D D223 D D224 D D231 D D232 D D233 D D234 D D241 D D242 D D243 D D244 D D251 D D252 D D253 D D254 D D261 D D262 D D263 D D264 D D271 D D272 D D273 D D274 D D111A D D112A D D113A D D114A D D121A D D122A D D123A D D124A D D131A D D132A D D133A D D134A D D141A D D142A D D143A D D144A D D151A D D152A D D153A D D154A D D161A D D162A D D163A D D164A D D171A D D172A D D173A D D174A D D211A D D212A D D213A D D214A D D221A D D222A D D223A D D224A D D231A D D232A D D233A D D234A D D241A D D242A D D243A D D244A D D251A D D252A D D253A D D254A D D261A D D262A D D263A D D264A D D271A D D272A D D273A D D274A D U111 D U112 D U113 D U114 D U121 D U122 D U123 D U124 D U131 D U132 D U133 D U134 D U141 D U142 D U143 D U144 D U151 D U152 D U153 D U154 D U161 D U162 D U163 D U164 D U171 D U172 D U173 D U174 D U211 D U212 D U213 D U214 D U221 D U222 D U223 D U224 D U231 D U232 D U233 D U234 D U241 D U242 D U243 D U244 D U251 D U252 D U253 D U254 D U261 D U262 D U263 D U264 D U271 D U272 D U273 D U274 D U111A D U112A D U113A D U114A D U121A D U122A D U123A D U124A D U131A D U132A D U133A D U134A D U141A D U142A D U143A D U144A D U151A D U152A D U153A D U154A D U161A D U162A D U163A D U164A D U171A D U172A D U173A D U174A D U211A D U212A D U213A D U214A D U221A D U222A D U223A D U224A D U231A D U232A D U233A D U234A D U241A D U242A D U243A D U244A D U251A D U252A D U253A D U254A D U261A D U262A D U263A D U264A D U271A D U272A D U273A D U274A D Border1A D Border2A D Border3A D Border4A D Border5A D Border6A D Border7A D Border8A D Border9A D Border10A D Border11A D Border12A // Card Faces D s0111 D s0112 D s0113 D s0121 D s0122 D s0123 D s0131 D s0132 D s0133 D s0211 D s0212 D s0213 D s0221 D s0222 D s0223 D s0231 D s0232 D s0233 D s0311 D s0312 D s0313 D s0321 D s0322 D s0323 D s0331 D s0332 D s0333 D s0411 D s0412 D s0413 D s0421 D s0422 D s0423 D s0431 D s0432 D s0433 D s0511 D s0512 D s0513 D s0521 D s0522 D s0523 D s0531 D s0532 D s0533 D s0611 D s0612 D s0613 D s0621 D s0622 D s0623 D s0631 D s0632 D s0633 D s0711 D s0712 D s0713 D s0721 D s0722 D s0723 D s0731 D s0732 D s0733 D s0811 D s0812 D s0813 D s0821 D s0822 D s0823 D s0831 D s0832 D s0833 D s0911 D s0912 D s0913 D s0921 D s0922 D s0923 D s0931 D s0932 D s0933 D s1011 D s1012 D s1013 D s1021 D s1022 D s1023 D s1031 D s1032 D s1033 D s1111 D s1112 D s1113 D s1121 D s1122 D s1123 D s1131 D s1132 D s1133 D s1211 D s1212 D s1213 D s1221 D s1222 D s1223 D s1231 D s1232 D s1233 // card face attributes D s0111A D s0112A D s0113A D s0121A D s0122A D s0123A D s0131A D s0132A D s0133A D s0211A D s0212A D s0213A D s0221A D s0222A D s0223A D s0231A D s0232A D s0233A D s0311A D s0312A D s0313A D s0321A D s0322A D s0323A D s0331A D s0332A D s0333A D s0411A D s0412A D s0413A D s0421A D s0422A D s0423A D s0431A D s0432A D s0433A D s0511A D s0512A D s0513A D s0521A D s0522A D s0523A D s0531A D s0532A D s0533A D s0611A D s0612A D s0613A D s0621A D s0622A D s0623A D s0631A D s0632A D s0633A D s0711A D s0712A D s0713A D s0721A D s0722A D s0723A D s0731A D s0732A D s0733A D s0811A D s0812A D s0813A D s0821A D s0822A D s0823A D s0831A D s0832A D s0833A D s0911A D s0912A D s0913A D s0921A D s0922A D s0923A D s0931A D s0932A D s0933A D s1011A D s1012A D s1013A D s1021A D s1022A D s1023A D s1031A D s1032A D s1033A D s1111A D s1112A D s1113A D s1121A D s1122A D s1123A D s1131A D s1132A D s1133A D s1211A D s1212A D s1213A D s1221A D s1222A D s1223A D s1231A D s1232A D s1233A // name screen indicators D ind ds qualified D IsStand n overlay(ind:06) D CurrCard ds qualified D NumVal 3u 0 inz D Suite 1a //--*ENTRY PARMS *NONE* ----------------------------------- /free // Load Splash alt red-blue strips and load 'BLACK JACK' onto card face. IsCompleted = *on; Hand(*) = *all' '; HandA(*) = *allx'00'; CardIdA(*) = *allx'00'; CardId(*) = *all' '; Credits = 100; hh = Dealer; Hand(hh).Card(1) = *all'B'; CardId(hh).Card(1) = 'B '; Hand(hh).Card(2) = *all'L'; CardId(hh).Card(2) = 'L '; Hand(hh).Card(3) = *all'A'; CardId(hh).Card(3) = 'A '; Hand(hh).Card(4) = *all'C'; CardId(hh).Card(4) = 'C '; Hand(hh).Card(5) = *all'K'; CardId(hh).Card(5) = 'K '; Hand(hh).Card(6) = *all' '; CardId(hh).Card(6) = ' '; hh = Player; Hand(hh).Card(1) = *all'J'; CardId(hh).Card(1) = 'J '; Hand(hh).Card(2) = *all'A'; CardId(hh).Card(2) = 'A '; Hand(hh).Card(3) = *all'C'; CardId(hh).Card(3) = 'C '; Hand(hh).Card(4) = *all'K'; CardId(hh).Card(4) = 'K '; Hand(hh).Card(5) = *all'2'; CardId(hh).Card(5) = '2 '; Hand(hh).Card(6) = *all'1'; CardId(hh).Card(6) = '1 '; evalr scDow = %trimr(f_GetDayName()); //-load card colors---------- 1b for hh = Dealer to Player; 2b for Card = 1 to 6; 3b if Card = 1 or Card = 5; Color = %bitor(RED: RI); 3x elseif Card = 2 or Card = 6; Color = %bitor(WHITE: RI); 3x elseif Card = 3; Color = %bitor(YELLOW: RI); 3x elseif Card = 4; Color = %bitor(BLUE: RI); 3e endif; BorderA(hh).Card(Card) = Color; 3b for row = 1 to 3; HandA(hh).Card(Card).Row(row).Col(*) = Color; 3e endfor; 2e endfor; 1e endfor; //--------------------------------------------------------- // Play the game. 1b dou 1 = 2; 2b if DealerShow > 0; exsr srShowBigTot; 2e endif; exfmt SCREEN; 2b if InfdsFkey = f03; 1v leave; 2e endif; // If current hand is completed, reset all for next hand. // Load new hands to restart game. 2b if IsCompleted; exsr srNextHand; 2x elseif InfdsFkey = f02; exsr srStand; 2x else; exsr srHitPlayer1Card; 2e endif; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // Stand. first turn up dealer down card // Evaluate total in dealers hand. // If < 17, deal computer cards until count is greater 17 or busted. begsr srStand; hh = Dealer; Card = 1; CurrCard = DealerDownCrd; exsr srLoadCardFace; exsr srCalcHandValue; DealerShow = Handvalue; exsr srShowBigTot; write screen; 1b dow DealerShow < 17 and DealerShow < YouHave; NxtDealerCard += 1; Card = NxtDealerCard; NxtCardDealt += 1; CurrCard = DeckArry(NxtCardDealt); exsr srLoadCardFace; exsr srCalcHandValue; DealerShow = Handvalue; exsr srShowBigTot; write screen; 2b if NxtDealerCard = 6; 1v leave; 2e endif; 1e enddo; //--------------------------------------------------------- // Now the moment of truth! Who won?- 1b if DealerShow > 21; //dealer BUSTED! YourMsg = '** W I N N E R **'; YourMsgA = %bitor(WHITE: RI); DealerMsg = '**DEALER BUSTED**'; DealerMsgA = %bitor(RED: HI: RI); hh = Player; exsr srWinnerBorderColor; credits += YouBet; Youbet = 0; 1x elseif DealerShow < YouHave; //Player Won YourMsg = '** W I N N E R **'; YourMsgA = %bitor(WHITE: RI); DealerMsg = *blanks; DealerMsgA = x'00'; credits += YouBet; Youbet = 0; hh = Player; exsr srWinnerBorderColor; 1x elseif DealerShow > YouHave; //Dealer Won DealerMsg = '** DEALER WINS **'; DealerMsgA = %bitor(WHITE: RI); YourMsg = *blanks; YourMsgA = x'00'; hh = Dealer; exsr srWinnerBorderColor; credits -= YouBet; Youbet = 0; 1x elseif DealerShow = YouHave; //Tie DealerMsg = '** T I E **'; DealerMsgA = %bitor(WHITE: RI); YourMsg = '** BET DOUBLED **'; YourMsgA = %bitor(WHITE: RI); 2b for hh = Dealer to Player; exsr srWinnerBorderColor; 2e endfor; 1e endif; ind.IsStand = *off; IsCompleted = *on; endsr; //--------------------------------------------------------- // Deal next hand. Reset messages and load new deck of cards. begsr srNextHand; Hand(*) = *all' '; HandA(*) = *allx'00'; CardIdA(*) = *allx'00'; CardId(*) = *all' '; 1b for hh = Dealer to Player; 2b for Card = 1 to 6; BorderA(hh).Card(Card) = ND; 2e endfor; 1e endfor; clear DealerMsg; DealerMsgA = x'00'; clear YourMsg; YourMsgA = x'00'; clear YouHave; clear DealerShow; YouBet += 10; NxtPlayerCard = 2; NxtDealerCard = 2; NxtCardDealt = 4; IsCompleted = *off; ind.IsStand = *on; DeckArry = f_ShuffleDeck(); //sort deck exsr srDeal2Cards; //deal 1st hand hh = Dealer; exsr srCalcHandValue; DealerShow = Handvalue; hh = Player; exsr srCalcHandValue; YouHave = Handvalue; endsr; //--------------------------------------------------------- // Deal player next card from deck. begsr srHitPlayer1Card; hh = Player; NxtPlayerCard += 1; 1b if NxtPlayerCard < 7; Card = NxtPlayerCard; NxtCardDealt += 1; CurrCard = DeckArry(NxtCardDealt); exsr srLoadCardFace; 1e endif; exsr srCalcHandValue; YouHave = Handvalue; //--------------------------------------------------------- // Check to see if greedy overachieving player went past 21. // 1. Load busted message. // 2. Turn Over dealer Face card, and load dealers hand value. // 3. Load dealer wins message. // 4. Subtract out lost bet // 5 set complete flag to reset SCREEN for next hand 1b if YouHave > 21; //BUSTED! YourMsg = '** B U S T E D **'; YourMsgA = %bitor(RED: RI: HI); DealerMsg = '** DEALER WINS **'; DealerMsgA = %bitor(WHITE: RI); hh = Dealer; Card = 1; CurrCard = DealerDownCrd; 2b for Row = 1 to 3; Hand(hh).Card(Card).Row(Row) = *all' '; HandA(hh).Card(Card).Row(Row) = *allx'00'; 2e endfor; exsr srLoadCardFace; exsr srCalcHandValue; DealerShow = Handvalue; Credits -= YouBet; Youbet = 0; hh = Dealer; exsr srWinnerBorderColor; ind.IsStand = *off; IsCompleted = *on; 1e endif; endsr; //--------------------------------------------------------- begsr srWinnerBorderColor; 1b for Card = 1 to 6; 2b if CardId(hh).Card(Card) = ' '; 1v leave; 2e endif; BorderA(hh).Card(Card) = CardIdA(hh).Card(Card); 1e endfor; endsr; //--------------------------------------------------------- // Problem here is ACE can count 1 or 11. // I couldn't accumulate values of cards as they // were dealt as ACE = 11 till player goes over 21 begsr srCalcHandValue; HandValue = 0; 1b for Card = 1 to 6; 2b if CardId(hh).Card(Card) = ' '; 1v leave; 2e endif; 2b if CardId(hh).Card(Card) = 'A1'; HandValue += 1; 2x elseif CardId(hh).Card(Card) = 'A '; HandValue += 11; 2x elseif CardId(hh).Card(Card) = '2 '; HandValue += 2; 2x elseif CardId(hh).Card(Card) = '3 '; HandValue += 3; 2x elseif CardId(hh).Card(Card) = '4 '; HandValue += 4; 2x elseif CardId(hh).Card(Card) = '5 '; HandValue += 5; 2x elseif CardId(hh).Card(Card) = '6 '; HandValue += 6; 2x elseif CardId(hh).Card(Card) = '7 '; HandValue += 7; 2x elseif CardId(hh).Card(Card) = '8 '; HandValue += 8; 2x elseif CardId(hh).Card(Card) = '9 '; HandValue += 9; 2x elseif CardId(hh).Card(Card) = '10' or CardId(hh).Card(Card) = 'J ' or CardId(hh).Card(Card) = 'Q ' or CardId(hh).Card(Card) = 'K '; HandValue += 10; 2e endif; 1e endfor; //--------------------------------------------------------- // if hand value is over 21, cycle back through // and see if any Aces can be valued at 1. 1b if HandValue > 21; 2b for Card = 1 to 6; //spin through cards 3b if CardId(hh).Card(Card) = 'A '; CardId(hh).Card(Card) = 'A1'; HandValue -= 10; 2v leave; 3e endif; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // Deal 2 cards to players and computers hand. begsr srDeal2Cards; hh = Player; Card = 0; 1b for Deal = 1 by 2 to 3; //deal 1 & 3 Card += 1; CurrCard = DeckArry(Deal); exsr srLoadCardFace; 1e endfor; //--------------------------------------------------------- // Save first card dealt to deal as that will be his 'down' card. hh = Dealer; Card = 0; 1b for Deal = 2 by 2 to 4; //deal 2 & 4 Card += 1; CurrCard = DeckArry(Deal); 2b if Card = 1; //dealer down card DealerDownCrd = CurrCard; exsr srLoadDownCard; 2x elseif Card = 2; exsr srLoadCardFace; 2e endif; 1e endfor; Card = 0; endsr; //--------------------------------------------------------- // Make dealers 1st card appear as down card. begsr srLoadDownCard; CardId(hh).Card(Card) = '**'; BorderA(hh).Card(Card) = Blue; 1b for row = 1 to 3; 2b for col = 1 to 3; HandA(hh).Card(Card).Row(Row).Col(Col) = %bitor(Red: RI); 3b if col = 2; HandA(hh).Card(Card).Row(Row).Col(Col) = %bitor(Blue: RI); 3e endif; 2e endfor; 1e endfor; Hand(hh).Card(Card).Row(1).Col(*) = '*'; Hand(hh).Card(Card).Row(2).Col(*) = '*'; Hand(hh).Card(Card).Row(3).Col(*) = '*'; endsr; //--------------------------------------------------------- // Load card images to screen. begsr srLoadCardFace; CardFace = f_GetCardFace(CurrCard.NumVal); CardId(hh).Card(Card) = CardFace; 1b if CardFace = 'A ' or CardFace = 'A1' ; Hand(hh).Card(Card).Row(1) = 'A A'; Hand(hh).Card(Card).Row(2) = 'A A'; Hand(hh).Card(Card).Row(3) = 'A A'; Color = %bitor(Red: RI); 1x elseif CardFace = 'K '; Hand(hh).Card(Card).Row(1) = 'K K'; Hand(hh).Card(Card).Row(2) = 'K K'; Hand(hh).Card(Card).Row(3) = 'K K'; Color = %bitor(Yellow: RI); 1x elseif CardFace = 'Q '; Hand(hh).Card(Card).Row(1) = 'Q Q'; Hand(hh).Card(Card).Row(2) = 'Q Q'; Hand(hh).Card(Card).Row(3) = 'Q Q'; Color = %bitor(White: RI); 1x elseif CardFace = 'J '; Hand(hh).Card(Card).Row(1) = 'J J'; Hand(hh).Card(Card).Row(2) = 'J J'; Hand(hh).Card(Card).Row(3) = 'J J'; Color = %bitor(Green: RI); 1x elseif CardFace = '10'; Hand(hh).Card(Card).Row(1) = '1 0'; Hand(hh).Card(Card).Row(2) = '1 0'; Hand(hh).Card(Card).Row(3) = '1 0'; Color = %bitor(Red: RI); 1x elseif CardFace = '9 '; Hand(hh).Card(Card).Row(1) = '999'; Hand(hh).Card(Card).Row(2) = '999'; Hand(hh).Card(Card).Row(3) = '999'; Color = %bitor(Blue:RI); 1x elseif CardFace = '8 '; Hand(hh).Card(Card).Row(1) = '888'; Hand(hh).Card(Card).Row(2) = '8 8'; Hand(hh).Card(Card).Row(3) = '888'; Color = %bitor(Yellow: RI); 1x elseif CardFace = '7 '; Hand(hh).Card(Card).Row(1) = '777'; Hand(hh).Card(Card).Row(2) = ' 7 '; Hand(hh).Card(Card).Row(3) = '777'; Color = %bitor(White: RI); 1x elseif CardFace = '6 '; Hand(hh).Card(Card).Row(1) = '666'; Hand(hh).Card(Card).Row(2) = ' '; Hand(hh).Card(Card).Row(3) = '666'; Color = %bitor(Green: RI); 1x elseif CardFace = '5 '; Hand(hh).Card(Card).Row(1) = '5 5'; Hand(hh).Card(Card).Row(2) = ' 5 '; Hand(hh).Card(Card).Row(3) = '5 5'; Color = %bitor(Red: RI); 1x elseif CardFace = '4 '; Hand(hh).Card(Card).Row(1) = '4 4'; Hand(hh).Card(Card).Row(2) = ' '; Hand(hh).Card(Card).Row(3) = '4 4'; Color = %bitor(Blue:RI); 1x elseif CardFace = '3 '; Hand(hh).Card(Card).Row(1) = '3 '; Hand(hh).Card(Card).Row(2) = ' 3 '; Hand(hh).Card(Card).Row(3) = ' 3'; Color = %bitor(Yellow: RI); 1x elseif CardFace = '2 '; Hand(hh).Card(Card).Row(1) = '2 '; Hand(hh).Card(Card).Row(2) = ' '; Hand(hh).Card(Card).Row(3) = ' 2'; Color = %bitor(White: RI); 1e endif; CardIdA(hh).Card(Card) = Color; 1b for row = 1 to 3; 2b for col = 1 to 3; 3b if Hand(hh).Card(Card).Row(row).Col(col) = ' '; HandA(hh).Card(Card).Row(row).Col(col) = x'00'; 3x else; HandA(hh).Card(Card).Row(row).Col(col) = Color; 3e endif; 2e endfor; 1e endfor; BorderA(hh).Card(Card) = White; endsr; //--------------------------------------------------------- // Idea here, is to show card values in large characters //--------------------------------------------------------- begsr srShowBigTot; evalr yyAlpha = '000' + %char(DealerShow); yy = %dec(%subst(yyAlpha:3:1) :1 :0); exsr srColorBig; Deal1s(*) = Big(*); Deal1sA(*) = BigA(*); yy = %dec(%subst(yyAlpha:2:1) :1 :0); 1b if yy = 0; // zero suppress 2b for yy = 1 to 7; Deal10s(yy).col(*) = *blanks; Deal10sA(yy).col(*) = ND; 2e endfor; 1x else; exsr srColorBig; Deal10s(*) = Big(*); Deal10sA(*) = BigA(*); 1e endif; evalr yyAlpha = '000' + %char(YouHave); yy = %dec(%subst(yyAlpha:3:1) :1 :0); exsr srColorBig; User1s(*) = Big(*); User1sA(*) = BigA(*); yy = %dec(%subst(yyAlpha:2:1) :1 :0); 1b if yy = 0; // zero suppress 2b for yy = 1 to 7; User10s(yy).col(*) = *blanks; User10sA(yy).col(*) = ND; 2e endfor; 1x else; exsr srColorBig; User10s(*) = Big(*); User10sA(*) = BigA(*); 1e endif; endsr; //--------------------------------------------------------- begsr srColorBig; Big = f_LoadBig(yy); 1b for Row = 1 to 7; 2b for Col = 1 to 4; 3b if Big(Row).Col(Col) > ' '; BigA(Row).Col(Col) = %bitor(Blue: RI); 3x else; BigA(Row).Col(Col) = ND; 3e endif; 2e endfor; 1e endfor; endsr; /end-free //--------------------------------------------------------- // Return 4 row X 7 column array P f_LoadBig b D f_LoadBig PI 4a dim(7) D p_BaseNum 3u 0 D Line s 4a dim(7) /free 1b if p_BaseNum = 3; Line(1) = '333 '; Line(2) = ' 3'; Line(3) = ' 3'; Line(4) = ' 333'; Line(5) = ' 3'; Line(6) = ' 3'; Line(7) = '333 '; 1x elseif p_BaseNum = 2; Line(1) = '222 '; Line(2) = ' 2'; Line(3) = ' 2'; Line(4) = ' 22 '; Line(5) = '2 '; Line(6) = '2 '; Line(7) = '2222'; 1x elseif p_BaseNum = 1; Line(1) = ' 11 '; Line(2) = ' 1 '; Line(3) = ' 1 '; Line(4) = ' 1 '; Line(5) = ' 1 '; Line(6) = ' 1 '; Line(7) = ' 111'; 1x elseif p_BaseNum = 0; Line(1) = ' 00 '; Line(2) = '0 0'; Line(3) = '0 0'; Line(4) = '0 0'; Line(5) = '0 0'; Line(6) = '0 0'; Line(7) = ' 00 '; 1x elseif p_BaseNum = 9; Line(1) = '9999'; Line(2) = '9 9'; Line(3) = '9 9'; Line(4) = '9999'; Line(5) = ' 9'; Line(6) = ' 9'; Line(7) = '9999'; 1x elseif p_BaseNum = 8; Line(1) = '8888'; Line(2) = '8 8'; Line(3) = '8 8'; Line(4) = '8888'; Line(5) = '8 8'; Line(6) = '8 8'; Line(7) = '8888'; 1x elseif p_BaseNum = 7; Line(1) = '7777'; Line(2) = ' 7'; Line(3) = ' 7'; Line(4) = ' 7 '; Line(5) = ' 7 '; Line(6) = '7 '; Line(7) = '7 '; 1x elseif p_BaseNum = 6; Line(1) = '6666'; Line(2) = '6 '; Line(3) = '6 '; Line(4) = '6666'; Line(5) = '6 6'; Line(6) = '6 6'; Line(7) = '6666'; 1x elseif p_BaseNum = 5; Line(1) = '5555'; Line(2) = '5 '; Line(3) = '5 '; Line(4) = '5555'; Line(5) = ' 5'; Line(6) = ' 5'; Line(7) = '5555'; 1x elseif p_BaseNum = 4; Line(1) = ' 44'; Line(2) = ' 4 4'; Line(3) = '4 4'; Line(4) = '4444'; Line(5) = ' 4'; Line(6) = ' 4'; Line(7) = ' 4'; 1e endif; return Line; /end-free P f_LoadBig e ]]> v5r4 *---------------------------------------------------------------- * JCRGMBLJD - Black Jack - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A CA03 A INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A 06 CA02 A R SCREEN A FRCDTA A D111A 1A P A D112A 1A P A D113A 1A P A D114A 1A P A D121A 1A P A D122A 1A P A D123A 1A P A D124A 1A P A D131A 1A P A D132A 1A P A D133A 1A P A D134A 1A P A D141A 1A P A D142A 1A P A D143A 1A P A D144A 1A P A D151A 1A P A D152A 1A P A D153A 1A P A D154A 1A P A D161A 1A P A D162A 1A P A D163A 1A P A D164A 1A P A D171A 1A P A D172A 1A P A D173A 1A P A D174A 1A P A D211A 1A P A D212A 1A P A D213A 1A P A D214A 1A P A D221A 1A P A D222A 1A P A D223A 1A P A D224A 1A P A D231A 1A P A D232A 1A P A D233A 1A P A D234A 1A P A D241A 1A P A D242A 1A P A D243A 1A P A D244A 1A P A D251A 1A P A D252A 1A P A D253A 1A P A D254A 1A P A D261A 1A P A D262A 1A P A D263A 1A P A D264A 1A P A D271A 1A P A D272A 1A P A D273A 1A P A D274A 1A P A U111A 1A P A U112A 1A P A U113A 1A P A U114A 1A P A U121A 1A P A U122A 1A P A U123A 1A P A U124A 1A P A U131A 1A P A U132A 1A P A U133A 1A P A U134A 1A P A U141A 1A P A U142A 1A P A U143A 1A P A U144A 1A P A U151A 1A P A U152A 1A P A U153A 1A P A U154A 1A P A U161A 1A P A U162A 1A P A U163A 1A P A U164A 1A P A U171A 1A P A U172A 1A P A U173A 1A P A U174A 1A P A U211A 1A P A U212A 1A P A U213A 1A P A U214A 1A P A U221A 1A P A U222A 1A P A U223A 1A P A U224A 1A P A U231A 1A P A U232A 1A P A U233A 1A P A U234A 1A P A U241A 1A P A U242A 1A P A U243A 1A P A U244A 1A P A U251A 1A P A U252A 1A P A U253A 1A P A U254A 1A P A U261A 1A P A U262A 1A P A U263A 1A P A U264A 1A P A U271A 1A P A U272A 1A P A U273A 1A P A U274A 1A P A BORDER1A 1A P A BORDER2A 1A P A BORDER3A 1A P A BORDER4A 1A P A BORDER5A 1A P A BORDER6A 1A P A S0111A 1A P A S0112A 1A P A S0113A 1A P A S0121A 1A P A S0122A 1A P A S0123A 1A P A S0131A 1A P A S0132A 1A P A S0133A 1A P A S0211A 1A P A S0212A 1A P A S0213A 1A P A S0221A 1A P A S0222A 1A P A S0223A 1A P A S0231A 1A P A S0232A 1A P A S0233A 1A P A S0311A 1A P A S0312A 1A P A S0313A 1A P A S0321A 1A P A S0322A 1A P A S0323A 1A P A S0331A 1A P A S0332A 1A P A S0333A 1A P A S0411A 1A P A S0412A 1A P A S0413A 1A P A S0421A 1A P A S0422A 1A P A S0423A 1A P A S0431A 1A P A S0432A 1A P A S0433A 1A P A S0511A 1A P A S0512A 1A P A S0513A 1A P A S0521A 1A P A S0522A 1A P A S0523A 1A P A S0531A 1A P A S0532A 1A P A S0533A 1A P A S0611A 1A P A S0612A 1A P A S0613A 1A P A S0621A 1A P A S0622A 1A P A S0623A 1A P A S0631A 1A P A S0632A 1A P A S0633A 1A P A BORDER7A 1A P A BORDER8A 1A P A BORDER9A 1A P A BORDER10A 1A P A BORDER11A 1A P A BORDER12A 1A P A S0711A 1A P A S0712A 1A P A S0713A 1A P A S0721A 1A P A S0722A 1A P A S0723A 1A P A S0731A 1A P A S0732A 1A P A S0733A 1A P A S0811A 1A P A S0812A 1A P A S0813A 1A P A S0821A 1A P A S0822A 1A P A S0823A 1A P A S0831A 1A P A S0832A 1A P A S0833A 1A P A S0911A 1A P A S0912A 1A P A S0913A 1A P A S0921A 1A P A S0922A 1A P A S0923A 1A P A S0931A 1A P A S0932A 1A P A S0933A 1A P A S1011A 1A P A S1012A 1A P A S1013A 1A P A S1021A 1A P A S1022A 1A P A S1023A 1A P A S1031A 1A P A S1032A 1A P A S1033A 1A P A S1111A 1A P A S1112A 1A P A S1113A 1A P A S1121A 1A P A S1122A 1A P A S1123A 1A P A S1131A 1A P A S1132A 1A P A S1133A 1A P A S1211A 1A P A S1212A 1A P A S1213A 1A P A S1221A 1A P A S1222A 1A P A S1223A 1A P A S1231A 1A P A S1232A 1A P A S1233A 1A P A DEALERMSGA 1A P A YOURMSGA 1A P A 1 3'JCRGMBLJ' A COLOR(BLU) A 1 14'BLACK JACK 21' A COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 3 3'DEALER' A DSPATR(HI) A DEALERMSG 25A O 3 20DSPATR(&DEALERMSGA) A 4 3'_________' A DSPATR(&BORDER1A) A 4 13'_________' A DSPATR(&BORDER2A) * A D111 1A O 4 24DSPATR(&D111A) A D112 1A O 4 26DSPATR(&D112A) A D113 1A O 4 28DSPATR(&D113A) A D114 1A O 4 30DSPATR(&D114A) A D211 1A O 4 33DSPATR(&D211A) A D212 1A O 4 35DSPATR(&D212A) A D213 1A O 4 37DSPATR(&D213A) A D214 1A O 4 39DSPATR(&D214A) A 4 41'_________' A DSPATR(&BORDER3A) A 4 51'_________' A DSPATR(&BORDER4A) A 4 61'_________' A DSPATR(&BORDER5A) A 4 71'_________' A DSPATR(&BORDER6A) A 5 3'|' A DSPATR(&BORDER1A) A S0111 1A O 5 5DSPATR(&S0111A) A S0112 1A O 5 7DSPATR(&S0112A) A S0113 1A O 5 9DSPATR(&S0113A) A 5 11'|' A DSPATR(&BORDER1A) A 5 13'|' A DSPATR(&BORDER2A) A S0211 1A O 5 15DSPATR(&S0211A) A S0212 1A O 5 17DSPATR(&S0212A) A S0213 1A O 5 19DSPATR(&S0213A) A 5 21'|' A DSPATR(&BORDER2A) A D121 1A O 5 24DSPATR(&D121A) A D122 1A O 5 26DSPATR(&D122A) A D123 1A O 5 28DSPATR(&D123A) A D124 1A O 5 30DSPATR(&D124A) A D221 1A O 5 33DSPATR(&D221A) A D222 1A O 5 35DSPATR(&D222A) A D223 1A O 5 37DSPATR(&D223A) A D224 1A O 5 39DSPATR(&D224A) A 5 41'|' A DSPATR(&BORDER3A) A S0311 1A O 5 43DSPATR(&S0311A) A S0312 1A O 5 45DSPATR(&S0312A) A S0313 1A O 5 47DSPATR(&S0313A) A 5 49'|' A DSPATR(&BORDER3A) A 5 51'|' A DSPATR(&BORDER4A) A S0411 1A O 5 53DSPATR(&S0411A) A S0412 1A O 5 55DSPATR(&S0412A) A S0413 1A O 5 57DSPATR(&S0413A) A 5 59'|' A DSPATR(&BORDER4A) A 5 61'|' A DSPATR(&BORDER5A) A S0511 1A O 5 63DSPATR(&S0511A) A S0512 1A O 5 65DSPATR(&S0512A) A S0513 1A O 5 67DSPATR(&S0513A) A 5 69'|' A DSPATR(&BORDER5A) A 5 71'|' A DSPATR(&BORDER6A) A S0611 1A O 5 73DSPATR(&S0611A) A S0612 1A O 5 75DSPATR(&S0612A) A S0613 1A O 5 77DSPATR(&S0613A) A 5 79'|' A DSPATR(&BORDER6A) A 6 3'|' A DSPATR(&BORDER1A) A S0121 1A O 6 5DSPATR(&S0121A) A S0122 1A O 6 7DSPATR(&S0122A) A S0123 1A O 6 9DSPATR(&S0123A) A 6 11'|' A DSPATR(&BORDER1A) A 6 13'|' A DSPATR(&BORDER2A) A S0221 1A O 6 15DSPATR(&S0221A) A S0222 1A O 6 17DSPATR(&S0222A) A S0223 1A O 6 19DSPATR(&S0223A) A 6 21'|' A DSPATR(&BORDER2A) A D131 1A O 6 24DSPATR(&D131A) A D132 1A O 6 26DSPATR(&D132A) A D133 1A O 6 28DSPATR(&D133A) A D134 1A O 6 30DSPATR(&D134A) A D231 1A O 6 33DSPATR(&D231A) A D232 1A O 6 35DSPATR(&D232A) A D233 1A O 6 37DSPATR(&D233A) A D234 1A O 6 39DSPATR(&D234A) A 6 41'|' A DSPATR(&BORDER3A) A S0321 1A O 6 43DSPATR(&S0321A) A S0322 1A O 6 45DSPATR(&S0322A) A S0323 1A O 6 47DSPATR(&S0323A) A 6 49'|' A DSPATR(&BORDER3A) A 6 51'|' A DSPATR(&BORDER4A) A S0421 1A O 6 53DSPATR(&S0421A) A S0422 1A O 6 55DSPATR(&S0422A) A S0423 1A O 6 57DSPATR(&S0423A) A 6 59'|' A DSPATR(&BORDER4A) A 6 61'|' A DSPATR(&BORDER5A) A S0521 1A O 6 63DSPATR(&S0521A) A S0522 1A O 6 65DSPATR(&S0522A) A S0523 1A O 6 67DSPATR(&S0523A) A 6 69'|' A DSPATR(&BORDER5A) A 6 71'|' A DSPATR(&BORDER6A) A S0621 1A O 6 73DSPATR(&S0621A) A S0622 1A O 6 75DSPATR(&S0622A) A S0623 1A O 6 77DSPATR(&S0623A) A 6 79'|' A DSPATR(&BORDER6A) A 7 3'|' A DSPATR(&BORDER1A) A S0131 1A O 7 5DSPATR(&S0131A) A S0132 1A O 7 7DSPATR(&S0132A) A S0133 1A O 7 9DSPATR(&S0133A) A 7 11'|' A DSPATR(&BORDER1A) A 7 13'|' A DSPATR(&BORDER2A) A S0231 1A O 7 15DSPATR(&S0231A) A S0232 1A O 7 17DSPATR(&S0232A) A S0233 1A O 7 19DSPATR(&S0233A) A 7 21'|' A DSPATR(&BORDER2A) A D141 1A O 7 24DSPATR(&D141A) A D142 1A O 7 26DSPATR(&D142A) A D143 1A O 7 28DSPATR(&D143A) A D144 1A O 7 30DSPATR(&D144A) A D241 1A O 7 33DSPATR(&D241A) A D242 1A O 7 35DSPATR(&D242A) A D243 1A O 7 37DSPATR(&D243A) A D244 1A O 7 39DSPATR(&D244A) A 7 41'|' A DSPATR(&BORDER3A) A S0331 1A O 7 43DSPATR(&S0331A) A S0332 1A O 7 45DSPATR(&S0332A) A S0333 1A O 7 47DSPATR(&S0333A) A 7 49'|' A DSPATR(&BORDER3A) A 7 51'|' A DSPATR(&BORDER4A) A S0431 1A O 7 53DSPATR(&S0431A) A S0432 1A O 7 55DSPATR(&S0432A) A S0433 1A O 7 57DSPATR(&S0433A) A 7 59'|' A DSPATR(&BORDER4A) A 7 61'|' A DSPATR(&BORDER5A) A S0531 1A O 7 63DSPATR(&S0531A) A S0532 1A O 7 65DSPATR(&S0532A) A S0533 1A O 7 67DSPATR(&S0533A) A 7 69'|' A DSPATR(&BORDER5A) A 7 71'|' A DSPATR(&BORDER6A) A S0631 1A O 7 73DSPATR(&S0631A) A S0632 1A O 7 75DSPATR(&S0632A) A S0633 1A O 7 77DSPATR(&S0633A) A 7 79'|' A DSPATR(&BORDER6A) A 8 3'|_______|' A DSPATR(&BORDER1A) A 8 13'|_______|' A DSPATR(&BORDER2A) A D151 1A O 8 24DSPATR(&D151A) A D152 1A O 8 26DSPATR(&D152A) A D153 1A O 8 28DSPATR(&D153A) A D154 1A O 8 30DSPATR(&D154A) A D251 1A O 8 33DSPATR(&D251A) A D252 1A O 8 35DSPATR(&D252A) A D253 1A O 8 37DSPATR(&D253A) A D254 1A O 8 39DSPATR(&D254A) A 8 41'|_______|' A DSPATR(&BORDER3A) A 8 51'|_______|' A DSPATR(&BORDER4A) A 8 61'|_______|' A DSPATR(&BORDER5A) A 8 71'|_______|' A DSPATR(&BORDER6A) A D161 1A O 9 24DSPATR(&D161A) A D162 1A O 9 26DSPATR(&D162A) A D163 1A O 9 28DSPATR(&D163A) A D164 1A O 9 30DSPATR(&D164A) A D261 1A O 9 33DSPATR(&D261A) A D262 1A O 9 35DSPATR(&D262A) A D263 1A O 9 37DSPATR(&D263A) A D264 1A O 9 39DSPATR(&D264A) A D171 1A O 10 24DSPATR(&D171A) A D172 1A O 10 26DSPATR(&D172A) A D173 1A O 10 28DSPATR(&D173A) A D174 1A O 10 30DSPATR(&D174A) A D271 1A O 10 33DSPATR(&D271A) A D272 1A O 10 35DSPATR(&D272A) A D273 1A O 10 37DSPATR(&D273A) A D274 1A O 10 39DSPATR(&D274A) A 12 3'--------------' A 13 3'_________' A DSPATR(&BORDER7A) A 13 13'_________' A DSPATR(&BORDER8A) * A U111 1A O 13 24DSPATR(&U111A) A U112 1A O 13 26DSPATR(&U112A) A U113 1A O 13 28DSPATR(&U113A) A U114 1A O 13 30DSPATR(&U114A) A U211 1A O 13 33DSPATR(&U211A) A U212 1A O 13 35DSPATR(&U212A) A U213 1A O 13 37DSPATR(&U213A) A U214 1A O 13 39DSPATR(&U214A) A 14 3'|' A DSPATR(&BORDER7A) A S0711 1A O 14 5DSPATR(&S0711A) A S0712 1A O 14 7DSPATR(&S0712A) A S0713 1A O 14 9DSPATR(&S0713A) A 14 11'|' A DSPATR(&BORDER7A) A 14 13'|' A DSPATR(&BORDER8A) A S0811 1A O 14 15DSPATR(&S0811A) A S0812 1A O 14 17DSPATR(&S0812A) A S0813 1A O 14 19DSPATR(&S0813A) A 14 21'|' A DSPATR(&BORDER8A) A U121 1A O 14 24DSPATR(&U121A) A U122 1A O 14 26DSPATR(&U122A) A U123 1A O 14 28DSPATR(&U123A) A U124 1A O 14 30DSPATR(&U124A) A U221 1A O 14 33DSPATR(&U221A) A U222 1A O 14 35DSPATR(&U222A) A U223 1A O 14 37DSPATR(&U223A) A U224 1A O 14 39DSPATR(&U224A) A 14 41'_________' A DSPATR(&BORDER9A) A 14 51'_________' A DSPATR(&BORDER10A) A 14 61'_________' A DSPATR(&BORDER11A) A 14 71'_________' A DSPATR(&BORDER12A) A 15 3'|' A DSPATR(&BORDER7A) A S0721 1A O 15 5DSPATR(&S0721A) A S0722 1A O 15 7DSPATR(&S0722A) A S0723 1A O 15 9DSPATR(&S0723A) A 15 11'|' A DSPATR(&BORDER7A) A 15 13'|' A DSPATR(&BORDER8A) A S0821 1A O 15 15DSPATR(&S0821A) A S0822 1A O 15 17DSPATR(&S0822A) A S0823 1A O 15 19DSPATR(&S0823A) A 15 21'|' A DSPATR(&BORDER8A) A U131 1A O 15 24DSPATR(&U131A) A U132 1A O 15 26DSPATR(&U132A) A U133 1A O 15 28DSPATR(&U133A) A U134 1A O 15 30DSPATR(&U134A) A U231 1A O 15 33DSPATR(&U231A) A U232 1A O 15 35DSPATR(&U232A) A U233 1A O 15 37DSPATR(&U233A) A U234 1A O 15 39DSPATR(&U234A) A 15 41'|' A DSPATR(&BORDER9A) A S0911 1A O 15 43DSPATR(&S0911A) A S0912 1A O 15 45DSPATR(&S0912A) A S0913 1A O 15 47DSPATR(&S0913A) A 15 49'|' A DSPATR(&BORDER9A) A 15 51'|' A DSPATR(&BORDER10A) A S1011 1A O 15 53DSPATR(&S1011A) A S1012 1A O 15 55DSPATR(&S1012A) A S1013 1A O 15 57DSPATR(&S1013A) A 15 59'|' A DSPATR(&BORDER10A) A 15 61'|' A DSPATR(&BORDER11A) A S1111 1A O 15 63DSPATR(&S1111A) A S1112 1A O 15 65DSPATR(&S1112A) A S1113 1A O 15 67DSPATR(&S1113A) A 15 69'|' A DSPATR(&BORDER11A) A 15 71'|' A DSPATR(&BORDER12A) A S1211 1A O 15 73DSPATR(&S1211A) A S1212 1A O 15 75DSPATR(&S1212A) A S1213 1A O 15 77DSPATR(&S1213A) A 15 79'|' A DSPATR(&BORDER12A) A 16 3'|' A DSPATR(&BORDER7A) A S0731 1A O 16 5DSPATR(&S0731A) A S0732 1A O 16 7DSPATR(&S0732A) A S0733 1A O 16 9DSPATR(&S0733A) A 16 11'|' A DSPATR(&BORDER7A) A 16 13'|' A DSPATR(&BORDER8A) A S0831 1A O 16 15DSPATR(&S0831A) A S0832 1A O 16 17DSPATR(&S0832A) A S0833 1A O 16 19DSPATR(&S0833A) A 16 21'|' A DSPATR(&BORDER8A) A U141 1A O 16 24DSPATR(&U141A) A U142 1A O 16 26DSPATR(&U142A) A U143 1A O 16 28DSPATR(&U143A) A U144 1A O 16 30DSPATR(&U144A) A U241 1A O 16 33DSPATR(&U241A) A U242 1A O 16 35DSPATR(&U242A) A U243 1A O 16 37DSPATR(&U243A) A U244 1A O 16 39DSPATR(&U244A) A 16 41'|' A DSPATR(&BORDER9A) A S0921 1A O 16 43DSPATR(&S0921A) A S0922 1A O 16 45DSPATR(&S0922A) A S0923 1A O 16 47DSPATR(&S0923A) A 16 49'|' A DSPATR(&BORDER9A) A 16 51'|' A DSPATR(&BORDER10A) A S1021 1A O 16 53DSPATR(&S1021A) A S1022 1A O 16 55DSPATR(&S1022A) A S1023 1A O 16 57DSPATR(&S1023A) A 16 59'|' A DSPATR(&BORDER10A) A 16 61'|' A DSPATR(&BORDER11A) A S1121 1A O 16 63DSPATR(&S1121A) A S1122 1A O 16 65DSPATR(&S1122A) A S1123 1A O 16 67DSPATR(&S1123A) A 16 69'|' A DSPATR(&BORDER11A) A 16 71'|' A DSPATR(&BORDER12A) A S1221 1A O 16 73DSPATR(&S1221A) A S1222 1A O 16 75DSPATR(&S1222A) A S1223 1A O 16 77DSPATR(&S1223A) A 16 79'|' A DSPATR(&BORDER12A) A 17 3'|_______|' A DSPATR(&BORDER7A) A 17 13'|_______|' A DSPATR(&BORDER8A) A U151 1A O 17 24DSPATR(&U151A) A U152 1A O 17 26DSPATR(&U152A) A U153 1A O 17 28DSPATR(&U153A) A U154 1A O 17 30DSPATR(&U154A) A U251 1A O 17 33DSPATR(&U251A) A U252 1A O 17 35DSPATR(&U252A) A U253 1A O 17 37DSPATR(&U253A) A U254 1A O 17 39DSPATR(&U254A) A 17 41'|' A DSPATR(&BORDER9A) A S0931 1A O 17 43DSPATR(&S0931A) A S0932 1A O 17 45DSPATR(&S0932A) A S0933 1A O 17 47DSPATR(&S0933A) A 17 49'|' A DSPATR(&BORDER9A) A 17 51'|' A DSPATR(&BORDER10A) A S1031 1A O 17 53DSPATR(&S1031A) A S1032 1A O 17 55DSPATR(&S1032A) A S1033 1A O 17 57DSPATR(&S1033A) A 17 59'|' A DSPATR(&BORDER10A) A 17 61'|' A DSPATR(&BORDER11A) A S1131 1A O 17 63DSPATR(&S1131A) A S1132 1A O 17 65DSPATR(&S1132A) A S1133 1A O 17 67DSPATR(&S1133A) A 17 69'|' A DSPATR(&BORDER11A) A 17 71'|' A DSPATR(&BORDER12A) A S1231 1A O 17 73DSPATR(&S1231A) A S1232 1A O 17 75DSPATR(&S1232A) A S1233 1A O 17 77DSPATR(&S1233A) A 17 79'|' A DSPATR(&BORDER12A) A U161 1A O 18 24DSPATR(&U161A) A U162 1A O 18 26DSPATR(&U162A) A U163 1A O 18 28DSPATR(&U163A) A U164 1A O 18 30DSPATR(&U164A) A U261 1A O 18 33DSPATR(&U261A) A U262 1A O 18 35DSPATR(&U262A) A U263 1A O 18 37DSPATR(&U263A) A U264 1A O 18 39DSPATR(&U264A) A 18 41'|_______|' A DSPATR(&BORDER9A) A 18 51'|_______|' A DSPATR(&BORDER10A) A 18 61'|_______|' A DSPATR(&BORDER11A) A 18 71'|_______|' A DSPATR(&BORDER12A) A U171 1A O 19 24DSPATR(&U171A) A U172 1A O 19 26DSPATR(&U172A) A U173 1A O 19 28DSPATR(&U173A) A U174 1A O 19 30DSPATR(&U174A) A U271 1A O 19 33DSPATR(&U271A) A U272 1A O 19 35DSPATR(&U272A) A U273 1A O 19 37DSPATR(&U273A) A U274 1A O 19 39DSPATR(&U274A) A 21 3'PLAYER' A DSPATR(HI) A YOURMSG 25A O 21 20DSPATR(&YOURMSGA) A 23 53'Bet' A COLOR(BLU) A 23 62'Credits' A COLOR(BLU) A 24 2'F3=Exit' A COLOR(BLU) A 24 15'Enter=Hit Me!' A COLOR(BLU) A 06 24 33'F2=Stand' A COLOR(BLU) A YOUBET 3Y 0O 24 53EDTCDE(4) A DSPATR(HI) A CREDITS 5Y 0O 24 63EDTCDE(L) A DSPATR(HI) ]]> v5r4 //--------------------------------------------------------- // JCRGMBTL - BattleShip //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMBTLD cf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D Col s 3u 0 D Colx s 3u 0 D ForCount s 3u 0 D HashCol s 3u 0 dim(51) D HashRow s 3u 0 dim(51) D Row s 3u 0 D Rowx s 3u 0 D TimesHit2 s 3u 0 D TimesHit3 s 3u 0 D TimesHit4 s 3u 0 D TimesHit5 s 3u 0 D UserxHit2 s 3u 0 D UserxHit3 s 3u 0 D UserxHit4 s 3u 0 D UserxHit5 s 3u 0 D WhereHitCol1 s 3u 0 D WhereHitCol2 s 3u 0 D WhereHitRow1 s 3u 0 D WhereHitRow2 s 3u 0 D xx s 3u 0 D yy s 3u 0 D IsCollision s n D IsDeployed s n D IsGoodRowCol s n D IsHit s n D IsHitFirst s n D IsHitSecond s n D Left c 1 D Right c 2 D Up c 3 D Down c 4 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Infds /Define Dspatr /Define FunctionKeys /Define QsnGetCsrAdr /Define f_GetRandom /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D Deployed ds dim(10) qualified D Col 1a dim(10) D Attack ds dim(10) likeds(Deployed) based(Ptr) enemy screen fields D Ptr s * inz(%addr(r01c01)) D AttackA ds dim(10) likeds(Deployed) based(Ptr2) enemy attrib array D Ptr2 s * inz(%addr(atr0101)) D Defend ds dim(10) likeds(Deployed) based(Ptr3) defend screen flds D Ptr3 s * inz(%addr(b01c01)) D DefendA ds dim(10) likeds(Deployed) based(Ptr4) defend attrib array D Ptr4 s * inz(%addr(btr0101)) D DefendSave ds dim(10) likeds(Deployed) // map screen fields into DS so arrays can manipulate values D ScreenDS ds D R01C01 D R01C02 D R01C03 D R01C04 D R01C05 D R01C06 D R01C07 D R01C08 D R01C09 D R01C10 D R02C01 D R02C02 D R02C03 D R02C04 D R02C05 D R02C06 D R02C07 D R02C08 D R02C09 D R02C10 D R03C01 D R03C02 D R03C03 D R03C04 D R03C05 D R03C06 D R03C07 D R03C08 D R03C09 D R03C10 D R04C01 D R04C02 D R04C03 D R04C04 D R04C05 D R04C06 D R04C07 D R04C08 D R04C09 D R04C10 D R05C01 D R05C02 D R05C03 D R05C04 D R05C05 D R05C06 D R05C07 D R05C08 D R05C09 D R05C10 D R06C01 D R06C02 D R06C03 D R06C04 D R06C05 D R06C06 D R06C07 D R06C08 D R06C09 D R06C10 D R07C01 D R07C02 D R07C03 D R07C04 D R07C05 D R07C06 D R07C07 D R07C08 D R07C09 D R07C10 D R08C01 D R08C02 D R08C03 D R08C04 D R08C05 D R08C06 D R08C07 D R08C08 D R08C09 D R08C10 D R09C01 D R09C02 D R09C03 D R09C04 D R09C05 D R09C06 D R09C07 D R09C08 D R09C09 D R09C10 D R10C01 D R10C02 D R10C03 D R10C04 D R10C05 D R10C06 D R10C07 D R10C08 D R10C09 D R10C10 D ATR0101 D ATR0102 D ATR0103 D ATR0104 D ATR0105 D ATR0106 D ATR0107 D ATR0108 D ATR0109 D ATR0110 D ATR0201 D ATR0202 D ATR0203 D ATR0204 D ATR0205 D ATR0206 D ATR0207 D ATR0208 D ATR0209 D ATR0210 D ATR0301 D ATR0302 D ATR0303 D ATR0304 D ATR0305 D ATR0306 D ATR0307 D ATR0308 D ATR0309 D ATR0310 D ATR0401 D ATR0402 D ATR0403 D ATR0404 D ATR0405 D ATR0406 D ATR0407 D ATR0408 D ATR0409 D ATR0410 D ATR0501 D ATR0502 D ATR0503 D ATR0504 D ATR0505 D ATR0506 D ATR0507 D ATR0508 D ATR0509 D ATR0510 D ATR0601 D ATR0602 D ATR0603 D ATR0604 D ATR0605 D ATR0606 D ATR0607 D ATR0608 D ATR0609 D ATR0610 D ATR0701 D ATR0702 D ATR0703 D ATR0704 D ATR0705 D ATR0706 D ATR0707 D ATR0708 D ATR0709 D ATR0710 D ATR0801 D ATR0802 D ATR0803 D ATR0804 D ATR0805 D ATR0806 D ATR0807 D ATR0808 D ATR0809 D ATR0810 D ATR0901 D ATR0902 D ATR0903 D ATR0904 D ATR0905 D ATR0906 D ATR0907 D ATR0908 D ATR0909 D ATR0910 D ATR1001 D ATR1002 D ATR1003 D ATR1004 D ATR1005 D ATR1006 D ATR1007 D ATR1008 D ATR1009 D ATR1010 D B01C01 D B01C02 D B01C03 D B01C04 D B01C05 D B01C06 D B01C07 D B01C08 D B01C09 D B01C10 D B02C01 D B02C02 D B02C03 D B02C04 D B02C05 D B02C06 D B02C07 D B02C08 D B02C09 D B02C10 D B03C01 D B03C02 D B03C03 D B03C04 D B03C05 D B03C06 D B03C07 D B03C08 D B03C09 D B03C10 D B04C01 D B04C02 D B04C03 D B04C04 D B04C05 D B04C06 D B04C07 D B04C08 D B04C09 D B04C10 D B05C01 D B05C02 D B05C03 D B05C04 D B05C05 D B05C06 D B05C07 D B05C08 D B05C09 D B05C10 D B06C01 D B06C02 D B06C03 D B06C04 D B06C05 D B06C06 D B06C07 D B06C08 D B06C09 D B06C10 D B07C01 D B07C02 D B07C03 D B07C04 D B07C05 D B07C06 D B07C07 D B07C08 D B07C09 D B07C10 D B08C01 D B08C02 D B08C03 D B08C04 D B08C05 D B08C06 D B08C07 D B08C08 D B08C09 D B08C10 D B09C01 D B09C02 D B09C03 D B09C04 D B09C05 D B09C06 D B09C07 D B09C08 D B09C09 D B09C10 D B10C01 D B10C02 D B10C03 D B10C04 D B10C05 D B10C06 D B10C07 D B10C08 D B10C09 D B10C10 D BTR0101 D BTR0102 D BTR0103 D BTR0104 D BTR0105 D BTR0106 D BTR0107 D BTR0108 D BTR0109 D BTR0110 D BTR0201 D BTR0202 D BTR0203 D BTR0204 D BTR0205 D BTR0206 D BTR0207 D BTR0208 D BTR0209 D BTR0210 D BTR0301 D BTR0302 D BTR0303 D BTR0304 D BTR0305 D BTR0306 D BTR0307 D BTR0308 D BTR0309 D BTR0310 D BTR0401 D BTR0402 D BTR0403 D BTR0404 D BTR0405 D BTR0406 D BTR0407 D BTR0408 D BTR0409 D BTR0410 D BTR0501 D BTR0502 D BTR0503 D BTR0504 D BTR0505 D BTR0506 D BTR0507 D BTR0508 D BTR0509 D BTR0510 D BTR0601 D BTR0602 D BTR0603 D BTR0604 D BTR0605 D BTR0606 D BTR0607 D BTR0608 D BTR0609 D BTR0610 D BTR0701 D BTR0702 D BTR0703 D BTR0704 D BTR0705 D BTR0706 D BTR0707 D BTR0708 D BTR0709 D BTR0710 D BTR0801 D BTR0802 D BTR0803 D BTR0804 D BTR0805 D BTR0806 D BTR0807 D BTR0808 D BTR0809 D BTR0810 D BTR0901 D BTR0902 D BTR0903 D BTR0904 D BTR0905 D BTR0906 D BTR0907 D BTR0908 D BTR0909 D BTR0910 D BTR1001 D BTR1002 D BTR1003 D BTR1004 D BTR1005 D BTR1006 D BTR1007 D BTR1008 D BTR1009 D BTR1010 //--*FUNCTION PROTOTYPES----------------------------------- D f_MoveReticle PR n D 3u 0 D 3u 0 D 3u 0 const D 3a const D f_MultNextHit PR n D 3u 0 const Df_SingleNextHit PR D f_DropBombOnX PR D 3u 0 D 3u 0 D f_GenerateDeployment... D PR D f_UpdateHits PR D 3u 0 row D 3u 0 col Db likeds(Defend) dim(10) grid row Db likeds(DefendA) dim(10) grid attr Db likeds(DefendSave) dim(10) gird save D 1a hit attr2 D 1a hit attr3 D 1a hit attr4 D 1a hit attr5 D 3u 0 hit cnt 2 D 3u 0 hit cnt 3 D 3u 0 hit cnt 4 D 3u 0 hit cnt 5 //--*ENTRY PARMS *NONE* ----------------------------------- /free exsr srSetupUserShips; 1b dou 1 = 2; exfmt SCREEN2; // get cursor Row and Column QsnGetCsrAdr(QsnCursorRow: QsnCursorCol: 0: ApiErrDS); csrRow = QsnCursorRow; cSrCol = QsnCursorCol; // F9 = Restart 2b if InfdsFkey = f09; exsr srSetupUserShips; 1i iter; 2e endif; 2b if InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; // Process users attack, then let computer have shot at it! exsr srUserAttack; exsr srComputerAttack; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // Spin through Rows and Columns looking for attacks. begsr srUserAttack; 1b for Row = 1 to 10; 2b for Col = 1 to 10; 3b if Attack(Row).Col(Col) = 'X'; 4b if Deployed(Row).Col(Col) = ' '; Attack(Row).Col(Col) = '.'; AttackA(Row).Col(Col) = %bitor(BLUE: PR); 4x else; f_UpdateHits(Row: Col: Attack: AttackA: Deployed: edspatr2: edspatr3: edspatr4: edspatr5: UserxHit2: UserxHit3: UserxHit4: UserxHit5); 4e endif; 3e endif; 2e endfor; 1e endfor; // Check and see if ALL enemy ships are sunk. 1b if UserxHit2 = 9 and UserxHit3 = 9 and UserxHit4 = 9 and UserxHit5 = 9; GameOver = 'CONGRATULATIONS! YOU WIN!'; aGameover = %bitor(Green: RI); 1e endif; endsr; //--------------------------------------------------------- // Blow users stuff outta the water!! // Until computer gets hit, it uses hash table to // select random shots from list of not-hit locations. // // Computer will spin down users defend array looking // for place it has already gotten a hit. When it finds one // check all adjacent Row/Columns for un-hit space // If one is found, FIRE ONE! If no hits are found or all // adjacent places are filled, continue with hash table random. // Three different types of activity. // 1. Multiple Hits detected. // 2. Single Hit Detected. // 3. No hits detected. begsr srComputerAttack; WhereHitRow1 = 0; WhereHitCol1 = 0; WhereHitRow2 = 0; WhereHitCol2 = 0; IsHitFirst = *off; IsHitSecond = *off; IsHit = *off; // analyze previous hits 1b for Row = 1 to 10; 2b for Col = 1 to 10; 3b if Defend(Row).Col(Col) = 'H'; 4b if WhereHitRow1 = 0; WhereHitRow1 = Row; WhereHitCol1 = Col; IsHitFirst = *on; 4x else; WhereHitRow2 = Row; WhereHitCol2 = Col; IsHitSecond = *on; 2v leave; 4e endif; 3e endif; 2e endfor; 2b if IsHitSecond; 1v leave; 2e endif; 1e endfor; //--------------------------------------------------------- // Single Hit - Fire on next random contiguous grid location. 1b if IsHitFirst and not IsHitSecond; f_SingleNextHit(); //--------------------------------------------------------- // Multiple Hits - Run Left, then Right, Up, then Down to get next hit 1x elseif IsHitFirst and IsHitSecond; 2b if WhereHitRow1 = WhereHitRow2; IsHit = f_MultNextHit(LEFT); 3b if not IsHit; IsHit = f_MultNextHit(RIGHT); 3e endif; 2e endif; 2b if WhereHitCol1 = WhereHitCol2 or (not IsHit); //side by side boats IsHit = f_MultNextHit(UP); 3b if not IsHit; IsHit = f_MultNextHit(DOWN); 3e endif; 2e endif; //--------------------------------------------------------- // If multiple hits on-screen, but preceding section // could not find new hit, then there are two ships // side-by-side. Try to hit first ship with another shot. 2b if not IsHit; f_SingleNextHit(); 2e endif; 1x else; //--------------------------------------------------------- // Nothing has been hit yet. // Load hash table with all even un-hit indexes. // Use random value (with upper limit = count of available indexes.) // to access hash table entry containing index to be targeted. yy = 0; 2b for Row = 1 to 10; 3b for Col = 1 to 10; 4b if not (Defend(Row).Col(Col) = 'm' or Defend(Row).Col(Col) = 'H' or Defend(Row).Col(Col) = 'S'); 5b if %rem(Row + Col: 2) = 0; yy += 1; HashRow(yy) = Row; HashCol(yy) = Col; 5e endif; 4e endif; 3e endfor; 2e endfor; 2b if yy > 0; xx = f_GetRandom(yy); f_DropBombOnX(HashRow(xx): HashCol(xx)); 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Let user set up right side ship locations. begsr srSetupUserShips; csrRow = 5; cSrCol = 8; BlueRi = %bitor(WHITE: RI); RedRi = %bitor(RED: RI); Attack(*) = *all' '; AttackA(*) = *allx'00'; Deployed(*) = *all' '; // load big F5 to grid so player knows what button to hit Defend(1) = 'FFFF 55555'; Defend(2) = 'FFFF 55555'; Defend(3) = 'FF 55 '; Defend(4) = 'FF 55 '; Defend(5) = 'FFF 555 '; Defend(6) = 'FFF 555 '; Defend(7) = 'FF 55'; Defend(8) = 'FF 55'; Defend(9) = 'FF 5555 '; Defend(10) = 'FF 555 '; 1b for row = 1 to 10; 2b for col = 1 to 10; 3b if Defend(row).Col(col) = ' '; Defend(row).Col(col) = '.'; DefendA(row).Col(col) = Blue; 3x else; DefendA(row).Col(col) = %bitor(Blue: RI); 3e endif; 2e endfor; 1e endfor; TimesHit2 = 0; TimesHit3 = 0; TimesHit4 = 0; TimesHit5 = 0; Udspatr2 = x'00'; Udspatr3 = x'00'; Udspatr4 = x'00'; Udspatr5 = x'00'; UserxHit2 = 0; UserxHit3 = 0; UserxHit4 = 0; UserxHit5 = 0; edspatr2 = x'00'; edspatr3 = x'00'; edspatr4 = x'00'; edspatr5 = x'00'; GameOver = *blanks; aGameover = ND; aDeployMsg = ND; IsDeployed = *off; evalr scDow = %trimr(f_GetDayName()); 1b dou 1 = 2; exfmt SCREEN1; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; aDeployMsg = ND; //--------------------------------------------------------- // Computer generate defense grid layout. 2b if InfdsFkey = f05; f_GenerateDeployment(); Defend(*) = Deployed(*); BlueRi = %bitor(Blue: RI); RedRi = %bitor(Blue: RI); 3b for Row = 1 to 10; 4b for Col = 1 to 10; 5b if Defend(Row).Col(Col) = ' '; Defend(Row).Col(Col) = '.'; DefendA(Row).Col(Col) = BLUE; 5x else; 6b if Defend(Row).Col(Col) = '2'; DefendA(Row).Col(Col) = %bitor(Turq: RI); 6x elseif Defend(Row).Col(Col) = '3'; DefendA(Row).Col(Col) = %bitor(Yellow: RI); 6x elseif Defend(Row).Col(Col) = '4'; DefendA(Row).Col(Col) = %bitor(PINK: RI); 6x elseif Defend(Row).Col(Col) = '5'; DefendA(Row).Col(Col) = %bitor(RED: RI); 6e endif; 5e endif; 4e endfor; 3e endfor; IsDeployed = *on; 1i iter; 2x else; //--------------------------------------------------------- // Let battle begin. turn all ships reverse image green for stealth 3b if IsDeployed; 4b for Row = 1 to 10; 5b for Col = 1 to 10; 6b if Defend(Row).Col(Col) <>'.'; DefendA(Row).Col(Col) = %bitor(Green: RI); 6e endif; 5e endfor; 4e endfor; 1v leave; 3x else; aDeployMsg = %bitor(Green: RI); 1i iter; 3e endif; 2e endif; 1e enddo; DefendSave(*) = Defend(*); //Save for sunk placement f_GenerateDeployment(); //Set random left side ships endsr; /end-free //--------------------------------------------------------- // Find next random location to hit after single hit Pf_SingleNextHit B Df_SingleNextHit PI /free 1b dou IsGoodRowCol; Row = WhereHitRow1; Col = WhereHitCol1; IsGoodRowCol = f_MoveReticle(Row: Col: f_GetRandom(4): 'SGL'); 2b if IsGoodRowCol; f_DropBombOnX(Row: Col); return; 2e endif; 1e enddo; /end-free Pf_SingleNextHit E //--------------------------------------------------------- // Find next location to nuke after multiple hits P f_MultNextHit B D f_MultNextHit PI n D p_Vector 3u 0 const /free Row = WhereHitRow1; Col = WhereHitCol1; 1b dou not IsGoodRowCol; IsGoodRowCol = f_MoveReticle(Row: Col: p_Vector: 'MLT'); 2b if IsGoodRowCol and Defend(Row).Col(Col) <> 'H'; f_DropBombOnX(Row: Col); return *on; 2e endif; 1e enddo; return *off; /end-free P f_MultNextHit E //--------------------------------------------------------- // Update Hits on grid and set display attributes P f_UpdateHits B D f_UpdateHits PI D Row 3u 0 D Col 3u 0 D GridRow likeds(Defend) dim(10) D GridRowA likeds(DefendA) dim(10) D GridSave likeds(DefendSave) dim(10) D HitAttr2 1a D HitAttr3 1a D HitAttr4 1a D HitAttr5 1a D HitCount2 3u 0 D HitCount3 3u 0 D HitCount4 3u 0 D HitCount5 3u 0 D Rowx s 3u 0 D Colx s 3u 0 /free 1b if GridSave(Row).Col(Col) = '2'; HitAttr2 = %bitor(YELLOW: RI); HitCount2 += 1; 1x elseif GridSave(Row).Col(Col) = '3'; HitAttr3 = %bitor(YELLOW: RI); HitCount3 += 1; 1x elseif GridSave(Row).Col(Col) = '4'; HitAttr4 = %bitor(YELLOW: RI); HitCount4 += 1; 1x elseif GridSave(Row).Col(Col) = '5'; HitAttr5 = %bitor(YELLOW: RI); HitCount5 += 1; 1e endif; 1b if HitCount2 = 2; HitAttr2 = RED; exsr srSetToSunk; HitCount2 = 9; 1x elseif HitCount3 = 3; HitAttr3 = RED; exsr srSetToSunk; HitCount3 = 9; 1x elseif HitCount4 = 4; HitAttr4 = RED; exsr srSetToSunk; HitCount4 = 9; 1x elseif HitCount5 = 5; HitAttr5 = RED; exsr srSetToSunk; HitCount5 = 9; 1x else; GridRow(Row).Col(Col) = 'H'; GridRowA(Row).Col(Col) = %bitor(YELLOW: RI); 1e endif; //--------------------------------------------------------- // if totally sunk, turn to 'S' and Red Color begsr srSetToSunk; 1b for Rowx = 1 to 10; 2b for Colx = 1 to 10; 3b if GridSave(Rowx).Col(Colx) = GridSave(Row).Col(Col); GridRow(Rowx).Col(Colx) = 'S'; GridRowA(Rowx).Col(Colx) = %bitor(RED: RI); 3e endif; 2e endfor; 1e endfor; endsr; /end-free P f_UpdateHits e //--------------------------------------------------------- // Unload the BOMB!!! P f_DropBombOnX B D f_DropBombOnX PI D Row 3u 0 D Col 3u 0 D Rowx s 3u 0 D Colx s 3u 0 /free 1b if Defend(Row).Col(Col) = '.'; Defend(Row).Col(Col) = 'm'; DefendA(Row).Col(Col) = %bitor(BLUE: RI); 1x else; f_UpdateHits(Row: Col: Defend: DefendA: DefendSave: udspatr2: udspatr3: udspatr4: udspatr5: TimesHit2: TimesHit3: TimesHit4: TimesHit5); 1e endif; //--------------------------------------------------------- // Check and see if ALL user ships are sunk. // Set loser indicator and show where remaining computer ships are located. 1b if TimesHit2 = 9 and TimesHit3 = 9 and TimesHit4 = 9 and TimesHit5 = 9; GameOver = 'LOSER! PRESS F9 TO RESTART.'; aGameover = %bitor(Green: RI); 2b for Rowx = 1 to 10; 3b for Colx = 1 to 10; 4b if Attack(Rowx).Col(Colx) = ' '; Attack(Rowx).Col(Colx) = Deployed(Rowx).Col(Colx); 4e endif; 3e endfor; 2e endfor; 1e endif; /end-free P f_DropBombOnX E //--------------------------------------------------------- // Return *off if next Row/Col not valid target. P f_MoveReticle B D f_MoveReticle PI n D Row 3u 0 D Col 3u 0 D Direction 3u 0 const D TypeScan 3a const /free // move targeting reticule one in selected direction 1b if Direction = UP; Row -= 1; 1x elseif Direction = DOWN; Row += 1; 1x elseif Direction = LEFT; Col -= 1; 1x elseif Direction = RIGHT; Col += 1; 1e endif; 1b if Row = 0 or Row = 11 or Col = 0 or Col = 11 or Defend(Row).Col(Col) = 'S' or Defend(Row).Col(Col) = 'm' or (Defend(Row).Col(Col) = 'H' and TypeScan = 'SGL'); return *off; 1e endif; return *on; /end-free P f_MoveReticle E //--------------------------------------------------------- // have computer randomly deploy ship positions P f_GenerateDeployment... P B D f_GenerateDeployment... D PI D ShipSize s 3u 0 D randVector s 3u 0 D sizeCount s 3u 0 D Row s 3u 0 D Col s 3u 0 D Rowx s 3u 0 D Colx s 3u 0 D RowDS ds dim(10) qualified D Col 1a dim(10) /free //--------------------------------------------------------- // randVector=1,2,3 or 4. 1=up, 2=right, 3=down, 4=left // ShipSize = number of indexes occupied by each ship. 1b for ShipSize = 2 to 5; randVector = f_GetRandom(4); 2b dou not IsCollision; sizeCount = 0; Row = f_GetRandom(10); Col = f_GetRandom(10); exsr srLoadShips; 2e enddo; 1e endfor; Deployed(*) = RowDS(*); //update global DS return; //--------------------------------------------------------- // Load grid. // I have to be concerned about ships trying to run off grid // and about ships trying to overlay each other // I know length of ship, direction ship is going, // size of grid. If a ship is going to run off grid, // back up starting point until ship will fit. begsr srLoadShips; IsCollision = *off; 1b if randVector = 1; //go up from start 2b dow ShipSize > Row; Row += 1; 2e enddo; 1x elseif randVector = 3; //go down from start 2b dow (11 - ShipSize) < Row; Row -= 1; 2e enddo; 1x elseif randVector = 2; //go right from start 2b dow (11 - ShipSize) < Col; Col -= 1; 2e enddo; 1x elseif randVector = 4; //go left from start 2b dow ShipSize > Col; Col += 1; 2e enddo; 1e endif; //--------------------------------------------------------- // Before any values are loaded, I have to make sure that none // of this ships coordinates are occupied by another ship. // If so, get new random numbers for starting point Rowx = Row; Colx = Col; 1b for ForCount = 1 to ShipSize; 2b if randVector = 1; //go up from start 3b if RowDs(Rowx).Col(Colx) > *blanks; IsCollision = *on; LV leavesr; 3e endif; Rowx -= 1; 2x elseif randVector = 3; //go down from start 3b if RowDs(Rowx).Col(Colx) > *blanks; IsCollision = *on; LV leavesr; 3e endif; Rowx += 1; 2x elseif randVector = 2; //go right from start 3b if RowDs(Rowx).Col(Colx) > *blanks; IsCollision = *on; LV leavesr; 3e endif; Colx += 1; 2x elseif randVector = 4; //go left from start 3b if RowDs(Rowx).Col(Colx) > *blanks; IsCollision = *on; LV leavesr; 3e endif; Colx -= 1; 2e endif; 1e endfor; //--------------------------------------------------------- // Load values for ships. 1b for ForCount = 1 to ShipSize; 2b if randVector = 1; RowDs(Row).Col(Col) = %char(ShipSize); Row -= 1; 2x elseif randVector = 3; RowDs(Row).Col(Col) = %char(ShipSize); Row += 1; 2x elseif randVector = 2; RowDs(Row).Col(Col) = %char(ShipSize); Col += 1; 2x elseif randVector = 4; RowDs(Row).Col(Col) = %char(ShipSize); Col -= 1; 2e endif; 1e endfor; endsr; /end-free P f_GenerateDeployment... P E ]]> v5r4 *---------------------------------------------------------------- * JCRGMBTLD - Battleship - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN1 CA05 A BTR0101 1A P A BTR0102 1A P A BTR0103 1A P A BTR0104 1A P A BTR0105 1A P A BTR0106 1A P A BTR0107 1A P A BTR0108 1A P A BTR0109 1A P A BTR0110 1A P A BTR0201 1A P A BTR0202 1A P A BTR0203 1A P A BTR0204 1A P A BTR0205 1A P A BTR0206 1A P A BTR0207 1A P A BTR0208 1A P A BTR0209 1A P A BTR0210 1A P A BTR0301 1A P A BTR0302 1A P A BTR0303 1A P A BTR0304 1A P A BTR0305 1A P A BTR0306 1A P A BTR0307 1A P A BTR0308 1A P A BTR0309 1A P A BTR0310 1A P A BTR0401 1A P A BTR0402 1A P A BTR0403 1A P A BTR0404 1A P A BTR0405 1A P A BTR0406 1A P A BTR0407 1A P A BTR0408 1A P A BTR0409 1A P A BTR0410 1A P A BTR0501 1A P A BTR0502 1A P A BTR0503 1A P A BTR0504 1A P A BTR0505 1A P A BTR0506 1A P A BTR0507 1A P A BTR0508 1A P A BTR0509 1A P A BTR0510 1A P A BTR0601 1A P A BTR0602 1A P A BTR0603 1A P A BTR0604 1A P A BTR0605 1A P A BTR0606 1A P A BTR0607 1A P A BTR0608 1A P A BTR0609 1A P A BTR0610 1A P A BTR0701 1A P A BTR0702 1A P A BTR0703 1A P A BTR0704 1A P A BTR0705 1A P A BTR0706 1A P A BTR0707 1A P A BTR0708 1A P A BTR0709 1A P A BTR0710 1A P A BTR0801 1A P A BTR0802 1A P A BTR0803 1A P A BTR0804 1A P A BTR0805 1A P A BTR0806 1A P A BTR0807 1A P A BTR0808 1A P A BTR0809 1A P A BTR0810 1A P A BTR0901 1A P A BTR0902 1A P A BTR0903 1A P A BTR0904 1A P A BTR0905 1A P A BTR0906 1A P A BTR0907 1A P A BTR0908 1A P A BTR0909 1A P A BTR0910 1A P A BTR1001 1A P A BTR1002 1A P A BTR1003 1A P A BTR1004 1A P A BTR1005 1A P A BTR1006 1A P A BTR1007 1A P A BTR1008 1A P A BTR1009 1A P A BTR1010 1A P A BLUERI 1A P A REDRI 1A P A ADEPLOYMSG 1A P A 1 3'JCRGMBTL' COLOR(BLU) A 1 14'BATTLE SHIP!' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 3'Deploy your Battle Group:' A DSPATR(HI) A 3 42'1' DSPATR(&REDRI) A 3 44'2' DSPATR(&REDRI) A 3 46'3' DSPATR(&REDRI) A 3 48'4' DSPATR(&REDRI) A 3 50'5' DSPATR(&REDRI) A 3 52'6' DSPATR(&REDRI) A 3 54'7' DSPATR(&REDRI) A 3 56'8' DSPATR(&REDRI) A 3 58'9' DSPATR(&REDRI) A 3 60'0' DSPATR(&REDRI) A 5 3'Press F5 to have the iSeries' A DSPATR(HI) A 5 38'1' DSPATR(&BLUERI) A B01C01 1A O 5 42DSPATR(&BTR0101) A B01C02 1A O 5 44DSPATR(&BTR0102) A B01C03 1A O 5 46DSPATR(&BTR0103) A B01C04 1A O 5 48DSPATR(&BTR0104) A B01C05 1A O 5 50DSPATR(&BTR0105) A B01C06 1A O 5 52DSPATR(&BTR0106) A B01C07 1A O 5 54DSPATR(&BTR0107) A B01C08 1A O 5 56DSPATR(&BTR0108) A B01C09 1A O 5 58DSPATR(&BTR0109) A B01C10 1A O 5 60DSPATR(&BTR0110) A 5 64'1' DSPATR(&BLUERI) A 6 3'battle computer place your ships.' A DSPATR(HI) A 6 38'2' DSPATR(&BLUERI) A B02C01 1A O 6 42DSPATR(&BTR0201) A B02C02 1A O 6 44DSPATR(&BTR0202) A B02C03 1A O 6 46DSPATR(&BTR0203) A B02C04 1A O 6 48DSPATR(&BTR0204) A B02C05 1A O 6 50DSPATR(&BTR0205) A B02C06 1A O 6 52DSPATR(&BTR0206) A B02C07 1A O 6 54DSPATR(&BTR0207) A B02C08 1A O 6 56DSPATR(&BTR0208) A B02C09 1A O 6 58DSPATR(&BTR0209) A B02C10 1A O 6 60DSPATR(&BTR0210) A 6 64'2' DSPATR(&BLUERI) A 7 38'3' DSPATR(&BLUERI) A B03C01 1A O 7 42DSPATR(&BTR0301) A B03C02 1A O 7 44DSPATR(&BTR0302) A B03C03 1A O 7 46DSPATR(&BTR0303) A B03C04 1A O 7 48DSPATR(&BTR0304) A B03C05 1A O 7 50DSPATR(&BTR0305) A B03C06 1A O 7 52DSPATR(&BTR0306) A B03C07 1A O 7 54DSPATR(&BTR0307) A B03C08 1A O 7 56DSPATR(&BTR0308) A B03C09 1A O 7 58DSPATR(&BTR0309) A B03C10 1A O 7 60DSPATR(&BTR0310) A 7 64'3' DSPATR(&BLUERI) A 8 38'4' DSPATR(&BLUERI) A B04C01 1A O 8 42DSPATR(&BTR0401) A B04C02 1A O 8 44DSPATR(&BTR0402) A B04C03 1A O 8 46DSPATR(&BTR0403) A B04C04 1A O 8 48DSPATR(&BTR0404) A B04C05 1A O 8 50DSPATR(&BTR0405) A B04C06 1A O 8 52DSPATR(&BTR0406) A B04C07 1A O 8 54DSPATR(&BTR0407) A B04C08 1A O 8 56DSPATR(&BTR0408) A B04C09 1A O 8 58DSPATR(&BTR0409) A B04C10 1A O 8 60DSPATR(&BTR0410) A 8 64'4' DSPATR(&BLUERI) A 9 3'You can press F5 as many times' A DSPATR(HI) A 9 38'5' DSPATR(&BLUERI) A B05C01 1A O 9 42DSPATR(&BTR0501) A B05C02 1A O 9 44DSPATR(&BTR0502) A B05C03 1A O 9 46DSPATR(&BTR0503) A B05C04 1A O 9 48DSPATR(&BTR0504) A B05C05 1A O 9 50DSPATR(&BTR0505) A B05C06 1A O 9 52DSPATR(&BTR0506) A B05C07 1A O 9 54DSPATR(&BTR0507) A B05C08 1A O 9 56DSPATR(&BTR0508) A B05C09 1A O 9 58DSPATR(&BTR0509) A B05C10 1A O 9 60DSPATR(&BTR0510) A 9 64'5' DSPATR(&BLUERI) A 10 3'as you wish to re-position ships.' A DSPATR(HI) A 10 38'6' DSPATR(&BLUERI) A B06C01 1A O 10 42DSPATR(&BTR0601) A B06C02 1A O 10 44DSPATR(&BTR0602) A B06C03 1A O 10 46DSPATR(&BTR0603) A B06C04 1A O 10 48DSPATR(&BTR0604) A B06C05 1A O 10 50DSPATR(&BTR0605) A B06C06 1A O 10 52DSPATR(&BTR0606) A B06C07 1A O 10 54DSPATR(&BTR0607) A B06C08 1A O 10 56DSPATR(&BTR0608) A B06C09 1A O 10 58DSPATR(&BTR0609) A B06C10 1A O 10 60DSPATR(&BTR0610) A 10 64'6' DSPATR(&BLUERI) A 11 38'7' DSPATR(&BLUERI) A B07C01 1A O 11 42DSPATR(&BTR0701) A B07C02 1A O 11 44DSPATR(&BTR0702) A B07C03 1A O 11 46DSPATR(&BTR0703) A B07C04 1A O 11 48DSPATR(&BTR0704) A B07C05 1A O 11 50DSPATR(&BTR0705) A B07C06 1A O 11 52DSPATR(&BTR0706) A B07C07 1A O 11 54DSPATR(&BTR0707) A B07C08 1A O 11 56DSPATR(&BTR0708) A B07C09 1A O 11 58DSPATR(&BTR0709) A B07C10 1A O 11 60DSPATR(&BTR0710) A 11 64'7' DSPATR(&BLUERI) A 12 38'8' DSPATR(&BLUERI) A B08C01 1A O 12 42DSPATR(&BTR0801) A B08C02 1A O 12 44DSPATR(&BTR0802) A B08C03 1A O 12 46DSPATR(&BTR0803) A B08C04 1A O 12 48DSPATR(&BTR0804) A B08C05 1A O 12 50DSPATR(&BTR0805) A B08C06 1A O 12 52DSPATR(&BTR0806) A B08C07 1A O 12 54DSPATR(&BTR0807) A B08C08 1A O 12 56DSPATR(&BTR0808) A B08C09 1A O 12 58DSPATR(&BTR0809) A B08C10 1A O 12 60DSPATR(&BTR0810) A 12 64'8' DSPATR(&BLUERI) A 13 3'Press Enter when completed with' A DSPATR(HI) A 13 38'9' DSPATR(&BLUERI) A B09C01 1A O 13 42DSPATR(&BTR0901) A B09C02 1A O 13 44DSPATR(&BTR0902) A B09C03 1A O 13 46DSPATR(&BTR0903) A B09C04 1A O 13 48DSPATR(&BTR0904) A B09C05 1A O 13 50DSPATR(&BTR0905) A B09C06 1A O 13 52DSPATR(&BTR0906) A B09C07 1A O 13 54DSPATR(&BTR0907) A B09C08 1A O 13 56DSPATR(&BTR0908) A B09C09 1A O 13 58DSPATR(&BTR0909) A B09C10 1A O 13 60DSPATR(&BTR0910) A 13 64'9' DSPATR(&BLUERI) A 14 3'deployment.' DSPATR(HI) A 14 38'0' DSPATR(&BLUERI) A B10C01 1A O 14 42DSPATR(&BTR1001) A B10C02 1A O 14 44DSPATR(&BTR1002) A B10C03 1A O 14 46DSPATR(&BTR1003) A B10C04 1A O 14 48DSPATR(&BTR1004) A B10C05 1A O 14 50DSPATR(&BTR1005) A B10C06 1A O 14 52DSPATR(&BTR1006) A B10C07 1A O 14 54DSPATR(&BTR1007) A B10C08 1A O 14 56DSPATR(&BTR1008) A B10C09 1A O 14 58DSPATR(&BTR1009) A B10C10 1A O 14 60DSPATR(&BTR1010) A 14 64'0' DSPATR(&BLUERI) A 16 42'1' DSPATR(&REDRI) A 16 44'2' DSPATR(&REDRI) A 16 46'3' DSPATR(&REDRI) A 16 48'4' DSPATR(&REDRI) A 16 50'5' DSPATR(&REDRI) A 16 52'6' DSPATR(&REDRI) A 16 54'7' DSPATR(&REDRI) A 16 56'8' DSPATR(&REDRI) A 16 58'9' DSPATR(&REDRI) A 16 60'0' DSPATR(&REDRI) A 18 42'Cruiser 2' COLOR(TRQ) A 19 42'Destroyer 3' COLOR(YLW) A 20 42'BattleShip 4' COLOR(PNK) A 21 42'AirCraft Carrier 5' COLOR(RED) A 23 2'F3=Exit' COLOR(BLU) A 23 20'F5=Computer generated deployment' A COLOR(BLU) A 23 58'Enter = Begin Battle!' COLOR(BLU) A 24 10'Admiral! You must deploy your ship- A s before going into battle!' A DSPATR(&ADEPLOYMSG) *---------------------------------------------------------------- A R SCREEN2 CA09 CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A ATR0101 1A P A ATR0102 1A P A ATR0103 1A P A ATR0104 1A P A ATR0105 1A P A ATR0106 1A P A ATR0107 1A P A ATR0108 1A P A ATR0109 1A P A ATR0110 1A P A ATR0201 1A P A ATR0202 1A P A ATR0203 1A P A ATR0204 1A P A ATR0205 1A P A ATR0206 1A P A ATR0207 1A P A ATR0208 1A P A ATR0209 1A P A ATR0210 1A P A ATR0301 1A P A ATR0302 1A P A ATR0303 1A P A ATR0304 1A P A ATR0305 1A P A ATR0306 1A P A ATR0307 1A P A ATR0308 1A P A ATR0309 1A P A ATR0310 1A P A ATR0401 1A P A ATR0402 1A P A ATR0403 1A P A ATR0404 1A P A ATR0405 1A P A ATR0406 1A P A ATR0407 1A P A ATR0408 1A P A ATR0409 1A P A ATR0410 1A P A ATR0501 1A P A ATR0502 1A P A ATR0503 1A P A ATR0504 1A P A ATR0505 1A P A ATR0506 1A P A ATR0507 1A P A ATR0508 1A P A ATR0509 1A P A ATR0510 1A P A ATR0601 1A P A ATR0602 1A P A ATR0603 1A P A ATR0604 1A P A ATR0605 1A P A ATR0606 1A P A ATR0607 1A P A ATR0608 1A P A ATR0609 1A P A ATR0610 1A P A ATR0701 1A P A ATR0702 1A P A ATR0703 1A P A ATR0704 1A P A ATR0705 1A P A ATR0706 1A P A ATR0707 1A P A ATR0708 1A P A ATR0709 1A P A ATR0710 1A P A ATR0801 1A P A ATR0802 1A P A ATR0803 1A P A ATR0804 1A P A ATR0805 1A P A ATR0806 1A P A ATR0807 1A P A ATR0808 1A P A ATR0809 1A P A ATR0810 1A P A ATR0901 1A P A ATR0902 1A P A ATR0903 1A P A ATR0904 1A P A ATR0905 1A P A ATR0906 1A P A ATR0907 1A P A ATR0908 1A P A ATR0909 1A P A ATR0910 1A P A ATR1001 1A P A ATR1002 1A P A ATR1003 1A P A ATR1004 1A P A ATR1005 1A P A ATR1006 1A P A ATR1007 1A P A ATR1008 1A P A ATR1009 1A P A ATR1010 1A P A BTR0101 1A P A BTR0102 1A P A BTR0103 1A P A BTR0104 1A P A BTR0105 1A P A BTR0106 1A P A BTR0107 1A P A BTR0108 1A P A BTR0109 1A P A BTR0110 1A P A BTR0201 1A P A BTR0202 1A P A BTR0203 1A P A BTR0204 1A P A BTR0205 1A P A BTR0206 1A P A BTR0207 1A P A BTR0208 1A P A BTR0209 1A P A BTR0210 1A P A BTR0301 1A P A BTR0302 1A P A BTR0303 1A P A BTR0304 1A P A BTR0305 1A P A BTR0306 1A P A BTR0307 1A P A BTR0308 1A P A BTR0309 1A P A BTR0310 1A P A BTR0401 1A P A BTR0402 1A P A BTR0403 1A P A BTR0404 1A P A BTR0405 1A P A BTR0406 1A P A BTR0407 1A P A BTR0408 1A P A BTR0409 1A P A BTR0410 1A P A BTR0501 1A P A BTR0502 1A P A BTR0503 1A P A BTR0504 1A P A BTR0505 1A P A BTR0506 1A P A BTR0507 1A P A BTR0508 1A P A BTR0509 1A P A BTR0510 1A P A BTR0601 1A P A BTR0602 1A P A BTR0603 1A P A BTR0604 1A P A BTR0605 1A P A BTR0606 1A P A BTR0607 1A P A BTR0608 1A P A BTR0609 1A P A BTR0610 1A P A BTR0701 1A P A BTR0702 1A P A BTR0703 1A P A BTR0704 1A P A BTR0705 1A P A BTR0706 1A P A BTR0707 1A P A BTR0708 1A P A BTR0709 1A P A BTR0710 1A P A BTR0801 1A P A BTR0802 1A P A BTR0803 1A P A BTR0804 1A P A BTR0805 1A P A BTR0806 1A P A BTR0807 1A P A BTR0808 1A P A BTR0809 1A P A BTR0810 1A P A BTR0901 1A P A BTR0902 1A P A BTR0903 1A P A BTR0904 1A P A BTR0905 1A P A BTR0906 1A P A BTR0907 1A P A BTR0908 1A P A BTR0909 1A P A BTR0910 1A P A BTR1001 1A P A BTR1002 1A P A BTR1003 1A P A BTR1004 1A P A BTR1005 1A P A BTR1006 1A P A BTR1007 1A P A BTR1008 1A P A BTR1009 1A P A BTR1010 1A P A EDSPATR2 1A P A EDSPATR3 1A P A EDSPATR4 1A P A EDSPATR5 1A P A UDSPATR2 1A P A UDSPATR3 1A P A UDSPATR4 1A P A UDSPATR5 1A P A AGAMEOVER 1A P A 1 3'JCRGMBTL' COLOR(BLU) A 1 14'BATTLE SHIP!' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 8'ATTACK ' A DSPATR(HI UL) A 2 42'DEFEND ' A DSPATR(HI UL) A 3 8'1' A 3 10'2' A 3 12'3' A 3 14'4' A 3 16'5' A 3 18'6' A 3 20'7' A 3 22'8' A 3 24'9' A 3 26'0' A 3 42'1' A 3 44'2' A 3 46'3' A 3 48'4' A 3 50'5' A 3 52'6' A 3 54'7' A 3 56'8' A 3 58'9' A 3 60'0' A R01C01 1A B 5 8DSPATR(&ATR0101) A R01C02 1A B 5 10DSPATR(&ATR0102) A R01C03 1A B 5 12DSPATR(&ATR0103) A R01C04 1A B 5 14DSPATR(&ATR0104) A R01C05 1A B 5 16DSPATR(&ATR0105) A R01C06 1A B 5 18DSPATR(&ATR0106) A R01C07 1A B 5 20DSPATR(&ATR0107) A R01C08 1A B 5 22DSPATR(&ATR0108) A R01C09 1A B 5 24DSPATR(&ATR0109) A R01C10 1A B 5 26DSPATR(&ATR0110) A 5 30'1' A B01C01 1A O 5 42DSPATR(&BTR0101) A B01C02 1A O 5 44DSPATR(&BTR0102) A B01C03 1A O 5 46DSPATR(&BTR0103) A B01C04 1A O 5 48DSPATR(&BTR0104) A B01C05 1A O 5 50DSPATR(&BTR0105) A B01C06 1A O 5 52DSPATR(&BTR0106) A B01C07 1A O 5 54DSPATR(&BTR0107) A B01C08 1A O 5 56DSPATR(&BTR0108) A B01C09 1A O 5 58DSPATR(&BTR0109) A B01C10 1A O 5 60DSPATR(&BTR0110) A 5 64'1' A R02C01 1A B 6 8DSPATR(&ATR0201) A R02C02 1A B 6 10DSPATR(&ATR0202) A R02C03 1A B 6 12DSPATR(&ATR0203) A R02C04 1A B 6 14DSPATR(&ATR0204) A R02C05 1A B 6 16DSPATR(&ATR0205) A R02C06 1A B 6 18DSPATR(&ATR0206) A R02C07 1A B 6 20DSPATR(&ATR0207) A R02C08 1A B 6 22DSPATR(&ATR0208) A R02C09 1A B 6 24DSPATR(&ATR0209) A R02C10 1A B 6 26DSPATR(&ATR0210) A 6 30'2' A B02C01 1A O 6 42DSPATR(&BTR0201) A B02C02 1A O 6 44DSPATR(&BTR0202) A B02C03 1A O 6 46DSPATR(&BTR0203) A B02C04 1A O 6 48DSPATR(&BTR0204) A B02C05 1A O 6 50DSPATR(&BTR0205) A B02C06 1A O 6 52DSPATR(&BTR0206) A B02C07 1A O 6 54DSPATR(&BTR0207) A B02C08 1A O 6 56DSPATR(&BTR0208) A B02C09 1A O 6 58DSPATR(&BTR0209) A B02C10 1A O 6 60DSPATR(&BTR0210) A 6 64'2' A R03C01 1A B 7 8DSPATR(&ATR0301) A R03C02 1A B 7 10DSPATR(&ATR0302) A R03C03 1A B 7 12DSPATR(&ATR0303) A R03C04 1A B 7 14DSPATR(&ATR0304) A R03C05 1A B 7 16DSPATR(&ATR0305) A R03C06 1A B 7 18DSPATR(&ATR0306) A R03C07 1A B 7 20DSPATR(&ATR0307) A R03C08 1A B 7 22DSPATR(&ATR0308) A R03C09 1A B 7 24DSPATR(&ATR0309) A R03C10 1A B 7 26DSPATR(&ATR0310) A 7 30'3' A B03C01 1A O 7 42DSPATR(&BTR0301) A B03C02 1A O 7 44DSPATR(&BTR0302) A B03C03 1A O 7 46DSPATR(&BTR0303) A B03C04 1A O 7 48DSPATR(&BTR0304) A B03C05 1A O 7 50DSPATR(&BTR0305) A B03C06 1A O 7 52DSPATR(&BTR0306) A B03C07 1A O 7 54DSPATR(&BTR0307) A B03C08 1A O 7 56DSPATR(&BTR0308) A B03C09 1A O 7 58DSPATR(&BTR0309) A B03C10 1A O 7 60DSPATR(&BTR0310) A 7 64'3' A R04C01 1A B 8 8DSPATR(&ATR0401) A R04C02 1A B 8 10DSPATR(&ATR0402) A R04C03 1A B 8 12DSPATR(&ATR0403) A R04C04 1A B 8 14DSPATR(&ATR0404) A R04C05 1A B 8 16DSPATR(&ATR0405) A R04C06 1A B 8 18DSPATR(&ATR0406) A R04C07 1A B 8 20DSPATR(&ATR0407) A R04C08 1A B 8 22DSPATR(&ATR0408) A R04C09 1A B 8 24DSPATR(&ATR0409) A R04C10 1A B 8 26DSPATR(&ATR0410) A 8 30'4' A B04C01 1A O 8 42DSPATR(&BTR0401) A B04C02 1A O 8 44DSPATR(&BTR0402) A B04C03 1A O 8 46DSPATR(&BTR0403) A B04C04 1A O 8 48DSPATR(&BTR0404) A B04C05 1A O 8 50DSPATR(&BTR0405) A B04C06 1A O 8 52DSPATR(&BTR0406) A B04C07 1A O 8 54DSPATR(&BTR0407) A B04C08 1A O 8 56DSPATR(&BTR0408) A B04C09 1A O 8 58DSPATR(&BTR0409) A B04C10 1A O 8 60DSPATR(&BTR0410) A 8 64'4' A R05C01 1A B 9 8DSPATR(&ATR0501) A R05C02 1A B 9 10DSPATR(&ATR0502) A R05C03 1A B 9 12DSPATR(&ATR0503) A R05C04 1A B 9 14DSPATR(&ATR0504) A R05C05 1A B 9 16DSPATR(&ATR0505) A R05C06 1A B 9 18DSPATR(&ATR0506) A R05C07 1A B 9 20DSPATR(&ATR0507) A R05C08 1A B 9 22DSPATR(&ATR0508) A R05C09 1A B 9 24DSPATR(&ATR0509) A R05C10 1A B 9 26DSPATR(&ATR0510) A 9 30'5' A B05C01 1A O 9 42DSPATR(&BTR0501) A B05C02 1A O 9 44DSPATR(&BTR0502) A B05C03 1A O 9 46DSPATR(&BTR0503) A B05C04 1A O 9 48DSPATR(&BTR0504) A B05C05 1A O 9 50DSPATR(&BTR0505) A B05C06 1A O 9 52DSPATR(&BTR0506) A B05C07 1A O 9 54DSPATR(&BTR0507) A B05C08 1A O 9 56DSPATR(&BTR0508) A B05C09 1A O 9 58DSPATR(&BTR0509) A B05C10 1A O 9 60DSPATR(&BTR0510) A 9 64'5' A R06C01 1A B 10 8DSPATR(&ATR0601) A R06C02 1A B 10 10DSPATR(&ATR0602) A R06C03 1A B 10 12DSPATR(&ATR0603) A R06C04 1A B 10 14DSPATR(&ATR0604) A R06C05 1A B 10 16DSPATR(&ATR0605) A R06C06 1A B 10 18DSPATR(&ATR0606) A R06C07 1A B 10 20DSPATR(&ATR0607) A R06C08 1A B 10 22DSPATR(&ATR0608) A R06C09 1A B 10 24DSPATR(&ATR0609) A R06C10 1A B 10 26DSPATR(&ATR0610) A 10 30'6' A B06C01 1A O 10 42DSPATR(&BTR0601) A B06C02 1A O 10 44DSPATR(&BTR0602) A B06C03 1A O 10 46DSPATR(&BTR0603) A B06C04 1A O 10 48DSPATR(&BTR0604) A B06C05 1A O 10 50DSPATR(&BTR0605) A B06C06 1A O 10 52DSPATR(&BTR0606) A B06C07 1A O 10 54DSPATR(&BTR0607) A B06C08 1A O 10 56DSPATR(&BTR0608) A B06C09 1A O 10 58DSPATR(&BTR0609) A B06C10 1A O 10 60DSPATR(&BTR0610) A 10 64'6' A R07C01 1A B 11 8DSPATR(&ATR0701) A R07C02 1A B 11 10DSPATR(&ATR0702) A R07C03 1A B 11 12DSPATR(&ATR0703) A R07C04 1A B 11 14DSPATR(&ATR0704) A R07C05 1A B 11 16DSPATR(&ATR0705) A R07C06 1A B 11 18DSPATR(&ATR0706) A R07C07 1A B 11 20DSPATR(&ATR0707) A R07C08 1A B 11 22DSPATR(&ATR0708) A R07C09 1A B 11 24DSPATR(&ATR0709) A R07C10 1A B 11 26DSPATR(&ATR0710) A 11 30'7' A B07C01 1A O 11 42DSPATR(&BTR0701) A B07C02 1A O 11 44DSPATR(&BTR0702) A B07C03 1A O 11 46DSPATR(&BTR0703) A B07C04 1A O 11 48DSPATR(&BTR0704) A B07C05 1A O 11 50DSPATR(&BTR0705) A B07C06 1A O 11 52DSPATR(&BTR0706) A B07C07 1A O 11 54DSPATR(&BTR0707) A B07C08 1A O 11 56DSPATR(&BTR0708) A B07C09 1A O 11 58DSPATR(&BTR0709) A B07C10 1A O 11 60DSPATR(&BTR0710) A 11 64'7' A R08C01 1A B 12 8DSPATR(&ATR0801) A R08C02 1A B 12 10DSPATR(&ATR0802) A R08C03 1A B 12 12DSPATR(&ATR0803) A R08C04 1A B 12 14DSPATR(&ATR0804) A R08C05 1A B 12 16DSPATR(&ATR0805) A R08C06 1A B 12 18DSPATR(&ATR0806) A R08C07 1A B 12 20DSPATR(&ATR0807) A R08C08 1A B 12 22DSPATR(&ATR0808) A R08C09 1A B 12 24DSPATR(&ATR0809) A R08C10 1A B 12 26DSPATR(&ATR0810) A 12 30'8' A B08C01 1A O 12 42DSPATR(&BTR0801) A B08C02 1A O 12 44DSPATR(&BTR0802) A B08C03 1A O 12 46DSPATR(&BTR0803) A B08C04 1A O 12 48DSPATR(&BTR0804) A B08C05 1A O 12 50DSPATR(&BTR0805) A B08C06 1A O 12 52DSPATR(&BTR0806) A B08C07 1A O 12 54DSPATR(&BTR0807) A B08C08 1A O 12 56DSPATR(&BTR0808) A B08C09 1A O 12 58DSPATR(&BTR0809) A B08C10 1A O 12 60DSPATR(&BTR0810) A 12 64'8' A R09C01 1A B 13 8DSPATR(&ATR0901) A R09C02 1A B 13 10DSPATR(&ATR0902) A R09C03 1A B 13 12DSPATR(&ATR0903) A R09C04 1A B 13 14DSPATR(&ATR0904) A R09C05 1A B 13 16DSPATR(&ATR0905) A R09C06 1A B 13 18DSPATR(&ATR0906) A R09C07 1A B 13 20DSPATR(&ATR0907) A R09C08 1A B 13 22DSPATR(&ATR0908) A R09C09 1A B 13 24DSPATR(&ATR0909) A R09C10 1A B 13 26DSPATR(&ATR0910) A 13 30'9' A B09C01 1A O 13 42DSPATR(&BTR0901) A B09C02 1A O 13 44DSPATR(&BTR0902) A B09C03 1A O 13 46DSPATR(&BTR0903) A B09C04 1A O 13 48DSPATR(&BTR0904) A B09C05 1A O 13 50DSPATR(&BTR0905) A B09C06 1A O 13 52DSPATR(&BTR0906) A B09C07 1A O 13 54DSPATR(&BTR0907) A B09C08 1A O 13 56DSPATR(&BTR0908) A B09C09 1A O 13 58DSPATR(&BTR0909) A B09C10 1A O 13 60DSPATR(&BTR0910) A 13 64'9' A R10C01 1A B 14 8DSPATR(&ATR1001) A R10C02 1A B 14 10DSPATR(&ATR1002) A R10C03 1A B 14 12DSPATR(&ATR1003) A R10C04 1A B 14 14DSPATR(&ATR1004) A R10C05 1A B 14 16DSPATR(&ATR1005) A R10C06 1A B 14 18DSPATR(&ATR1006) A R10C07 1A B 14 20DSPATR(&ATR1007) A R10C08 1A B 14 22DSPATR(&ATR1008) A R10C09 1A B 14 24DSPATR(&ATR1009) A R10C10 1A B 14 26DSPATR(&ATR1010) A 14 30'0' A B10C01 1A O 14 42DSPATR(&BTR1001) A B10C02 1A O 14 44DSPATR(&BTR1002) A B10C03 1A O 14 46DSPATR(&BTR1003) A B10C04 1A O 14 48DSPATR(&BTR1004) A B10C05 1A O 14 50DSPATR(&BTR1005) A B10C06 1A O 14 52DSPATR(&BTR1006) A B10C07 1A O 14 54DSPATR(&BTR1007) A B10C08 1A O 14 56DSPATR(&BTR1008) A B10C09 1A O 14 58DSPATR(&BTR1009) A B10C10 1A O 14 60DSPATR(&BTR1010) A 14 64'0' A 16 8'Enemy Ship Status' DSPATR(UL HI) A 16 42'Your Ship Status' DSPATR(UL HI) A 17 8'Cruiser 2' DSPATR(&EDSPATR2) A 17 42'Cruiser 2' DSPATR(&UDSPATR2) A 18 8'Destroyer 3' DSPATR(&EDSPATR3) A 18 42'Destroyer 3' DSPATR(&UDSPATR3) A 19 8'BattleShip 4' DSPATR(&EDSPATR4) A 19 42'BattleShip 4' DSPATR(&UDSPATR4) A 20 8'Aircraft Carrier 5' A DSPATR(&EDSPATR5) A 20 42'Aircraft Carrier 5' A DSPATR(&UDSPATR5) A GAMEOVER 27A 21 20DSPATR(&AGAMEOVER) A 23 7'Key X, press Enter to Fire!' A COLOR(BLU) A 24 7'F3=Exit' COLOR(BLU) A 24 41'F9=Restart' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRGMCRB - Cribbage // Subroutines------------------------------------------- // srUserDealt Show users hand and allow selection of discards. // srUserDiscard Make sure user has selected only 2 cards for discard. // srUserPlay Play users selection. // srLoadCraigHand Select highest possible scoring hand for Craig // srCraigLead1st Craig leads 1st card. // srCraigPlay Craig selects and plays a card. // srPlayOneCard Load Craigs/users card into play array. // srScoreCraig Load subfile for Craigs scores. // srScoreUser Load subfile for users scores. // srScoreWindow Show score window for each hand. // srChkForGO Check both hands to see if either player can next play under 32. // srScoreHeels Check Starter Card for 'Heels' // srScoreNobs Check for Nobs // srChkAllPlayd Check both hands for all cards played. // srScoreNada If no score, write nothing for zero record // srScorePlayed Score hands as they are played // srScoreHand Add total face value of cards and any scoring combinations. // srGetBarScore Add up score for bar graph move // srLoadSbfRec Load scoring cards and colors into subfile. // srMoveBarGraph Move bar graph to reflect totals // srShowCrib Turn up Crib Cards. // srNextHand Deal next hand. Reset Indicators, messages, and load new hand. // srSortDeck Load new deck // srDeal6Cards Deal 6 cards to users and Craigs hand. // srResetPlay Reset played cards after 31 total or successful GO. // srReShowHands Reshow hands after play is complete // srExitPgm exit program //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMCRBD cf e workstn infds(Infds) indds(Ind) F SFILE(sbfdta1: rrn) //--*STAND ALONE------------------------------------------- D BarCarry s 1a dim(120) based(barCPtr) D BarUarry s 1a dim(120) based(barUPtr) D DiscardX s 1a dim(6) based(ptr7) D ptr7 s * inz(%addr(discard1)) D NextStepFlg s 31a D sbfSCatr s 1a dim(5) based(sPtr2) D sbfSCval s 2a dim(5) based(sPtr1) D ShowScoreSbf s 3a D srCraigStat s 30a D srUserStat s 30a D WhoPlayed s 5a inz('Craig') D WhoPlayedLast s 3a D CurrentCard s 3u 0 D ab s 3u 0 D ac s 3u 0 D ad s 3u 0 D ah s 3u 0 D AllGroupings s 3u 0 dim(8) D an s 3u 0 D ax s 3u 0 D ay s 3u 0 D az s 3u 0 D BestA s 3u 0 D BestArry s 3u 0 dim(4) based(bPtr1) D BestB s 3u 0 D BestC s 3u 0 D BestD s 3u 0 D BestDiscard1 s 3u 0 D BestDiscard2 s 3u 0 D BestScore s 3u 0 D ByHowMuch s 3u 0 D CardCount s 3u 0 D CardsToScore s 3u 0 D Check s 3u 0 D Deal s 3u 0 D HandScore s 3u 0 D IndexArry s 3u 0 dim(7) based(aPtr1) D NxtPlayC s 3u 0 D NxtPlayCard s 3u 0 D NxtPlayU s 3u 0 D PickHighCard s 3u 0 D PlayAbleCnt s 3u 0 D PlayThisCard s 3u 0 D RemainingCnt s 3u 0 D rrn s 3u 0 D RunningTot s 3u 0 D sbfx s 3u 0 D Sbfxb s 3u 0 D sFifteens s 3u 0 D sFourOfKind s 3u 0 D sPairs s 3u 0 D sRunOf3s s 3u 0 D sRunOf4s s 3u 0 D sRunOf5s s 3u 0 D sRunOf6s s 3u 0 D sRunOf7s s 3u 0 D sThreeOfKind s 3u 0 D WhoseCrib s 3u 0 1=Player 2=Craig D aPtr1 s * inz(%addr(aIndex)) D barCPtr s * inz(%addr(BarCds)) D barUPtr s * inz(%addr(BarUds)) D bPtr1 s * inz(%addr(BestIndexds)) D sPtr1 s * inz(%addr(sbfSC)) D sPtr2 s * inz(%addr(sbfsca)) D CraigLeadAny s n D CraigLeadFive s n D CraigLeadFour s n D CraigLeadNine s n D CraigLeadSix s n D CraigLeadTen s n D CraigLeadThree s n D CraigLeadTwo s n D IsCardSelected s n dim(6) D IsCraigCardPlayed... D s n dim(4) what has been played D IsCraigGo s n D IsCraigOut s n Craig out of card D IsFlush s n D IsFound s n D IsGameOver s n we have a winner D IsGO s n D IsLoadGraph s n D IsOver31 s n D IsPickBest s n Craig play logic D IsUserCardPlayed... D s n dim(4) D IsUserGo s n D IsUserOut s n user out of cards D QuoteMark c const('''') //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetCardFace /Define f_GetCardColor /Define f_ShuffleDeck /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Define 3D array for card faces D Face ds dim(4) qualified based(ptr1) D Row likeds(RowDsx) dim(3) D RowDsx ds qualified D Col 2a dim(4) D ptr1 s * inz(%addr(chand11)) // Define 3D array for screen field attributes D Attr ds dim(4) qualified based(ptr2) D Row likeds(RowDsy) dim(3) D RowDsy ds qualified D Col 1a dim(4) D ptr2 s * inz(%addr(chand11a)) // Define 2D array for cards Craig will play D PlayCraig ds dim(3) qualified based(ptr3) D Col 2a dim(4) D ptr3 s * inz(%addr(Play11)) D PlayCraigA ds dim(3) qualified based(ptr4) D Col 1a dim(4) D ptr4 s * inz(%addr(Play11a)) // Define 2D array for cards user will play D PlayUser ds dim(3) qualified based(ptr5) D Col 2a dim(4) D ptr5 s * inz(%addr(Play15)) D PlayUserA ds dim(3) qualified based(ptr6) D Col 1a dim(4) D ptr6 s * inz(%addr(Play15a)) // name screen indicators D ind ds qualified D sfldsp n overlay(ind:01) D sfldspctl n overlay(ind:02) D Play1stCard n overlay(ind:10) D Play2ndCard n overlay(ind:20) D Play3rdCard n overlay(ind:30) D Play4thCard n overlay(ind:40) D PlayMsg n overlay(ind:45) D Play5thCard n overlay(ind:50) D Play6thCard n overlay(ind:60) D CribMsgCraig n overlay(ind:70) D CribMsgUser n overlay(ind:71) D ColrBarCraig n overlay(ind:72) D ColrBarUser n overlay(ind:73) D CraigSaysGo n overlay(ind:74) D UserSaysGo n overlay(ind:75) D BorderRed n overlay(ind:76) D BorderBlue n overlay(ind:77) D indsav ds qualified D Play1stCard n D Play2ndCard n D Play3rdCard n D Play4thCard n D ds D NewDeck 2a dim(52) newly sorted deck D NewCard 3u 0 overlay(newdeck:1) D NewSuite 1a overlay(newdeck:*next) D ds D uDealt 2a dim(6) ascend users hand D uFace 3u 0 overlay(uDealt:1) D uSuite 1a overlay(uDealt:*next) D ds D uPlay4 2a dim(4) ascend 4 cards to play D uFace4 3u 0 overlay(uPlay4:1) D uSuite4 1a overlay(uPlay4:*next) D ds D cDealt 2a dim(6) ascend Craigs hand D cFace 3u 0 overlay(cDealt:1) D cSuite 1a overlay(cDealt:*next) D ds D cPlay4 2a dim(4) ascend 4 cards to play D cFace4 3u 0 overlay(cPlay4:1) D cSuite4 1a overlay(cPlay4:*next) D ds D CribCards 2a dim(4) ascend inz either crib D CribFace 3u 0 overlay(CribCards:1) D CribSuite 1a overlay(CribCards:*next) D ds D PlayIt 2a dim(8) cards played D pFace 3u 0 overlay(PlayIt:1) D pSuite 1a overlay(PlayIt:*next) D BestIndexDS ds inz D BestIndexA 3u 0 D BestIndexB 3u 0 D BestIndexC 3u 0 D BestIndexD 3u 0 // Craig hand AI and scoring variables D ds D TstDeck 2a dim(8) descend inz work deck to compare D TstCard 3u 0 overlay(TstDeck:1) D TstSuite 1a overlay(TstDeck:*next) D ds D RunDeck 2a dim(8) descend inz drop when runs of D RunCard 3u 0 overlay(RunDeck:1) D ds D SavDeck 2a dim(8) Original Deck D SavCard 3u 0 overlay(Savdeck:1) inz D SavSuite 1a overlay(Savdeck:*next) D aIndex ds inz D a1 3u 0 D a2 3u 0 D a3 3u 0 D a4 3u 0 D a5 3u 0 D a6 3u 0 D a7 3u 0 // arrays to load cards that scored to window D sbfSC ds inz scoring cards D sbfSC1 2a D sbfSC2 2a D sbfSC3 2a D sbfSC4 2a D sbfSC5 2a D sbfSCa ds inz scoring card attribu D sbfSC1a 1a D sbfSC2a 1a D sbfSC3a 1a D sbfSC4a 1a D sbfSC5a 1a // move bar graph to represent total scores D BarCds ds inz Craigs graph D trackc1 D trackc2 D trackc3 D BarUds ds inz users graph D tracku1 D tracku2 D tracku3 // map screen fields into DS so pointers to data can overlay D screenDS ds D CHAND11A D CHAND12A D CHAND13A D CHAND14A D CHAND21A D CHAND22A D CHAND23A D CHAND24A D CHAND31A D CHAND32A D CHAND33A D CHAND34A D CCRIB11A D CCRIB12A D CCRIB13A D CCRIB14A D CCRIB21A D CCRIB22A D CCRIB23A D CCRIB24A D CCRIB31A D CCRIB32A D CCRIB33A D CCRIB34A D UHAND11A D UHAND12A D UHAND13A D UHAND14A D UHAND21A D UHAND22A D UHAND23A D UHAND24A D UHAND31A D UHAND32A D UHAND33A D UHAND34A D UCRIB11A D UCRIB12A D UCRIB13A D UCRIB14A D UCRIB21A D UCRIB22A D UCRIB23A D UCRIB24A D UCRIB31A D UCRIB32A D UCRIB33A D UCRIB34A D PLAY11A D PLAY12A D PLAY13A D PLAY14A D PLAY21A D PLAY22A D PLAY23A D PLAY24A D PLAY31A D PLAY32A D PLAY33A D PLAY34A D PLAY15A D PLAY16A D PLAY17A D PLAY18A D PLAY25A D PLAY26A D PLAY27A D PLAY28A D PLAY35A D PLAY36A D PLAY37A D PLAY38A D UHAND15A D UHAND16A D UHAND25A D UHAND26A D UHAND35A D UHAND36A D PLAY11 D PLAY12 D PLAY13 D PLAY14 D PLAY21 D PLAY22 D PLAY23 D PLAY24 D PLAY31 D PLAY32 D PLAY33 D PLAY34 D PLAY15 D PLAY16 D PLAY17 D PLAY18 D PLAY25 D PLAY26 D PLAY27 D PLAY28 D PLAY35 D PLAY36 D PLAY37 D PLAY38 D CHAND11 D CHAND12 D CHAND13 D CHAND14 D CHAND21 D CHAND22 D CHAND23 D CHAND24 D CHAND31 D CHAND32 D CHAND33 D CHAND34 D CCRIB11 D CCRIB12 D CCRIB13 D CCRIB14 D CCRIB21 D CCRIB22 D CCRIB23 D CCRIB24 D CCRIB31 D CCRIB32 D CCRIB33 D CCRIB34 D UHAND11 D UHAND12 D UHAND13 D UHAND14 D UHAND21 D UHAND22 D UHAND23 D UHAND24 D UHAND31 D UHAND32 D UHAND33 D UHAND34 D UCRIB11 D UCRIB12 D UCRIB13 D UCRIB14 D UCRIB21 D UCRIB22 D UCRIB23 D UCRIB24 D UCRIB31 D UCRIB32 D UCRIB33 D UCRIB34 D UHAND15 D UHAND16 D UHAND25 D UHAND26 D UHAND35 D UHAND36 D DISCARD1 D DISCARD2 D DISCARD3 D DISCARD4 D DISCARD5 D DISCARD6 //--*FUNCTION PROTOTYPES----------------------------------- D f_KQJcount10 PR 3u 0 D 3u 0 const //--*ENTRY PARMS *NONE* ----------------------------------- C NewGameStart Tag /free // load initial screen to show lots of pretty colors. evalr scDow = %trimr(f_GetDayName()); Face(*) = *all' '; Attr(*) = *allx'00'; 1b for ah = 1 to 4; Attr(ah).Row(1).Col(*) = %bitor(RED: RI); Attr(ah).Row(2).Col(*) = %bitor(WHITE: RI); Attr(ah).Row(3).Col(*) = %bitor(BLUE: RI); 1e endfor; PlayCraig(*) = *blanks; PlayUser(*) = *blanks; PlayCraigA(1).Col(*) = %bitor(YELLOW: RI); PlayCraigA(2).Col(*) = %bitor(RED: RI); PlayCraigA(3).Col(*) = %bitor(GREEN: RI); PlayUserA(1).Col(*) = %bitor(YELLOW: RI); PlayUserA(2).Col(*) = %bitor(RED: RI); PlayUserA(3).Col(*) = %bitor(GREEN: RI); clear Deck1; clear Deck2; clear Deck3; Deck1A = %bitor(YELLOW: RI); Deck2A = %bitor(RED: RI); Deck3A = %bitor(GREEN: RI); // --load bar graphs-- BarCArry(*) = 'R'; //red BarUArry(*) = 'B'; //blue barccnt = 120; barucnt = 120; clear u121; clear c121; runningtot = 31; Ind.CribMsgCraig = *on; Ind.CribMsgUser = *on; Ind.ColrBarCraig = *off; Ind.ColrBarUser = *off; Ind.PlayMsg = *off; clear PlayMsg; UserMsg = 'Press Enter to begin!'; exfmt SCREEN; 1b if InfdsFkey = f03; exsr srExitPgm; 1e endif; // Initialize stuff for new game to begin. WhoseCrib = 2; //player 1st crib barucnt = 0; barccnt = 0; clear u121; clear c121; IsGameOver = *off; barCds = *all'.'; barUds = *all'.'; Ind.CribMsgCraig = *off; Ind.CribMsgUser = *off; Ind.ColrBarCraig = *off; Ind.ColrBarUser = *off; Ind.CraigSaysGo = *off; Ind.UserSaysGo = *off; //user GO flag exsr srNextHand; exsr srUserDealt; //--------------------------------------------------------- // Play the game. logic for non-linear game. Displays and logic depend // on where you are in play, what card values, who went first last time. // I am going to use a flag concept to keep track of what is happening. // Could get real complicated. 1b dou 1 = 2; 2b if NextStepFlg = 'Craig Plays a Card ' or NextStepFlg = 'Play Craig 1st card '; 2x else; exfmt SCREEN; 2e endif; 2b if InfdsFkey = f03; 1v leave; 2e endif; usermsga = *blanks; UserMsg = *blanks; //--------------------------------------------------------- // Show users hand and allow selection of discards. // User discard editing and beginning game play. 2b if NextStepFlg = 'Show User Discard Screen '; exsr srUserDealt; 2x elseif NextStepFlg = 'Edit Discard Selection '; exsr srUserDiscard; //--------------------------------------------------------- // It didn't take long to get complicated. At first I coded play-logic-smart SR // but with GO logic being what it is, it was way too cumbersome to control. // Now I am going to make idiot savant subroutines that try to do one simple // step (or not so simple). They will report status back of what they did and // all grim complicated control logic will be here. // ------------------------------ // GO logic. If person can play card, check other players hand for GO // condition. If found, set flag and allow current person to continue. // ------------------------------ // User plays card. // 1). Craig has cards but 2) cannot play without going over 31. // Set on Craig go message. // Allow user to play another card. // user plays until 1)runs out of cards 2)makes 31 3)not play without over 31. // At end of one these sequences, // give user GO for 1, reset play, let Craig play next card. // ------------------------------ // Craig plays card. // 1) User has cards but 2) cannot play without going over 31. // set on user GO message. // FRCWTR and allow Craig to spin through playing all possible cards until // 1)runs out of cards 2)makes 31 3)not play without over 31. // At end of one these sequences, // give Craig GO for 1, reset play, let user play next card. // ------------------------------ // Special circumstance // And this may be changed cause I can't seem to find a clear ruling on this // If Craig is out of cards and user can't play, still give Craig // a GO for 1 to reset deck count. // or vice versa if user is out of cards and Craig can't play. //--------------------------------------------------------- 2x elseif NextStepFlg = 'Craig Plays a Card '; exsr srCraigPlay; WhoPlayed = 'Craig'; 3b if NextStepFlg = 'Edit Discard Selection '; //HAND OVER //user at GO /Craig has cards /Craig can still play 3x elseif IsUserGo and //User can't play (not IsCraigOut) and //Craig has cards (not IsCraigGo); //Craig has cards NextStepFlg = 'Craig Plays a Card '; write screen; //user at GO /Craig has cards /Craig cannot play 3x elseif IsUserGo and //User can't play (not IsCraigOut) and //Craig has cards IsCraigGo; //Craig cant play Ind.CraigSaysGo = *off; IsGO = *on; exsr srScorePlayed; IsGO = *off; NextStepFlg = 'User Selects a Card for Play '; // - user at GO / Craig has no cards. 3x elseif IsUserGo and //User can't play IsCraigOut; //Craig played all Ind.CraigSaysGo = *off; IsGO = *on; exsr srScorePlayed; IsGO = *off; NextStepFlg = 'User Selects a Card for Play '; // - Craig played normally or Craig played last card 3x elseif srCraigStat = 'Craig Played Card OK' or IsCraigOut; //Craig played all Ind.CraigSaysGo = *off; NextStepFlg = 'User Selects a Card for Play '; 3e endif; //--------------------------------------------------------- // USER selects card for play 2x elseif NextStepFlg = 'User Selects a Card for Play '; exsr srUserPlay; WhoPlayed = 'You'; 3b if NextStepFlg = 'Edit Discard Selection '; //HAND OVER //--------------------------------------------------------- // Check for error messages //picked card with too high face value 3x elseif srUserStat = 'Over 31. Select a lower card.'; usermsga = %bitor(GREEN: RI); UserMsg = 'Over 31. Select lower card'; NextStepFlg = 'User Selects a Card for Play '; // must select one card 3x elseif srUserStat = 'User must select 1 card'; usermsga = %bitor(GREEN: RI); UserMsg = 'Select 1 card to Play. '; NextStepFlg = 'User Selects a Card for Play '; //Craig at GO /User has cards /User can play 3x elseif IsCraigGo and //Craig can't play (not IsCraigOut) and //Craig has cards (not IsUserOut) and //User has cards (not IsUserGo); //User can play NextStepFlg = 'User Selects a Card for Play '; //Craig at GO /User has cards /User cannot play 3x elseif IsCraigGo and //Craig can't play (not IsCraigOut) and //Craig has cards (not IsUserOut) and //User has cards IsUserGo; //User cant play Ind.UserSaysGo = *off; IsGO = *on; exsr srScorePlayed; IsGO = *off; NextStepFlg = 'Craig Plays a Card '; //Craig at GO /User has played all cards. 3x elseif IsCraigGo and //Craig can't play (not IsCraigOut) and //Craig has cards IsUserOut; //User played all card Ind.UserSaysGo = *off; IsGO = *on; exsr srScorePlayed; IsGO = *off; NextStepFlg = 'Craig Plays a Card '; // - user played normally or played last card 3x elseif srUserStat = 'User Played Card OK' or IsUserOut; //User has no cards NextStepFlg = 'Craig Plays a Card '; 3e endif; //--------------------------------------------------------- // Strategy for Craig to pick 1st card to play. 2x elseif NextStepFlg = 'Play Craig 1st card'; exsr srCraigLead1st; //play Craig 1st card 2e endif; srCraigStat = *blanks; srUserStat = *blanks; 1e enddo; *inlr = *on; return; write assume; //--------------------------------------------------------- // Craig selects and plays card. // Make sure Craig has any cards left. // Make sure Craigs selection will not go over 31. // Spin through all plays and find highest scoring play. begsr srCraigPlay; srCraigStat = *blanks; exsr srChkAllPlayd; 1b if not IsCraigOut; //--------------------------------------------------------- // See if Craig has any cards that will score 31. // If so select that card 1st. 2b if RunningTot >= 21; 3b for ad = 1 to 4; 4b if not IsCraigCardPlayed(ad) and f_KQJcount10(CFace4(ad)) + RunningTot = 31; ah = 1; PlayThisCard = ad; WhoPlayed = 'Craig'; exsr srPlayOneCard; exsr srScorePlayed; //load message to scr srCraigStat = 'Craig Played Card OK'; 3v leave; 4e endif; 3e endfor; 2e endif; 2b if srCraigStat <> 'Craig Played Card OK'; ah = 1; //--------------------------------------------------------- // Pickbest // If I get to here Craig has cards that will score less than 31. // One at a time load each card into playIt array // that will score less than 32 and check scores. // Card resulting in highest score will be selected. // If nothing scores, play highest card. NxtPlayCard += 1; clear PlayThisCard; clear BestScore; clear PickHighCard; IsLoadGraph = *off; IsPickBest = *on; //set flag to scoring subroutine 3b for ad = 1 to 4; 4b if not IsCraigCardPlayed(ad) and f_KQJcount10(CFace4(ad)) + RunningTot < 32; PlayIt(NxtPlayCard) = cPlay4(ad); exsr srScorePlayed; //score hand exsr srGetBarScore; //add total 5b if HandScore > BestScore; //pick highest score BestScore = HandScore; PlayThisCard = ad; 5e endif; 5b if BestScore = 0 and CFace4(ad) > PickHighCard; //pick highest card PickHighCard = CFace4(ad); PlayThisCard = ad; 5e endif; 4e endif; 3e endfor; //--------------------------------------------------------- pface(NxtPlayCard) = 0; //remove test card psuite(NxtPlayCard) = *blanks; //remove test card NxtPlayCard -= 1; //reset nxt play cnt IsPickBest = *off; //flag to scoring subr IsLoadGraph = *on; WhoPlayed = 'Craig'; exsr srPlayOneCard; exsr srScorePlayed; //load message to scr srCraigStat = 'Craig Played Card OK'; 2e endif; 1e endif; exsr srChkForGO; endsr; //--------------------------------------------------------- // Move bar graph to reflect totals. // Also check for end of game / winner conditions. begsr srMoveBarGraph; IsGameOver = *off; 1b if IsLoadGraph; 2b if HandScore > 0; 3b if WhoPlayed = 'Craig'; //Craig scored BarCcnt += HandScore; 4b if BarCcnt >= 121; //Craig Won BarCcnt = 121; ByHowMuch = BarCcnt - BarUcnt; Ind.ColrBarCraig = *on; c121 = 'X'; BarCds = *all'R'; IsGameOver = *on; 4x else; 5b for ab = 1 to BarCcnt; barcarry(ab) = 'X'; 5e endfor; 4e endif; 3x else; //--------------------------------------------------------- BarUcnt += HandScore; 4b if BarUcnt >= 121; //Craig Won BarUcnt = 121; ByHowMuch = BarUcnt - BarCcnt; //difference for end Ind.ColrBarUser = *on; u121 = 'X'; BarUds = *all'B'; IsGameOver = *on; 4x else; 5b for ab = 1 to BarUcnt; barUarry(ab) = 'X'; 5e endfor; 4e endif; 3e endif; 2e endif; 1e endif; //--------------------------------------------------------- // If I have winner, stop game and show results. 1b if IsGameOver; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' WON by ' + %triml(%editc(ByHowMuch:'4')) + ' .' + ' Press Enter to Play again.'; Ind.Play1stCard = *off; Ind.Play2ndCard = *off; Ind.Play3rdCard = *off; Ind.Play4thCard = *off; Ind.Play5thCard = *off; Ind.Play6thCard = *off; clear usermsga; clear usermsg; exfmt SCREEN; 2b if InfdsFkey = f03; exsr srExitPgm; 2e endif; /end-free GO C goto NewGameStart /free 1e endif; endsr; //--------------------------------------------------------- // If running total > 21, check both hands to see if // either player can next play under 32. begsr srChkForGO; IsCraigGo = *off; Ind.CraigSaysGo = *off; IsUserGo = *off; Ind.UserSaysGo = *off; PlayAbleCnt = 0; exsr srChkAllPlayd; 1b if RunningTot > 21; 2b if not IsUserOut; 3b for ad = 1 to 4; 4b if not IsUserCardPlayed(ad) and f_KQJcount10(uFace4(ad)) + RunningTot < 32; PlayAbleCnt += 1; 3v leave; 4e endif; 3e endfor; 3b if PlayAbleCnt = 0; //GO button IsUserGo = *on; Ind.UserSaysGo = *on; 3e endif; 2e endif; //--------------------------------------------------------- 2b if not IsCraigOut; PlayAbleCnt = 0; 3b for ad = 1 to 4; 4b if not IsCraigCardPlayed(ad) and f_KQJcount10(cFace4(ad)) + RunningTot < 32; PlayAbleCnt += 1; 3v leave; 4e endif; 3e endfor; 3b if PlayAbleCnt = 0; //GO button IsCraigGo = *on; Ind.CraigSaysGo = *on; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // play users selection. begsr srUserPlay; srUserStat = *blanks; exsr srChkAllPlayd; 1b if not IsUserOut; // Make sure user has selected single card. ax = 0; 2b for ad = 1 to 4; 3b if Discardx(ad) > ' '; ax += 1; PlayThisCard = ad; 3e endif; 2e endfor; 2b if ax <> 1; srUserStat = 'User must select 1 card'; 2x else; // Now I know user has cards that will play. 3b if f_KQJcount10(uFace4(PlayThisCard)) + RunningTot > 31; srUserStat = 'Over 31. Select a lower card.'; 3x else; //--------------------------------------------------------- // Ok, user has got card to play and they have selected // one with total below 31. Load card into arena. // remove X selection for that space. ah = 3; exsr srPlayOneCard; 4b if Ind.Play1stCard; Ind.Play1stCard = (1 <> PlayThisCard); 4e endif; 4b if Ind.Play2ndCard; Ind.Play2ndCard = (2 <> PlayThisCard); 4e endif; 4b if Ind.Play3rdCard; Ind.Play3rdCard = (3 <> PlayThisCard); 4e endif; 4b if Ind.Play4thCard; Ind.Play4thCard = (4 <> PlayThisCard); 4e endif; // Score hand. WhoPlayed = 'You'; exsr srScorePlayed; //load message to scr srUserStat = 'User Played Card OK'; 3e endif; clear DiscardX; 2e endif; 1e endif; exsr srChkForGO; //Check Craig GO endsr; //--------------------------------------------------------- // Show users hand and allow selection of discards. begsr srUserDealt; Ind.Play1stCard = *on; Ind.Play2ndCard = *on; Ind.Play3rdCard = *on; Ind.Play4thCard = *on; Ind.Play5thCard = *on; Ind.Play6thCard = *on; indsav.Play1stCard = *on; indsav.Play2ndCard = *on; indsav.Play3rdCard = *on; indsav.Play4thCard = *on; clear DiscardX; clear usermsga; UserMsg = 'Use X to select 2 cards to discard.'; NextStepFlg = 'Edit Discard Selection '; endsr; //--------------------------------------------------------- // Make sure user has selected only 2 cards for discard. // Load and 'turn over' starting card. // Load discard into crib // Load 4 remaining cards into user hand array begsr srUserDiscard; srUserStat = *blanks; ax = 0; 1b for ad = 1 to 6; 2b if DiscardX(ad) > ' '; ax += 1; 2e endif; 1e endfor; 1b if ax < 2 or ax > 2; usermsga = %bitor(GREEN: RI); UserMsg = 'Use X to select 2 cards to discard.'; 1x else; // 2 selected * usermsga = *blanks; UserMsg = 'X card to Play.'; NextStepFlg = 'User Selects a Card for Play '; // 'turn over' 13th card from deck to be to start card. Ind.Play5thCard = *off; Ind.Play6thCard = *off; Deck1 = f_GetCardFace(NewCard(13)); Deck1a = %bitor(WHITE: PR: UL); Deck2a = f_GetCardColor(NewSuite(13)); Deck3a = f_GetCardColor(NewSuite(13)); //--------------------------------------------------------- // Load two user discards into crib . // Load four 'keepers' into users Play array. clear ac; ax = 0; clear ay; clear UPlay4; 2b for ad = 1 to 6; 3b if DiscardX(ad) > ' '; ax += 1; CribCards(ax) = uDealt(ad); 3x else; ac += 1; uPlay4(ac) = uDealt(ad); 3e endif; 2e endfor; // Load screen with four playing cards. Clear 5 & 6 sorta uPlay4; Attr(3).Row(1).Col(*) = %bitor(WHITE: PR: UL); Attr(3).Row(3).Col(*) = x'00'; 2b for ax = 1 to 4; Face(3).Row(1).Col(ax) = f_GetCardFace(uFace4(ax)); Attr(3).Row(2).Col(ax) = f_GetCardColor(uSuite4(ax)); 2e endfor; clear uHand15; clear uhand16; clear uhand15a; clear uhand16a; clear uhand25a; clear uhand26a; clear uhand35a; clear uhand36a; clear DiscardX; 2b if WhoseCrib = 1; NextStepFlg = 'Play Craig 1st card'; ah = 4; 2x else; NextStepFlg = 'User Selects a Card for Play '; ah = 2; 2e endif; Face(ah).Row(1).Col(1) = *blanks; Face(ah).Row(2).Col(1) = *blanks; Face(ah).Row(3).Col(1) = *blanks; Face(ah).Row(1).Col(2) = *blanks; Face(ah).Row(2).Col(2) = *blanks; Face(ah).Row(3).Col(2) = *blanks; Attr(ah).Row(1).Col(1) = %bitor(RED: RI); Attr(ah).Row(2).Col(1) = %bitor(WHITE: RI); Attr(ah).Row(3).Col(1) = %bitor(BLUE: RI); Attr(ah).Row(1).Col(2) = %bitor(RED: RI); Attr(ah).Row(2).Col(2) = %bitor(WHITE: RI); Attr(ah).Row(3).Col(2) = %bitor(BLUE: RI); // Check Starter Card for 'Heels' exsr srScoreHeels; 1e endif; endsr; //--------------------------------------------------------- // Score 'Heels' begsr srScoreHeels; 1b if NewCard(13) = 11; //starter card = jack 2b if WhoseCrib = 1; WhoPlayed = 'You'; 2x else; WhoPlayed = 'Craig'; 2e endif; HandScore = 2; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Heels for 2. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 2b if InfdsFkey = f03; exsr srExitPgm; 2e endif; clear PlayMsg; Ind.PlayMsg = *off; 1e endif; endsr; //--------------------------------------------------------- // Craig picks 1st card to play. There are lots of strategies that // could be applied here. I am going to keep it fairly simple to start out. // This subroutine can also be executed after GO, so I have to be sensitive // about what cards have already been played out of the hand. // Array IsCraigCardPlayed = *off if that card is available to play. // Probably easiest just to spin through Craigs hand and load flags. // Check flags, Spin back through and play selected card. begsr srCraigLead1st; CraigLeadTwo = *off; CraigLeadThree = *off; CraigLeadFour = *off; CraigLeadFive = *off; CraigLeadSix = *off; CraigLeadNine = *off; CraigLeadTen = *off; CraigLeadAny = *off; 1b for ad = 1 to 4; 2b if not IsCraigCardPlayed(ad); CraigLeadAny = *on; 3b if cFace4(ad) = 2; CraigLeadTwo = *on; 3x elseif cFace4(ad) = 3; CraigLeadThree = *on; 3x elseif cFace4(ad) = 4; CraigLeadFour = *on; 1v leave; 3x elseif cFace4(ad) = 5; CraigLeadFive = *on; 3x elseif cFace4(ad) = 6; CraigLeadSix = *on; 3x elseif cFace4(ad) = 9; CraigLeadNine = *on; 3x elseif cFace4(ad) >= 10; CraigLeadTen = *on; 3e endif; 2e endif; 1e endfor; // ---- 1b if CraigLeadAny; //--------------------------------------------------------- // Play a 4. // Play 6 if Craig has a 9. // Play 10 if Craig has a 5. // Play a 2 or 3. (save aces for 31s!). // Play first non-5 / non-ace card. // if only thing left is 5 or ace, play the 5. // Leave loop when card is found that matches one of strategy criteria. IsFound = *off; 2b for ad = 1 to 4; 3b if not IsCraigCardPlayed(ad); 4b if CraigLeadFour and cFace4(ad) = 4; IsFound = *on; 2v leave; 4x elseif CraigLeadSix and CraigLeadNine and cFace4(ad) = 6; IsFound = *on; 2v leave; 4x elseif CraigLeadTen and CraigLeadFive and cFace4(ad) >= 10; IsFound = *on; 2v leave; 4x elseif CraigLeadThree and cFace4(ad) = 3; IsFound = *on; 2v leave; 4x elseif CraigLeadTwo and cFace4(ad) = 2; IsFound = *on; 2v leave; 4e endif; 3e endif; 2e endfor; // Else play first non-5 / non-ace card. // if only thing left is 5 or ace, play the 5 2b if not IsFound; 3b for ad = 1 to 4; 4b if not IsCraigCardPlayed(ad); 5b if cFace4(ad) = 1 or cFace4(ad) = 5; 5x else; IsFound = *on; 3v leave; 5e endif; 4e endif; 3e endfor; 2e endif; // If still nothing, play 1st available card. 2b if not IsFound; 3b for ad = 1 to 4; 4b if not IsCraigCardPlayed(ad); IsFound = *on; 3v leave; 4e endif; 3e endfor; 2e endif; //--------------------------------------------------------- // At this point, ad should equal index of // card from Craigs hand it wants to play. ah = 1; PlayThisCard = ad; exsr srPlayOneCard; 1e endif; NextStepFlg = 'User Selects a Card for Play '; endsr; //--------------------------------------------------------- // 1. If card go past 31, return error. // 2. load Craigs/users card into play array. // 3. load play card array to play card screen hand. // 4. blank out card in Craig/users screen hand // 5. Check and see if is last card played. begsr srPlayOneCard; IsOver31 = *off; WhoPlayedLast = *blanks; RunningTot = 0; 1b for ax = 1 to 8; 2b if pFace(ax) = 0; 1v leave; 2e endif; RunningTot += f_KQJcount10(pFace(ax)); 1e endfor; 1b if ah = 1; 2b if RunningTot + f_KQJcount10(cFace4(PlayThisCard)) > 31; IsOver31 = *on; 2e endif; 1x else; 2b if RunningTot + f_KQJcount10(uFace4(PlayThisCard)) > 31; IsOver31 = *on; 2e endif; 1e endif; 1b if not IsOver31; NxtPlayCard += 1; 2b if ah = 1; NxtPlayc += 1; RunningTot = RunningTot + f_KQJcount10(cFace4(PlayThisCard)); IsCraigCardPlayed(PlayThisCard) = *on; PlayIt(NxtPlayCard) = cPlay4(PlayThisCard); PlayCraigA(1).Col(NxtPlayC) = %bitor(WHITE: PR: UL); PlayCraigA(2).Col(NxtPlayC) = f_GetCardColor(pSuite(NxtPlayCard)); PlayCraigA(3).Col(NxtPlayC) = f_GetCardColor(pSuite(NxtPlayCard)); PlayCraig(1).Col(NxtPlayC) = f_GetCardFace(pFace(NxtPlayCard)); WhoPlayedLast = 'Craig'; 2x else; NxtPlayU += 1; RunningTot = RunningTot + f_KQJcount10(uFace4(PlayThisCard)); IsUserCardPlayed(PlayThisCard) = *on; PlayIt(NxtPlayCard) = uPlay4(PlayThisCard); PlayUserA(1).Col(NxtPlayU) = %bitor(WHITE: PR: UL); PlayUserA(2).Col(NxtPlayU) = f_GetCardColor(pSuite(NxtPlayCard)); PlayUserA(3).Col(NxtPlayU) = f_GetCardColor(pSuite(NxtPlayCard)); PlayUser(1).Col(NxtPlayU) = f_GetCardFace(pFace(NxtPlayCard)); WhoPlayedLast = 'You'; 2e endif; //Spin back through blanking out Craig/user card from hand 2b for ax = 1 to 3; Face(ah).Row(ax).Col(PlayThisCard) = *blanks; Attr(ah).Row(ax).Col(PlayThisCard) = x'00'; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // Show score window for each hand. // Player that does not have crib // will be scored first and moved first. // 1). Turn Crib hand Over. // 2). Determine who to score first. // 3). Check 4 cards in players hand for flush. // 4). Combine 4 cards in players hand with start card. // 5). Position window relative to hand being scored. // 6). pop-up window. // 7) repeat steps 3 through 6 for player with crib. // Note: Flush processing is different for crib. // all 4 cards must match suite of starting card. begsr srScoreWindow; clear PlayMsg; Ind.PlayMsg = *off; Ind.BorderRed = *off; Ind.BorderBlue = *off; clear savdeck; SavCard = 0; SavDeck(1) = Newdeck(13); //load start card CardsToScore = 5; ShowScoreSbf = 'YES'; //Load cards to sbf pos = 27; //position window exsr srResetPlay; exsr srReShowHands; write screen; 1b if WhoseCrib = 1; //player has crib lin = 1; //position window exsr srScoreCraig; 2b if not IsGameOver; //Craig didn't win exsr srScoreUser; 2e endif; 1x else; //Craig has crib lin = 6; //position window exsr srScoreUser; 2b if not IsGameOver; //user didn't win exsr srScoreCraig; 2e endif; 1e endif; // Now score Crib. Give point to correct player! 1b if not IsGameOver; //nobody won yet SavDeck(2) = CribCards(1); SavDeck(3) = CribCards(2); SavDeck(4) = CribCards(3); SavDeck(5) = CribCards(4); TstDeck = SavDeck; 2b if WhoseCrib = 1; //player has crib scoremsg = ' Your Crib '; Ind.BorderRed = *off; Ind.BorderBlue = *on; 2x else; //Craig has crib Ind.BorderRed = *on; Ind.BorderBlue = *off; scoremsg = ' Craig' + QuoteMark + 's Crib'; 2e endif; IsLoadGraph = *off; exsr srScoreHand; // Flush? Flush is different for crib. All five must match IsFlush = *off; 2b if NewSuite(13) = CribSuite(1) and NewSuite(13) = CribSuite(2) and NewSuite(13) = CribSuite(3) and NewSuite(13) = CribSuite(4); IsFlush = *on; HandScore += 5; sbfTotal = HandScore; // -- write flush record ---- clear sbfscval; clear sbfscatr; sbfscMsg = 'Flush for 5'; 3b for sbfx = 1 to 5; sbfSCatr(sbfx) = f_GetCardColor(NewSuite(13)); 3e endfor; rrn += 1; write sbfdta1; Ind.sfldsp = *on; 2e endif; exsr srScoreNobs; exsr srScoreNada; //see if no score write sbfctl1; exfmt sfooter1; 2b if InfdsFkey = f03; exsr srExitPgm; 2e endif; IsLoadGraph = *on; exsr srMoveBarGraph; 1e endif; ShowScoreSbf = 'NO '; endsr; //--------------------------------------------------------- // Load subfile for Craigs scores. begsr srScoreCraig; Ind.BorderRed = *on; Ind.BorderBlue = *off; SavDeck(2) = cPlay4(1); SavDeck(3) = cPlay4(2); SavDeck(4) = cPlay4(3); SavDeck(5) = cPlay4(4); TstDeck = SavDeck; scoremsg = ' Craig' + QuoteMark + 's Hand'; WhoPlayed = 'Craig'; IsLoadGraph = *off; exsr srScoreHand; // check for flush IsFlush = *off; 1b if csuite4(1) = csuite4(2) and csuite4(1) = csuite4(3) and csuite4(1) = csuite4(4); IsFlush = *on; HandScore += 4; sbfTotal = HandScore; // -- write flush record ---- clear sbfscval; clear sbfscatr; sbfscMsg = 'Flush for 4'; 2b for sbfx = 1 to 4; sbfSCatr(sbfx) = f_GetCardColor(csuite4(1)); 2e endfor; rrn += 1; write sbfdta1; Ind.sfldsp = *on; 1e endif; exsr srScoreNobs; exsr srScoreNada; write sbfctl1; exfmt sfooter1; 1b if InfdsFkey = f03; exsr srExitPgm; 1e endif; IsLoadGraph = *on; exsr srMoveBarGraph; endsr; //--------------------------------------------------------- // Load subfile for users scores. begsr srScoreUser; Ind.BorderRed = *off; Ind.BorderBlue = *on; SavDeck(2) = uPlay4(1); SavDeck(3) = uPlay4(2); SavDeck(4) = uPlay4(3); SavDeck(5) = uPlay4(4); TstDeck = SavDeck; scoremsg = ' Your Hand'; WhoPlayed = 'You'; IsLoadGraph = *off; exsr srScoreHand; // check for user flush IsFlush = *off; 1b if usuite4(1) = usuite4(2) and usuite4(1) = usuite4(3) and usuite4(1) = usuite4(4); IsFlush = *on; HandScore += 4; sbfTotal = HandScore; // -- write flush record ---- clear sbfscval; clear sbfscatr; sbfscMsg = 'Flush for 4'; 2b for sbfx = 1 to 4; sbfSCatr(sbfx) = f_GetCardColor(usuite4(1)); 2e endfor; rrn += 1; write sbfdta1; Ind.sfldsp = *on; 1e endif; exsr srScoreNobs; exsr srScoreNada; write sbfctl1; exfmt sfooter1; 1b if InfdsFkey = f03; exsr srExitPgm; 1e endif; IsLoadGraph = *on; exsr srMoveBarGraph; endsr; //--------------------------------------------------------- // Check for Nobs. Any hand that has Jack of // same suite as start card gets 1 point. begsr srScoreNobs; 1b for ax = 2 to 5; 2b if SavCard(ax) = 11 and SavSuite(ax) = NewSuite(13); HandScore += 1; sbfTotal = HandScore; // write nobs sbf record clear sbfscval; clear sbfscatr; sbfscMsg = 'Nobs For 1'; sbfSCatr(1) = f_GetCardColor(SavSuite(ax)); sbfSCval(1) = f_GetCardFace(SavCard(ax)); rrn += 1; write sbfdta1; Ind.sfldsp = *on; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // If no score, write nothing for zero record begsr srScoreNada; 1b if HandScore = 0; clear sbfscatr; sbfscMsg = 'Nothing for Zero'; sbfSCval = '00'; rrn += 1; write sbfdta1; Ind.sfldsp = *on; 1e endif; endsr; //--------------------------------------------------------- // Select highest possible scoring hand for Craig // from six cards he was dealt. // Discard other two to appropriate crib begsr srLoadCraigHand; clear SavDeck; savCard = 0; clear TstDeck; TstCard = 0; clear BestB; clear BestC; clear BestD; clear BestScore; ShowScoreSbf = 'NO '; IsLoadGraph = *off; IsFlush = *off; 1b for BestA = 1 to 6; 2b for BestB = (BestA + 1) to 6; 3b for BestC = (BestB + 1) to 6; 4b for BestD = (BestC + 1) to 6; SavDeck(1) = cDealt(BestA); SavDeck(2) = cDealt(BestB); SavDeck(3) = cDealt(BestC); SavDeck(4) = cDealt(BestD); // See what this hand would be worth. TstDeck = SavDeck; CardsToScore = 4; exsr srScoreHand; 5b if cSuite(BestA) = cSuite(BestB) and cSuite(BestA) = cSuite(BestC) and cSuite(BestA) = cSuite(BestD); IsFlush = *on; HandScore += 4; 5e endif; 5b if HandScore > BestScore; BestIndexA = BestA; BestIndexB = BestB; BestIndexC = BestC; BestIndexD = BestD; BestScore = handscore; 5e endif; 4e endfor; 3e endfor; 2e endfor; 1e endfor; //--------------------------------------------------------- // Craig got crummy hand into which nothing scored. // There is room for strategy here but to keep it simple // I would like to keep any ACE or any 5 or any Jack(nobs) // Beyond that keep lowest cards for better opportunities // while in play. 1b if BestScore = 0; IsCardSelected = *off; clear ax; 2b for ay = 1 to 6; 3b if cFace(ay) = 1; ax += 1; BestArry(ax) = ay; IsCardSelected(ay) = *on; 3x elseif cFace(ay) = 5; ax += 1; BestArry(ax) = ay; IsCardSelected(ay) = *on; 3x elseif cFace(ay) = 11; ax += 1; BestArry(ax) = ay; IsCardSelected(ay) = *on; 3e endif; 2e endfor; // At best I would have only loaded three cards. 2b for ay = 1 to 6; 3b if not IsCardSelected(ay); ax += 1; 4b if ax = 5; 2v leave; 4e endif; BestArry(ax) = ay; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // Discard 2 indexes that are not best index values. clear BestDiscard1; clear BestDiscard2; 1b for BestA = 1 to 6; 2b if BestA = BestIndexA or BestA = BestIndexB or BestA = BestIndexC or BestA = BestIndexD; 2x else; 3b if BestDiscard1 = 0; BestDiscard1 = BestA; 3x else; BestDiscard2 = BestA; 3e endif; 2e endif; 1e endfor; //--------------------------------------------------------- // load best cards to Craig playing hand/load discards to crib cPlay4(1) = cDealt(BestIndexa); cPlay4(2) = cDealt(BestIndexb); cPlay4(3) = cDealt(BestIndexc); cPlay4(4) = cDealt(BestIndexd); clear CribCards; CribFace = 0; CribCards(3) = cDealt(BestDiscard1); CribCards(4) = cDealt(BestDiscard2); Face(1).Row(1).Col(*) = *blanks; Face(1).Row(2).Col(*) = *blanks; Face(1).Row(3).Col(*) = *blanks; Attr(1).Row(1).Col(*) = %bitor(RED: RI); Attr(1).Row(2).Col(*) = %bitor(WHITE: RI); Attr(1).Row(3).Col(*) = %bitor(BLUE: RI); 1b if WhoseCrib = 1; //Player 1st crib ah = 4; 1x else; ah = 2; 1e endif; Face(ah).Row(1).Col(3) = *blanks; Face(ah).Row(2).Col(3) = *blanks; Face(ah).Row(3).Col(3) = *blanks; Face(ah).Row(1).Col(4) = *blanks; Face(ah).Row(2).Col(4) = *blanks; Face(ah).Row(3).Col(4) = *blanks; Attr(ah).Row(1).Col(3) = %bitor(RED: RI); Attr(ah).Row(2).Col(3) = %bitor(WHITE: RI); Attr(ah).Row(3).Col(3) = %bitor(BLUE: RI); Attr(ah).Row(1).Col(4) = %bitor(RED: RI); Attr(ah).Row(2).Col(4) = %bitor(WHITE: RI); Attr(ah).Row(3).Col(4) = %bitor(BLUE: RI); IsLoadGraph = *on; //enable graph load endsr; //--------------------------------------------------------- // Turn up Crib Cards. begsr srShowCrib; sorta CribCards; 1b if WhoseCrib = 1; ah = 4; 1x else; ah = 2; 1e endif; Attr(ah).Row(1).Col(*) = %bitor(WHITE: PR: UL); 1b for ax = 1 to 4; Face(ah).Row(1).Col(ax) = f_GetCardFace(CribFace(ax)); Attr(ah).Row(2).Col(ax) = f_GetCardColor(CribSuite(ax)); Attr(ah).Row(3).Col(ax) = f_GetCardColor(CribSuite(ax)); 1e endfor; endsr; //--------------------------------------------------------- // Deal next hand. begsr srNextHand; Face(*) = *all' '; Attr(*) = *allx'00'; PlayCraig(*) = *all' '; PlayCraigA(*) = *allx'00'; PlayUser(*) = *all' '; PlayUserA(*) = *allx'00'; clear NxtPlayC; clear NxtPlayU; clear Deck1A; clear Deck2A; clear Deck3A; clear Deck1; clear Deck2; clear Deck3; clear PlayIt; clear WhoPlayedLast; IsUserGo = *off; IsCraigGo = *off; IsUserOut = *off; IsCraigOut = *off; IsPickBest = *off; clear NxtPlayCard; pFace = 0; clear PlayThisCard; uFace = 0; uFace4 = 0; cFace = 0; cFace4 = 0; CribFace = 0; TstCard = 0; RunCard = 0; SavCard = 0; RunningTot = 0; clear srCraigStat; clear srUserStat; ShowScoreSbf = 'NO '; Ind.CribMsgCraig = *off; Ind.CribMsgUser = *off; Ind.ColrBarCraig = *off; Ind.ColrBarUser = *off; Ind.CraigSaysGo = *off; Ind.UserSaysGo = *off; // --swap crib 1b if WhoseCrib = 2; WhoseCrib = 1; Ind.CribMsgUser = *on; 1x else; WhoseCrib = 2; Ind.CribMsgCraig = *on; 1e endif; IsCraigCardPlayed = *off; IsUserCardPlayed = *off; IsOver31 = *off; IsGO = *off; NewDeck = f_ShuffleDeck(); exsr srDeal6Cards; //deal 1st hand endsr; //--------------------------------------------------------- // Deal 6 cards to users/Craigs hand. begsr srDeal6Cards; clear ax; 1b for Deal = 1 by 2 to 11; ax += 1; uDealt(ax) = NewDeck(Deal); 1e endfor; // load even cards to Craig. clear ax; 1b for Deal = 2 by 2 to 12; ax += 1; cDealt(ax) = NewDeck(Deal); 1e endfor; clear ax; //--------------------------------------------------------- // Load 6 user card faces to screen. // note that only first four cards are in array. 5th and 6th card are // only used for crib selection and play minor part in overall scheme. // I decided to make them just fields and deal with them separately. // Load cards function returns card face (A 1 2 3 4 J Q K) and color // attribute for card in hand. // users hand = 3ah sorta uDealt; Attr(3).Row(1).Col(*) = %bitor(WHITE: PR: UL); Attr(3).Row(3).Col(*) = x'00'; 1b for ax = 1 to 4; Face(3).Row(1).Col(ax) = f_GetCardFace(uFace(ax)); Attr(3).Row(2).Col(ax) = f_GetCardColor(uSuite(ax)); 1e endfor; uHand15 = f_GetCardFace(uface(5)); uhand16 = f_GetCardFace(uface(6)); uhand15a = %bitor(WHITE: PR: UL); uhand16a = %bitor(WHITE: PR: UL); uhand25a = f_GetCardColor(uSuite(5)); uhand26a = f_GetCardColor(uSuite(6)); uhand35a = x'00'; uhand36a = x'00'; exsr srLoadCraigHand; endsr; //--------------------------------------------------------- // Load scoring cards and colors into subfile. begsr srLoadSbfRec; clear sbfscval; clear sbfscatr; 1b if sbfscMsg = 'Run of 5 for 5' or sbfscMsg = 'Run of 4 for 4' or sbfscMsg = 'Run of 3 for 3'; sbfx = cardcount; 2b for sbfxb = 1 to CardCount; sbfSCatr(sbfxb) = f_GetCardColor(TstSuite(IndexArry(sbfx))); sbfSCval(sbfxb) = f_GetCardFace(TstCard(IndexArry(sbfx))); sbfx -= 1; 2e endfor; 1x else; 2b for sbfx = 1 to CardCount; sbfSCatr(sbfx) = f_GetCardColor(TstSuite(IndexArry(sbfx))); sbfSCval(sbfx) = f_GetCardFace(TstCard(IndexArry(sbfx))); 2e endfor; 1e endif; rrn += 1; write sbfdta1; Ind.sfldsp = *on; endsr; //--------------------------------------------------------- // Scoring while in play is concerning with cards played IN SEQUENCE backwards // from last card played. // Even runs of are different. You can only count runs starting from card played. // Add of total face value of cards and any scoring combinations. // Process GO by giving message but no other processing begsr srScorePlayed; 1b if not IsGO; SavDeck = Playit; TstDeck = SavDeck; clear AllGroupings; clear sFifteens; clear sPairs; clear sThreeOfKind; clear sFourOfKind; clear sRunOf3s; clear sRunOf4s; clear sRunOf5s; clear sRunOf6s; clear sRunOf7s; // Check all cards played for 15 total clear Check; 2b for ax = 1 to NxtPlayCard; Check += f_KQJcount10(TstCard(ax)); 3b if check > 15; 2v leave; 3e endif; 2e endfor; 2b if Check = 15; sFifteens = 1; 2e endif; //--------------------------------------------------------- // look for 4 of a kinds, 3 of a kinds and pairs. // You can't count same cards twice. // ie if you have 4 of a kind you cannot also // count same cards as 2 pairs. // Going to look for 4s first. 2b dou '1'; an = NxtPlayCard; 3b if NxtPlayCard >= 4; 4b if TstCard(an) = TstCard(an - 1) and TstCard(an) = TstCard(an - 2) and TstCard(an) = TstCard(an - 3); sFourOfKind += 1; 2v leave; 4e endif; 3e endif; // Repeat process for 3 of a kind 3b if NxtPlayCard >= 3; 4b if TstCard(an) = TstCard(an - 1) and TstCard(an) = TstCard(an - 2); sThreeOfKind += 1; 2v leave; 4e endif; 3e endif; // Repeat process for pairs 3b if NxtPlayCard >= 2; 4b if TstCard(an) = TstCard(an - 1); sPairs += 1; 2v leave; 4e endif; 3e endif; 2e enddo; // Check for runs in a row. exsr srRunsInRow; 1e endif; //end GO skip 1b if not IsPickBest; //--------------------------------------------------------- // Load score message on screen. // 2 cards active - pair or 15 for 2 // 3 cards active - 3 of a kind or run of 3 // 4 cards active - 4 of a kind or run of 4 // 5 cards active and up - run of that number of cards. clear HandScore; clear PlayMsg; Ind.PlayMsg = *off; indsav.Play1stCard = Ind.Play1stCard; indsav.Play2ndCard = Ind.Play2ndCard; indsav.Play3rdCard = Ind.Play3rdCard; indsav.Play4thCard = Ind.Play4thCard; Ind.Play1stCard = *off; Ind.Play2ndCard = *off; Ind.Play3rdCard = *off; Ind.Play4thCard = *off; 2b if not IsGO; 3b if sFifteens > 0; HandScore = 2; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored 15 for 2. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3e endif; 3b if sRunOf7s > 0; HandScore = 7; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 7 for 7. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sRunOf6s > 0; HandScore = 6; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 6 for 6. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sRunOf5s > 0; HandScore = 5; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 5 for 5. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sFourOfKind > 0; HandScore = 12; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored 4 of a kind for 12. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sRunOf4s > 0; HandScore = 4; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 4 for 4. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sThreeOfKind > 0; HandScore = 6; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored 3 of a kind for 6. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sRunOf3s > 0; HandScore = 3; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 3 for 3. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3x elseif sPairs > 0; HandScore = 2; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Pair for 2. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; 3e endif; 3b if RunningTot = 31; Ind.CraigSaysGo = *off; Ind.UserSaysGo = *off; HandScore = 1; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored 31 for 1. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 4b if InfdsFkey = f03; exsr srExitPgm; 4e endif; exsr srResetPlay; 3e endif; 2x else; //--------------------------------------------------------- // Process Go scoring here. HandScore = 1; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored GO for 1. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 3b if InfdsFkey = f03; exsr srExitPgm; 3e endif; exsr srResetPlay; 2e endif; //--------------------------------------------------------- // Process last Card played scoring. // score 1 if count <> 31 // score 1 regardless // score 1 if count <> 31 score 2 if count = 31, etc. exsr srChkAllPlayd; 2b if IsUserOut and IsCraigOut; HandScore = 1; Ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Last Card for 1. Press Enter'; exsr srMoveBarGraph; exfmt SCREEN; 3b if InfdsFkey = f03; exsr srExitPgm; 3e endif; // If all cards played, pop up score window for each hand. exsr srShowCrib; exsr srScoreWindow; exsr srNextHand; exsr srUserDealt; 2e endif; clear PlayMsg; Ind.PlayMsg = *off; Ind.Play1stCard = indsav.Play1stCard; Ind.Play2ndCard = indsav.Play2ndCard; Ind.Play3rdCard = indsav.Play3rdCard; Ind.Play4thCard = indsav.Play4thCard; IsGO = *off; 1e endif; endsr; //--------------------------------------------------------- // Check for runs in a Row. begsr srRunsInRow; 1b if NxtPlayCard >= 7; ax = (-6) + NxtPlayCard; clear TstDeck; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; //--------------------------------------------------------- // run of 7 (yeah, i guess it could happen) 2b for a1 = 1 to 7; 3b for a2 = (a1 + 1) to 7; 4b for a3 = (a2 + 1) to 7; 5b for a4 = (a3 + 1) to 7; 6b for a5 = (a4 + 1) to 7; 7b for a6 = (a5 + 1) to 7; 8b for a7 = (a6 + 1) to 7; 9b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4 and TstCard(a1) = TstCard(a6) + 5 and TstCard(a1) = TstCard(a7) + 6; sRunOf7s += 1; LV leavesr; 9e endif; 8e endfor; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 6s 1b if NxtPlayCard >= 6; ax = (-5) + NxtPlayCard; clear TstDeck; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; 2b for a1 = 1 to 6; 3b for a2 = (a1 + 1) to 6; 4b for a3 = (a2 + 1) to 6; 5b for a4 = (a3 + 1) to 6; 6b for a5 = (a4 + 1) to 6; 7b for a6 = (a5 + 1) to 6; 8b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4 and TstCard(a1) = TstCard(a6) + 5; sRunOf6s += 1; LV leavesr; 8e endif; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 5s 1b if NxtPlayCard >= 5; ax = (-4) + NxtPlayCard; clear TstDeck; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; 2b for a1 = 1 to 5; 3b for a2 = (a1 + 1) to 5; 4b for a3 = (a2 + 1) to 5; 5b for a4 = (a3 + 1) to 5; 6b for a5 = (a4 + 1) to 5; 7b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4; sRunOf5s += 1; LV leavesr; 7e endif; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 4s 1b if NxtPlayCard >= 4; ax = ( - 3) + NxtPlayCard; clear TstDeck; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; 2b for a1 = 1 to 4; 3b for a2 = (a1 + 1) to 4; 4b for a3 = (a2 + 1) to 4; 5b for a4 = (a3 + 1) to 4; 6b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3; sRunOf4s += 1; LV leavesr; 6e endif; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 3s 1b if NxtPlayCard >= 3; ax = ( - 2) + NxtPlayCard; clear TstDeck; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; 2b for a1 = 1 to 3; 3b for a2 = (a1 + 1) to 3; 4b for a3 = (a2 + 1) to 3; 5b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2; sRunOf3s += 1; LV leavesr; 5e endif; 4e endfor; 3e endfor; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // Check both hands for all cards Played. begsr srChkAllPlayd; IsUserOut = *off; IsCraigOut = *off; 1b if IsCraigCardPlayed(1) and IsCraigCardPlayed(2) and IsCraigCardPlayed(3) and IsCraigCardPlayed(4); IsCraigOut = *on; 1e endif; 1b if IsUserCardPlayed(1) and IsUserCardPlayed(2) and IsUserCardPlayed(3) and IsUserCardPlayed(4); IsUserOut = *on; 1e endif; endsr; //--------------------------------------------------------- // Now add up score. begsr srGetBarScore; HandScore = (sFifteens * 2) + (sPairs * 2) + (sThreeOfKind * 6) + (sFourOfKind * 12) + (sRunOf3s * 3) + (sRunOf4s * 4) + (sRunOf5s * 5) + (sRunOf6s * 6) + (sRunOf7s * 7); 1b if not IsPickBest; exsr srMoveBarGraph; 1e endif; endsr; //--------------------------------------------------------- // Reset Played cards/count array after 31 total or a GO. begsr srResetPlay; clear RunningTot; clear PlayIt; clear NxtPlayCard; pFace = 0; PlayCraig(*) = *blanks; PlayCraigA(*) = *blanks; PlayUser(*) = *blanks; PlayUserA(*) = *blanks; clear NxtPlayC; clear NxtPlayU; IsCraigGo = *off; Ind.CraigSaysGo = *off; IsUserGo = *off; Ind.UserSaysGo = *off; endsr; //--------------------------------------------------------- // Add total face value of cards and any scoring combinations. begsr srScoreHand; 1b if ShowScoreSbf = 'YES'; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; clear sbfdta1; write sbfctl1; Ind.sfldspctl = *on; 1e endif; //--------------------------------------------------------- sFifteens = 0; // groups of twos clear AllGroupings; 1b for a1 = 1 to CardsToScore; 2b for a2 = (a1 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); Check = %xfoot(AllGroupings); 3b if Check = 15; sFifteens += 1; 4b if ShowScoreSbf = 'YES'; sbfscMsg = 'Fifteen for 2'; CardCount = 2; exsr srLoadSbfRec; 4e endif; 3e endif; 2e endfor; 1e endfor; // groups of threes 1b if CardsToScore >= 3; 2b for a1 = 1 to CardsToScore; 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); AllGroupings(3) = f_KQJcount10(TstCard(a3)); Check = %xfoot(AllGroupings); 5b if Check = 15; sFifteens += 1; 6b if ShowScoreSbf = 'YES'; sbfscMsg = 'Fifteen for 2'; CardCount = 3; exsr srLoadSbfRec; 6e endif; 5e endif; 4e endfor; 3e endfor; 2e endfor; 1e endif; // groups of 4 1b if CardsToScore >= 4; 2b for a1 = 1 to CardsToScore; 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; 5b for a4 = (a3 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); AllGroupings(3) = f_KQJcount10(TstCard(a3)); AllGroupings(4) = f_KQJcount10(TstCard(a4)); Check = %xfoot(AllGroupings); 6b if Check = 15; sFifteens += 1; 7b if ShowScoreSbf = 'YES'; sbfscMsg = 'Fifteen for 2'; CardCount = 4; exsr srLoadSbfRec; 7e endif; 6e endif; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; // groups of 5 1b if CardsToScore >= 5; 2b for a1 = 1 to CardsToScore; 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; 5b for a4 = (a3 + 1) to CardsToScore; 6b for a5 = (a4 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); AllGroupings(3) = f_KQJcount10(TstCard(a3)); AllGroupings(4) = f_KQJcount10(TstCard(a4)); AllGroupings(5) = f_KQJcount10(TstCard(a5)); Check = %xfoot(AllGroupings); 7b if Check = 15; sFifteens += 1; 8b if ShowScoreSbf = 'YES'; sbfscMsg = 'Fifteen for 2'; CardCount = 5; exsr srLoadSbfRec; 8e endif; 7e endif; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; // groups of 6 1b if CardsToScore >= 6; 2b for a1 = 1 to CardsToScore; 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; 5b for a4 = (a3 + 1) to CardsToScore; 6b for a5 = (a4 + 1) to CardsToScore; 7b for a6 = (a5 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); AllGroupings(3) = f_KQJcount10(TstCard(a3)); AllGroupings(4) = f_KQJcount10(TstCard(a4)); AllGroupings(5) = f_KQJcount10(TstCard(a5)); AllGroupings(6) = f_KQJcount10(TstCard(a6)); Check = %xfoot(AllGroupings); 8b if Check = 15; sFifteens += 1; 8e endif; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; // groups of 7 1b if CardsToScore >= 7; 2b for a1 = 1 to CardsToScore; 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; 5b for a4 = (a3 + 1) to CardsToScore; 6b for a5 = (a4 + 1) to CardsToScore; 7b for a6 = (a5 + 1) to CardsToScore; 8b for a7 = (a6 + 1) to CardsToScore; AllGroupings(1) = f_KQJcount10(TstCard(a1)); AllGroupings(2) = f_KQJcount10(TstCard(a2)); AllGroupings(3) = f_KQJcount10(TstCard(a3)); AllGroupings(4) = f_KQJcount10(TstCard(a4)); AllGroupings(5) = f_KQJcount10(TstCard(a5)); AllGroupings(6) = f_KQJcount10(TstCard(a6)); AllGroupings(7) = f_KQJcount10(TstCard(a7)); Check = %xfoot(AllGroupings); 9b if Check = 15; sFifteens += 1; 9e endif; 8e endfor; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; // group of CardsToScore 1b if CardsToScore = 8; 2b for check = 1 to 8; AllGroupings(Check) = f_KQJcount10(TstCard(Check)); 2e endfor; Check = %xfoot(AllGroupings); 2b if Check = 15; sFifteens += 1; 2e endif; 1e endif; //--------------------------------------------------------- // look for 4 of a kinds, 3 of a kinds and pairs. // You can't count same cards twice. // Going to look for 4s first. If found, add 1 to 4 counter. // Drop cards from test deck clear sFourOfKind; 1b if CardsToScore >= 4; 2b for a1 = 1 to CardsToScore; CurrentCard = TstCard(a1); 3b for a2 = (a1 + 1) to CardsToScore; 4b for a3 = (a2 + 1) to CardsToScore; 5b for a4 = (a3 + 1) to CardsToScore; 6b if CurrentCard = TstCard(a1) and CurrentCard = TstCard(a2) and CurrentCard = TstCard(a3) and CurrentCard = TstCard(a4); sFourOfKind += 1; 7b if ShowScoreSbf = 'YES'; sbfscMsg = 'Four of a kind for 12'; CardCount = 4; exsr srLoadSbfRec; 7e endif; 7b for az = 1 to CardsToScore; 8b if CurrentCard = TstCard(az); clear TstCard(az); 8e endif; 7e endfor; 6e endif; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // Repeat process to check for 3 of a kinds clear sThreeOfKind; 1b if CardsToScore >= 3; 2b for a1 = 1 to CardsToScore; 3b if TstCard(a1) > 0; //may have been dropped CurrentCard = TstCard(a1); 4b for a2 = (a1 + 1) to CardsToScore; 5b for a3 = (a2 + 1) to CardsToScore; 6b if CurrentCard = TstCard(a1) and CurrentCard = TstCard(a2) and CurrentCard = TstCard(a3); sThreeOfKind += 1; 7b if ShowScoreSbf = 'YES'; sbfscMsg = 'Three of a kind for 6'; CardCount = 3; exsr srLoadSbfRec; 7e endif; 7b for az = 1 to CardsToScore; 8b if CurrentCard = TstCard(az); clear TstCard(az); 8e endif; 7e endfor; 6e endif; 5e endfor; 4e endfor; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // Repeat process to check for 2 of a kind clear sPairs; 1b for a1 = 1 to CardsToScore; 2b if TstCard(a1) > 0; CurrentCard = TstCard(a1); 3b for a2 = (a1 + 1) to CardsToScore; 4b if CurrentCard = TstCard(a1) and CurrentCard = TstCard(a2); sPairs += 1; 5b if ShowScoreSbf = 'YES'; sbfscMsg = 'Pair for 2'; CardCount = 2; exsr srLoadSbfRec; 5e endif; 5b for az = 1 to CardsToScore; 6b if CurrentCard = TstCard(az); clear TstCard(az); 6e endif; 5e endfor; 4e endif; 3e endfor; 2e endif; 1e endfor; //--------------------------------------------------------- // Now it really gets hard! haha just kidding(NOT!) // Check for number of cards in a run now. // This is going to be complicated as if a pair is in a run, // the run has to be counted twice // 234 =run of 3 2344=2 runs of three. // also if a larger number run, supersedes any smaller run. // ie 1234=1 run of 4 NOT 2 runs of three // RunDeck. Use it to drop cards from. TstDeck = SavDeck; sorta TstCard; RunDeck = TstDeck; RemainingCnt = CardsToScore; //--------------------------------------------------------- // run of 7 (yeah, i guess it could happen) clear sRunOf7s; 1b if RemainingCnt >= 7; 2b for a1 = 1 to RemainingCnt; 3b for a2 = (a1 + 1) to RemainingCnt; 4b for a3 = (a2 + 1) to RemainingCnt; 5b for a4 = (a3 + 1) to RemainingCnt; 6b for a5 = (a4 + 1) to RemainingCnt; 7b for a6 = (a5 + 1) to RemainingCnt; 8b for a7 = (a6 + 1) to RemainingCnt; 9b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4 and TstCard(a1) = TstCard(a6) + 5 and TstCard(a1) = TstCard(a7) + 6; sRunOf7s += 1; clear RunCard(a1); clear RunCard(a2); clear RunCard(a3); clear RunCard(a4); clear RunCard(a5); clear RunCard(a6); clear RunCard(a7); 9e endif; 8e endfor; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // If there was a run of 7, I need to 'remove' those // runs from the 'deck' so they counted as a smaller run // Reload from deck with cards // removed and get a new RemainingCnt count. 1b if sRunOf7s > 0; sorta RunDeck; TstDeck = RunDeck; 2b for a1 = 1 to 8; 3b if TstCard(a1) = 0; RemainingCnt = (a1 - 1); 2v leave; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 6s clear sRunOf6s; 1b if RemainingCnt >= 6; 2b for a1 = 1 to RemainingCnt; 3b for a2 = (a1 + 1) to RemainingCnt; 4b for a3 = (a2 + 1) to RemainingCnt; 5b for a4 = (a3 + 1) to RemainingCnt; 6b for a5 = (a4 + 1) to RemainingCnt; 7b for a6 = (a5 + 1) to RemainingCnt; 8b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4 and TstCard(a1) = TstCard(a6) + 5; sRunOf6s += 1; clear RunCard(a1); clear RunCard(a2); clear RunCard(a3); clear RunCard(a4); clear RunCard(a5); clear RunCard(a6); 8e endif; 7e endfor; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 6s 1b if sRunOf6s > 0; sorta RunDeck; TstDeck = RunDeck; 2b for a1 = 1 to 8; 3b if TstCard(a1) = 0; RemainingCnt = (a1 - 1); 2v leave; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 5s clear sRunOf5s; 1b if RemainingCnt >= 5; 2b for a1 = 1 to RemainingCnt; 3b for a2 = (a1 + 1) to RemainingCnt; 4b for a3 = (a2 + 1) to RemainingCnt; 5b for a4 = (a3 + 1) to RemainingCnt; 6b for a5 = (a4 + 1) to RemainingCnt; 7b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3 and TstCard(a1) = TstCard(a5) + 4; sRunOf5s += 1; 8b if ShowScoreSbf = 'YES'; sbfscMsg = 'Run of 5 for 5'; CardCount = 5; exsr srLoadSbfRec; 8e endif; clear RunCard(a1); clear RunCard(a2); clear RunCard(a3); clear RunCard(a4); clear RunCard(a5); 7e endif; 6e endfor; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // Run of 5s 1b if sRunOf5s > 0; sorta RunDeck; TstDeck = RunDeck; 2b for a1 = 1 to 8; 3b if TstCard(a1) = 0; RemainingCnt = (a1 - 1); 2v leave; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 4s clear sRunOf4s; 1b if RemainingCnt >= 4; 2b for a1 = 1 to RemainingCnt; 3b for a2 = (a1 + 1) to RemainingCnt; 4b for a3 = (a2 + 1) to RemainingCnt; 5b for a4 = (a3 + 1) to RemainingCnt; 6b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2 and TstCard(a1) = TstCard(a4) + 3; sRunOf4s += 1; 7b if ShowScoreSbf = 'YES'; sbfscMsg = 'Run of 4 for 4'; CardCount = 4; exsr srLoadSbfRec; 7e endif; clear RunCard(a1); clear RunCard(a2); clear RunCard(a3); clear RunCard(a4); 6e endif; 5e endfor; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // Run of 4s 1b if sRunOf4s > 0; sorta RunDeck; TstDeck = RunDeck; 2b for a1 = 1 to 8; 3b if TstCard(a1) = 0; RemainingCnt = (a1 - 1); 2v leave; 3e endif; 2e endfor; 1e endif; //--------------------------------------------------------- // run of 3s clear sRunOf3s; 1b if RemainingCnt >= 3; 2b for a1 = 1 to RemainingCnt; 3b for a2 = (a1 + 1) to RemainingCnt; 4b for a3 = (a2 + 1) to RemainingCnt; 5b if TstCard(a1) = TstCard(a2) + 1 and TstCard(a1) = TstCard(a3) + 2; sRunOf3s += 1; 6b if ShowScoreSbf = 'YES'; sbfscMsg = 'Run of 3 for 3'; CardCount = 3; exsr srLoadSbfRec; 6e endif; 5e endif; 4e endfor; 3e endfor; 2e endfor; 1e endif; //--------------------------------------------------------- // subroutine to add up total score and load bar graph exsr srGetBarScore; 1b if ShowScoreSbf = 'YES'; sbfTotal = HandScore; 1e endif; endsr; //--------------------------------------------------------- // Reshow hands after Play is complete begsr srReShowHands; Attr(1).Row(1).Col(*) = %bitor(WHITE: PR: UL); Attr(3).Row(1).Col(*) = %bitor(WHITE: PR: UL); 1b for ax = 1 to 4; Face(1).Row(1).Col(ax) = f_GetCardFace(cFace4(ax)); Attr(1).Row(2).Col(ax) = f_GetCardColor(cSuite4(ax)); Attr(1).Row(3).Col(ax) = f_GetCardColor(cSuite4(ax)); Face(3).Row(1).Col(ax) = f_GetCardFace(uFace4(ax)); Attr(3).Row(2).Col(ax) = f_GetCardColor(uSuite4(ax)); Attr(3).Row(3).Col(ax) = f_GetCardColor(uSuite4(ax)); 1e endfor; endsr; //--------------------------------------------------------- begsr srExitPgm; *inlr = *on; return; endsr; /end-free //--------------------------------------------------------- // King, Queen and Jack card values count as 10 P f_KQJcount10 B D f_KQJcount10 PI 3u 0 D p_Num1to13 3u 0 const /free 1b if p_Num1to13 > 10; return 10; 1x else; return %uns(p_Num1to13); 1e endif; /end-free P f_KQJcount10 E ]]> v5r4 *---------------------------------------------------------------- * JCRGMCRBD - CRIBBAGE - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN FRCDTA A USERMSGA 1A P A CCRIB11A 1A P A CCRIB12A 1A P A CCRIB13A 1A P A CCRIB14A 1A P A CCRIB21A 1A P A CCRIB22A 1A P A CCRIB23A 1A P A CCRIB24A 1A P A CCRIB31A 1A P A CCRIB32A 1A P A CCRIB33A 1A P A CCRIB34A 1A P A CHAND11A 1A P A CHAND12A 1A P A CHAND13A 1A P A CHAND14A 1A P A CHAND21A 1A P A CHAND22A 1A P A CHAND23A 1A P A CHAND24A 1A P A CHAND31A 1A P A CHAND32A 1A P A CHAND33A 1A P A CHAND34A 1A P A DECK1A 1A P A PLAY11A 1A P A PLAY12A 1A P A PLAY13A 1A P A PLAY14A 1A P A PLAY15A 1A P A PLAY16A 1A P A PLAY17A 1A P A PLAY18A 1A P A DECK2A 1A P A PLAY21A 1A P A PLAY22A 1A P A PLAY23A 1A P A PLAY24A 1A P A PLAY25A 1A P A PLAY26A 1A P A PLAY27A 1A P A PLAY28A 1A P A DECK3A 1A P A PLAY31A 1A P A PLAY32A 1A P A PLAY33A 1A P A PLAY34A 1A P A PLAY35A 1A P A PLAY36A 1A P A PLAY37A 1A P A PLAY38A 1A P A UCRIB11A 1A P A UCRIB12A 1A P A UCRIB13A 1A P A UCRIB14A 1A P A UCRIB21A 1A P A UCRIB22A 1A P A UCRIB23A 1A P A UCRIB24A 1A P A UCRIB31A 1A P A UCRIB32A 1A P A UCRIB33A 1A P A UCRIB34A 1A P A UHAND11A 1A P A UHAND12A 1A P A UHAND13A 1A P A UHAND14A 1A P A UHAND21A 1A P A UHAND22A 1A P A UHAND23A 1A P A UHAND24A 1A P A UHAND31A 1A P A UHAND32A 1A P A UHAND33A 1A P A UHAND34A 1A P A UHAND15A 1A P A UHAND16A 1A P A UHAND25A 1A P A UHAND26A 1A P A UHAND35A 1A P A UHAND36A 1A P A 1 3'JCRGMCRB' COLOR(BLU) A 1 14'CRIBBAGE' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 70 2 32' CRIB ' COLOR(RED) DSPATR(RI) A CCRIB11 2A O 3 30DSPATR(&CCRIB11A) A CCRIB12 2A O 3 33DSPATR(&CCRIB12A) A CCRIB13 2A O 3 36DSPATR(&CCRIB13A) A CCRIB14 2A O 3 39DSPATR(&CCRIB14A) A 4 4' ' COLOR(RED) DSPATR(RI) A CHAND11 2A O 4 11DSPATR(&CHAND11A) A CHAND12 2A O 4 14DSPATR(&CHAND12A) A CHAND13 2A O 4 17DSPATR(&CHAND13A) A CHAND14 2A O 4 20DSPATR(&CHAND14A) A CCRIB21 2A O 4 30DSPATR(&CCRIB21A) A CCRIB22 2A O 4 33DSPATR(&CCRIB22A) A CCRIB23 2A O 4 36DSPATR(&CCRIB23A) A CCRIB24 2A O 4 39DSPATR(&CCRIB24A) A 5 4' ' COLOR(RED) DSPATR(RI) A CHAND21 2A O 5 11DSPATR(&CHAND21A) A CHAND22 2A O 5 14DSPATR(&CHAND22A) A CHAND23 2A O 5 17DSPATR(&CHAND23A) A CHAND24 2A O 5 20DSPATR(&CHAND24A) A CCRIB31 2A O 5 30DSPATR(&CCRIB31A) A CCRIB32 2A O 5 33DSPATR(&CCRIB32A) A CCRIB33 2A O 5 36DSPATR(&CCRIB33A) A CCRIB34 2A O 5 39DSPATR(&CCRIB34A) A 6 4' ' COLOR(RED) DSPATR(RI) A CHAND31 2A O 6 11DSPATR(&CHAND31A) A CHAND32 2A O 6 14DSPATR(&CHAND32A) A CHAND33 2A O 6 17DSPATR(&CHAND33A) A CHAND34 2A O 6 20DSPATR(&CHAND34A) A BARCCNT 3Y 0O 6 74EDTCDE(4) COLOR(WHT) A 72 DSPATR(RI) A 74 7 11'GO ' DSPATR(RI) A 7 35' ' COLOR(RED) DSPATR(RI) A TRACKC1 40A O 7 37COLOR(RED) A 72 DSPATR(RI) A 8 10'- - - - - - -' A 8 35' ' COLOR(BLU) DSPATR(RI) A TRACKU1 40A O 8 37COLOR(BLU) A 73 DSPATR(RI) A 9 3'--' DSPATR(HI) A 9 7'|' A PLAY11 2A O 9 11DSPATR(&PLAY11A) A PLAY12 2A O 9 14DSPATR(&PLAY12A) A PLAY13 2A O 9 17DSPATR(&PLAY13A) A PLAY14 2A O 9 20DSPATR(&PLAY14A) A 10 7'|' A PLAY21 2A O 10 11DSPATR(&PLAY21A) A PLAY22 2A O 10 14DSPATR(&PLAY22A) A PLAY23 2A O 10 17DSPATR(&PLAY23A) A PLAY24 2A O 10 20DSPATR(&PLAY24A) A TRACKC2 40A O 10 37COLOR(RED) A 72 DSPATR(RI) A DECK1 2A O 11 3DSPATR(&DECK1A) A 11 7'|' A PLAY31 2A O 11 11DSPATR(&PLAY31A) A PLAY32 2A O 11 14DSPATR(&PLAY32A) A PLAY33 2A O 11 17DSPATR(&PLAY33A) A PLAY34 2A O 11 20DSPATR(&PLAY34A) A TRACKU2 40A O 11 37COLOR(BLU) A 73 DSPATR(RI) A DECK2 2A O 12 3DSPATR(&DECK2A) A 12 7'|' A 45 PLAYMSG 50A O 12 9DSPATR(RI) A 72 AO 73 COLOR(WHT) A DECK3 2A O 13 3DSPATR(&DECK3A) A 13 7'|' A PLAY15 2A O 13 11DSPATR(&PLAY15A) A PLAY16 2A O 13 14DSPATR(&PLAY16A) A PLAY17 2A O 13 17DSPATR(&PLAY17A) A PLAY18 2A O 13 20DSPATR(&PLAY18A) A TRACKC3 40A O 13 37COLOR(RED) A 72 DSPATR(RI) A C121 1A O 13 78 A 72 DSPATR(RI) COLOR(RED) A 14 7'|' A PLAY25 2A O 14 11DSPATR(&PLAY25A) A PLAY26 2A O 14 14DSPATR(&PLAY26A) A PLAY27 2A O 14 17DSPATR(&PLAY27A) A PLAY28 2A O 14 20DSPATR(&PLAY28A) A TRACKU3 40A O 14 37COLOR(BLU) A 73 DSPATR(RI) A U121 1A O 14 78 A 73 DSPATR(RI) COLOR(BLU) A 15 3'--' DSPATR(HI) A 15 7'|' A PLAY35 2A O 15 11DSPATR(&PLAY35A) A PLAY36 2A O 15 14DSPATR(&PLAY36A) A PLAY37 2A O 15 17DSPATR(&PLAY37A) A PLAY38 2A O 15 20DSPATR(&PLAY38A) A RUNNINGTOT 3Y 0O 15 27EDTCDE(4) DSPATR(UL) A BARUCNT 3Y 0O 15 74EDTCDE(4) COLOR(WHT) A 73 DSPATR(RI) A 16 10'- - - - - - -' A 17 3' ' COLOR(BLU) DSPATR(RI) A UHAND11 2A O 17 11DSPATR(&UHAND11A) A UHAND12 2A O 17 14DSPATR(&UHAND12A) A UHAND13 2A O 17 17DSPATR(&UHAND13A) A UHAND14 2A O 17 20DSPATR(&UHAND14A) A UHAND15 2A O 17 23DSPATR(&UHAND15A) A UHAND16 2A O 17 26DSPATR(&UHAND16A) A 71 17 32' CRIB ' COLOR(BLU) DSPATR(RI) A 18 3' ' COLOR(BLU) DSPATR(RI) A UHAND21 2A O 18 11DSPATR(&UHAND21A) A UHAND22 2A O 18 14DSPATR(&UHAND22A) A UHAND23 2A O 18 17DSPATR(&UHAND23A) A UHAND24 2A O 18 20DSPATR(&UHAND24A) A UHAND25 2A O 18 23DSPATR(&UHAND25A) A UHAND26 2A O 18 26DSPATR(&UHAND26A) A UCRIB11 2A O 18 30DSPATR(&UCRIB11A) A UCRIB12 2A O 18 33DSPATR(&UCRIB12A) A UCRIB13 2A O 18 36DSPATR(&UCRIB13A) A UCRIB14 2A O 18 39DSPATR(&UCRIB14A) A 19 3' ' COLOR(BLU) DSPATR(RI) A UHAND31 2A O 19 11DSPATR(&UHAND31A) A UHAND32 2A O 19 14DSPATR(&UHAND32A) A UHAND33 2A O 19 17DSPATR(&UHAND33A) A UHAND34 2A O 19 20DSPATR(&UHAND34A) A UHAND35 2A O 19 23DSPATR(&UHAND35A) A UHAND36 2A O 19 26DSPATR(&UHAND36A) A UCRIB21 2A O 19 30DSPATR(&UCRIB21A) A UCRIB22 2A O 19 33DSPATR(&UCRIB22A) A UCRIB23 2A O 19 36DSPATR(&UCRIB23A) A UCRIB24 2A O 19 39DSPATR(&UCRIB24A) A 10N75 DISCARD1 1A B 20 11COLOR(WHT) A 20N75 DISCARD2 1A B 20 14COLOR(WHT) A 30N75 DISCARD3 1A B 20 17COLOR(WHT) A 40N75 DISCARD4 1A B 20 20COLOR(WHT) A 50N75 DISCARD5 1A B 20 23COLOR(WHT) A 60N75 DISCARD6 1A B 20 26COLOR(WHT) A UCRIB31 2A O 20 30DSPATR(&UCRIB31A) A UCRIB32 2A O 20 33DSPATR(&UCRIB32A) A UCRIB33 2A O 20 36DSPATR(&UCRIB33A) A UCRIB34 2A O 20 39DSPATR(&UCRIB34A) A 75 21 11'You say GO ' A DSPATR(RI) A N75 USERMSG 36A O 22 11DSPATR(&USERMSGA) A 23 57' ' COLOR(YLW) DSPATR(RI) A 23 59'=Clubs' A 23 68' ' COLOR(WHT) DSPATR(RI) A 23 70'=Diamonds' A 24 2'F3=Exit' COLOR(BLU) A 24 57' ' COLOR(RED) DSPATR(RI) A 24 59'=Hearts' A 24 68' ' COLOR(BLU) DSPATR(RI) A 24 70'=Spades' *---------------------------------------------------------------- A R ASSUME ASSUME A 1 2' ' DSPATR(ND) *---------------------------------------------------------------- A R SBFDTA1 SFL A SBFSC1A 1A P A SBFSC2A 1A P A SBFSC3A 1A P A SBFSC4A 1A P A SBFSC5A 1A P A SBFSC1 2A O 3 1DSPATR(&SBFSC1A) A SBFSC2 2A O 3 4DSPATR(&SBFSC2A) A SBFSC3 2A O 3 7DSPATR(&SBFSC3A) A SBFSC4 2A O 3 10DSPATR(&SBFSC4A) A SBFSC5 2A O 3 13DSPATR(&SBFSC5A) A SBFSCMSG 21A O 3 16 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(09) SFLSIZ(18) A WINDOW(&LIN &POS 14 36) A 01 SFLDSP A 02 SFLDSPCTL A N01 SFLCLR A N04 SFLEND A 77 WDWBORDER((*COLOR BLU) + (*DSPATR RI) (*CHAR '/-\..\-/')) A 76 WDWBORDER((*COLOR RED) + (*DSPATR RI) (*CHAR '/-\..\-/')) A LIN 2S 0P A POS 2S 0P A SCOREMSG 20A O 1 1DSPATR(HI UL) *---------------------------------------------------------------- A R SFOOTER1 WINDOW(SBFCTL1) OVERLAY A 13 1'Enter' COLOR(BLU) DSPATR(RI) A 13 16'Total:' COLOR(BLU) A SBFTOTAL 3Y 0O 13 23EDTCDE(4) DSPATR(RI) ]]> and // Craig Rutledge //--------------------------------------------------------- //?Aknakereso - Minesweeper //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMMINEDCF E workstn infds(Infds) * * D Akna C CONST('*') Mine D MFlag C CONST('!') Win mine D NoBomb C CONST(':') No mine D Sorok C CONST(8) Rows D Oszlop C CONST(40) Column //--*STAND ALONE------------------------------------------- D Col s 3u 0 D Row s 3u 0 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Infds /Define Dspatr /Define FunctionKeys /Define QsnGetCsrAdr /Define f_GetRandom /Define f_GetDayName /Define f_CenterText /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D Mines ds dim(Sorok) qualified D Col 1a dim(Oszlop) * D TempM ds dim(Sorok) qualified D Col 1a dim(Oszlop) * * //--*FUNCTION PROTOTYPES----------------------------------- * d akt S 2 0 d aknak S 4 0 d ures S 4 0 d jeloles S 2 0 d rowK S 2 0 d colK S 2 0 d rows S 1 0 d cols S 1 0 d i S 2 0 d j S 2 0 d aa S 2 0 d bb S 2 0 d Number S 1 0 d Char S 1A d mehet S 1A d bill S 2 0 d vanNulla S 1A d language S 1A E-English,H-Hungaria d XKeypress S 4 0 * * //--*ENTRY PARMS *NONE* ----------------------------------- /free exsr DetailSettings; exsr srSTART; 1b dou 1 = 2; 2b if InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- //?Kiertekeles begsr Kiertekeles; //?1. 1b if %Scan('X':Wsmezo1) > 0; jeloles = %Scan('X':Wsmezo1); XKeypress += 1; row = 1; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo1:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?2. 1b if %Scan('X':Wsmezo2) > 0; jeloles = %Scan('X':Wsmezo2); XKeypress += 1; row = 2; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo2:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?3. 1b if %Scan('X':Wsmezo3) > 0; jeloles = %Scan('X':Wsmezo3); XKeypress += 1; row = 3; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo3:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?4. 1b if %Scan('X':Wsmezo4) > 0; jeloles = %Scan('X':Wsmezo4); XKeypress += 1; row = 4; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo4:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?5. 1b if %Scan('X':Wsmezo5) > 0; jeloles = %Scan('X':Wsmezo5); XKeypress += 1; row = 5; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo5:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?6. 1b if %Scan('X':Wsmezo6) > 0; jeloles = %Scan('X':Wsmezo6); XKeypress += 1; row = 6; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo6:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?7. 1b if %Scan('X':Wsmezo7) > 0; jeloles = %Scan('X':Wsmezo7); XKeypress += 1; row = 7; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo7:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; //?8. 1b if %Scan('X':Wsmezo8) > 0; jeloles = %Scan('X':Wsmezo8); XKeypress += 1; row = 8; 2b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 2x else; %Subst(WsMezo8:jeloles:1) = 'x'; exsr NezzukMeg; 2e endif; 1e endif; endsr; //--------------------------------------------------------- //?Nezzuk meg begsr NezzukMeg; rowK = row; colK = jeloles; 1b if Mines(row).Col(jeloles) <> '0'; 2b select; 2x When row = 1; %Subst(WsMezo1:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 2; %Subst(WsMezo2:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 3; %Subst(WsMezo3:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 4; %Subst(WsMezo4:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 5; %Subst(WsMezo5:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 6; %Subst(WsMezo6:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 7; %Subst(WsMezo7:jeloles:1) = Mines(row).Col(jeloles); 2x When row = 8; %Subst(WsMezo8:jeloles:1) = Mines(row).Col(jeloles); 2e endsl; 1x else; //?kinullazzuk a TempM tombot 2b for i=1 to Sorok; 3b for j=1 to Oszlop; TempM(i).Col(j) = ' '; 3e endfor; 2e endfor; 2b select; 2x When row = 1; %Subst(WsMezo1:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo1:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo1); colK += 1; %Subst(WsMezo1:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 2; %Subst(WsMezo2:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo2:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo2); colK += 1; %Subst(WsMezo2:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 3; %Subst(WsMezo3:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo3:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo3); colK += 1; %Subst(WsMezo3:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 4; %Subst(WsMezo4:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo4:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo4); colK += 1; %Subst(WsMezo4:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 5; %Subst(WsMezo5:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo5:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo5); colK += 1; %Subst(WsMezo5:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 6; %Subst(WsMezo6:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo6:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo6); colK += 1; %Subst(WsMezo6:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 7; %Subst(WsMezo7:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo7:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo7); colK += 1; %Subst(WsMezo7:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2x When row = 8; %Subst(WsMezo8:jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK += -1; %Subst(WsMezo8:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; //?-> colK = jeloles; 3b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsMezo8); colK += 1; %Subst(WsMezo8:colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 3e Enddo; exsr Felkutat; 2e endsl; 1e endif; ures = 0; 1b for i = 1 to Sorok; 2b for j = 1 to Oszlop; 3b select; 3x When i = 1; 4b if %Subst(WsMezo1:j:1) = ' '; ures += 1; 4e endif; 3x When i = 2; 4b if %Subst(WsMezo2:j:1) = ' '; ures += 1; 4e endif; 3x When i = 3; 4b if %Subst(WsMezo3:j:1) = ' '; ures += 1; 4e endif; 3x When i = 4; 4b if %Subst(WsMezo4:j:1) = ' '; ures += 1; 4e endif; 3x When i = 5; 4b if %Subst(WsMezo5:j:1) = ' '; ures += 1; 4e endif; 3x When i = 6; 4b if %Subst(WsMezo6:j:1) = ' '; ures += 1; 4e endif; 3x When i = 7; 4b if %Subst(WsMezo7:j:1) = ' '; ures += 1; 4e endif; 3x When i = 8; 4b if %Subst(WsMezo8:j:1) = ' '; ures += 1; 4e endif; 3e endsl; 2e endfor; 1e endfor; 1b if ures = aknak and XKeypress > 2; //?WIN! exsr YouWin; 1e endif; endsr; //--------------------------------------------------------- //?Korbe begsr Korbe; rowK = row; colK = col; 1b for rows = 1 to 3; 2b for cols = 1 to 3; i = (rowK - 2) + rows; j = (colK - 2) + cols; 3b if (i) < 1 or (i) > sorok OR (j) < 1 or (j) > %len(WsMezo1); 3x else; // ?kiszamolas 4b if Mines(i).Col(j) <> '*'; char = Mines(i).Col(j); 5b If char = ' '; char = '0'; 5e endif; 5b monitor; Number = %dec(char:1:0); 5x on-error; Number = 0; 5e endmon; Number += 1; Mines(i).Col(j) = %char(Number); 4e endif; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- //?GameOver begsr eGameOver; *in80 = *on; *in85 = *on; WsBumm1 = 'BBB U U M M M M'; WsBumm2 = 'B B U U MM MM MM MM'; WsBumm3 = 'BBB U U M M M M M M'; WsBumm4 = 'B B U U M M M M'; WsBumm5 = 'BBB UUU M M M M'; GameOver= f_CenterText('A jateknak vege! GAME OVER!':30); aGameover = %bitor(Red: RI); 1b for row = 1 to Sorok; 2b for col = 1 to Oszlop; 3b select; 3x When row = 1; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo1:col:1) = Akna; 4e endif; 3x When row = 2; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo2:col:1) = Akna; 4e endif; 3x When row = 3; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo3:col:1) = Akna; 4e endif; 3x When row = 4; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo4:col:1) = Akna; 4e endif; 3x When row = 5; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo5:col:1) = Akna; 4e endif; 3x When row = 6; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo6:col:1) = Akna; 4e endif; 3x When row = 7; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo7:col:1) = Akna; 4e endif; 3x When row = 8; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo8:col:1) = Akna; 4e endif; 3e endsl; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- //?You Win!!! begsr YouWin; *in80 = *on; *in85 = *off; WsBumm1 = ' W W W I N N'; WsBumm2 = ' W W W I NN N'; WsBumm3 = ' W W W I N N N'; WsBumm4 = ' W W W I N NN'; WsBumm5 = ' WWWWW I N N'; GameOver= f_CenterText('NYERTEL! YOU WIN!':30); aGameover = %bitor(Green: RI); 1b for row = 1 to Sorok; 2b for col = 1 to Oszlop; 3b select; 3x When row = 1; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo1:col:1) = MFlag; 4x else; %Subst(Wsmezo1:col:1) = ' '; 4e endif; 3x When row = 2; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo2:col:1) = MFlag; 4x else; %Subst(Wsmezo2:col:1) = ' '; 4e endif; 3x When row = 3; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo3:col:1) = MFlag; 4x else; %Subst(Wsmezo3:col:1) = ' '; 4e endif; 3x When row = 4; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo4:col:1) = MFlag; 4x else; %Subst(Wsmezo4:col:1) = ' '; 4e endif; 3x When row = 5; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo5:col:1) = MFlag; 4x else; %Subst(Wsmezo5:col:1) = ' '; 4e endif; 3x When row = 6; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo6:col:1) = MFlag; 4x else; %Subst(Wsmezo6:col:1) = ' '; 4e endif; 3x When row = 7; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo7:col:1) = MFlag; 4x else; %Subst(Wsmezo7:col:1) = ' '; 4e endif; 3x When row = 8; 4b if Mines(row).Col(col) = Akna; %Subst(Wsmezo8:col:1) = MFlag; 4x else; %Subst(Wsmezo8:col:1) = ' '; 4e endif; 3e endsl; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- //?Start begsr srSTART; *in80 = *On; GameOver = *blanks; Aknak = 0; WsMezo1 = 'Press F5 to start the game!'; WsMezo2 = *blanks; WsMezo3 = 'Nyomj F5-ot a jatek elkezdesehez!'; WsMezo4 = *blanks; WsMezo5 = *blanks; WsMezo6 = *blanks; WsMezo7 = *blanks; WsMezo8 = *blanks; WsTempM1= *blanks; WsTempM2= *blanks; WsTempM3= *blanks; WsTempM4= *blanks; WsTempM5= *blanks; WsTempM6= *blanks; WsTempM7= *blanks; WsTempM8= *blanks; evalr scDow = %trimr(f_GetDayName()); //?detail cursor position csrRow = 10; cSrCol = 23; row = 1; col = 1; 1b dou 1 = 2; exfmt SCREEN1; QsnGetCsrAdr(QsnCursorRow: QsnCursorCol: 0: ApiErrDS); csrRow = QsnCursorRow; cSrCol = QsnCursorCol; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; //?Kiertekeles exsr Kiertekeles; //--------------------------------------------------------- //?F9 Change Language 2b if InfdsFkey = f09; 3b if language = 'H'; exsr DetailSettings; 3x else; language = 'H'; WSF3 = 'F3=Kilepes'; WSF5 = 'F5=Uj jatek'; WSF9 = 'F9=English'; WSF12= 'F12=Kilepes'; WSHDR1= 'AKNAKERESO'; WSDES = 'Kijeloles'; WSDES2= 'Uss'+White+'X-et'+Green+', majd Entert!'; WSMINES=' Aknak szama:'; WSDESC1= ': Itt nincs bomba'; WSDESC2= '1..8 Szomszedos bombak szama'; 3e endif; 1i iter; 2e endif; //--------------------------------------------------------- //?F5 Computer generate mines 2b if InfdsFkey = f05; *in80 = *off; csrRow = 6; cSrCol = 4; aGameover = *blanks; mehet = '0'; Aknak = 0; GameOver = *blanks; WsMezo1 = *blanks; WsMezo2 = *blanks; WsMezo3 = *blanks; WsMezo4 = *blanks; WsMezo5 = *blanks; WsMezo6 = *blanks; WsMezo7 = *blanks; WsMezo8 = *blanks; WsTempM1= *blanks; WsTempM2= *blanks; WsTempM3= *blanks; WsTempM4= *blanks; WsTempM5= *blanks; WsTempM6= *blanks; WsTempM7= *blanks; WsTempM8= *blanks; ures = 0; WsBumm1 = *blanks; WsBumm2 = *blanks; WsBumm3 = *blanks; WsBumm4 = *blanks; WsBumm5 = *blanks; 3b for row = 1 to Sorok; 4b for col = 1 to Oszlop; akt = f_GetRandom(13); 5b if akt = 9; Mines(row).Col(col) = Akna; TempM(row).Col(col) = ' '; Aknak += 1; 5x else; Mines(row).Col(col) = '0'; TempM(row).Col(col) = ' '; ures += 1; 5e endif; 4e endfor; 3e endfor; WSAkna = aknak; mehet = '1'; 3b for row = 1 to Sorok; 4b for col = 1 to Oszlop; 5b if Mines(row).Col(col) = Akna; exsr Korbe; 5e endif; 4e endfor; 3e endfor; 1i iter; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- //?Felkutat; begsr Felkutat; rowK = row; colK = col; 1b for aa = 1 to Oszlop; 2b for bb = 1 to Sorok; 3b select; 3x When bb = 1; %Subst(WsTempM1:aa:1) = TempM(bb).Col(aa); 3x When bb = 2; %Subst(WsTempM2:aa:1) = TempM(bb).Col(aa); 3x When bb = 3; %Subst(WsTempM3:aa:1) = TempM(bb).Col(aa); 3x When bb = 4; %Subst(WsTempM4:aa:1) = TempM(bb).Col(aa); 3x When bb = 5; %Subst(WsTempM5:aa:1) = TempM(bb).Col(aa); 3x When bb = 6; %Subst(WsTempM6:aa:1) = TempM(bb).Col(aa); 3x When bb = 7; %Subst(WsTempM7:aa:1) = TempM(bb).Col(aa); 3x When bb = 8; %Subst(WsTempM8:aa:1) = TempM(bb).Col(aa); 3e endsl; 2e endfor; 1e endfor; //?ha van 0-s, akkor kell veluk foglalkozni 1b if %Scan('0':WsTempM1) > 0 OR %Scan('0':WsTempM2) > 0 OR %Scan('0':WsTempM3) > 0 OR %Scan('0':WsTempM4) > 0 OR %Scan('0':WsTempM5) > 0 OR %Scan('0':WsTempM6) > 0 OR %Scan('0':WsTempM7) > 0 OR %Scan('0':WsTempM8) > 0; vanNulla = 'Y'; 1x else; vanNulla = ' '; 1e endif; 1b Dow vanNulla = 'Y'; vanNulla = ' '; 2b for aa = 1 to Oszlop; 3b for bb = 1 to Sorok; 4b if TempM(bb).Col(aa) = '0'; 5b for rows = 1 to 3; 6b for cols = 1 to 3; i = (bb - 2) + rows; j = (aa - 2) + cols; 7b if (i) < 1 or (i) > sorok OR (j) < 1 or (j) > %len(WsMezo1); 7x else; //? ahol meg ures - where is empty 8b if TempM(i).Col(j) = ' '; TempM(i).Col(j) = Mines(i).Col(j); 9b if TempM(i).Col(j) = '0'; vanNulla = 'Y'; 9e endif; 8e endif; 7e endif; 6e endfor; 5e endfor; 4e endif; 3e endfor; 2e endfor; 1e Enddo; 1b for aa = 1 to Oszlop; 2b for bb = 1 to Sorok; 3b select; 3x When bb = 1; %Subst(WsTempM1:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo1:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo1:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 2; %Subst(WsTempM2:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo2:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo2:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 3; %Subst(WsTempM3:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo3:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo3:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 4; %Subst(WsTempM4:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo4:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo4:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 5; %Subst(WsTempM5:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo5:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo5:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 6; %Subst(WsTempM6:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo6:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo6:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 7; %Subst(WsTempM7:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo7:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo7:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3x When bb = 8; %Subst(WsTempM8:aa:1) = TempM(bb).Col(aa); 4b If TempM(bb).Col(aa) = '0'; %Subst(WsMezo8:aa:1) = NoBomb; 4x else; 5b If TempM(bb).Col(aa) <> ' '; %Subst(WsMezo8:aa:1) = TempM(bb).Col(aa); 5e endif; 4e endif; 3e endsl; 2e endfor; 1e endfor; endsr; // //?Detail settings -------------------------------------------------- // begsr DetailSettings; XKeypress = 0; language = 'E'; WSF3 = 'F3=Quit'; WSF5 = 'F5=New Game'; WSF9 = 'F9=Magyar'; WSF12= 'F12=Quit'; WSHDR1= 'MINESWEEPER'; WSDES = 'Designation'; WSDES2= 'Press'+White+'X'+Green+', and Enter'; WSMINES='Number of mines:'; WSDESC1= ': There is no bomb'; WSDESC2= '1..8 Number of adjacent bombs'; endsr; /end-free ********************************************************************** ]]> v5r4 //--------------------------------------------------------- // JCRGMPOK - Video Poker //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMPOKD cf e workstn infds(Infds) indds(Ind) //--*STAND ALONE------------------------------------------- D Color s 1a D NewDeck s 2a dim(52) D ac s 3u 0 D AceBucket s 3u 0 D ax s 3u 0 D ay s 3u 0 D col s 3u 0 D Deal s 3u 0 D JackBucket s 3u 0 D KingBucket s 3u 0 D QueenBucket s 3u 0 D row s 3u 0 D xx s 3u 0 D IsFlush s n D IsRoyalStraight... D s n D IsStraight s n //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetCardFace /Define f_GetCardColor /Define f_ShuffleDeck /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_LoadFace PR 4a dim(7) D 2a const //--*DATA STRUCTURES--------------------------------------- D ds D UserHand 2a dim(5) ascend D UserCard 3u 0 overlay(Userhand:1) D UserSuite 1a overlay(UserHand:*next) // Name screen indicators D ind ds qualified D ScreenCtl n overlay(ind:10) // Define 3D array for Card faces and Card attributes D Face ds dim(5) qualified based(ptr1) D Row likeds(Rowx) dim(7) D Rowx ds qualified D Col 1a dim(4) D ptr1 s * inz(%addr(c111)) D Attr ds dim(5) likeds(Face) based(ptr2) D ptr2 s * inz(%addr(c111a)) // map screen fields into DS so pointers to data can overlay D DisCardDS ds inz D DisCard1 D DisCard2 D DisCard3 D DisCard4 D DisCard5 D DisCardArry 1a dim(5) overlay(DisCardDS) // Define array for Card id field attributes D CardIdAtrDS ds D CardID1A D CardID2A D CardID3A D CardID4A D CardID5A D CardIdAtr 1a dim(5) overlay(CardIdAtrDS) // Define array for Card side border attributes D BorderAtrDS ds D BORDER1A D BORDER2A D BORDER3A D BORDER4A D BORDER5A D BorderAtr 1a dim(5) overlay(BorderAtrDS) D BorderTopBotDS ds D BORDERTOP1 D BORDERBOT1 Overlay(BorderTop1) D BORDERTOP2 D BORDERBOT2 Overlay(BorderTop2) D BORDERTOP3 D BORDERBOT3 Overlay(BorderTop3) D BORDERTOP4 D BORDERBOT4 Overlay(BorderTop4) D BORDERTOP5 D BORDERBOT5 Overlay(BorderTop5) D BorderTopBot 11a dim(5) overlay(BorderTopBotDS) // top and bottom border attributes D TopBotAtrDS ds D TOPBOT1A D TOPBOT2A D TOPBOT3A D TOPBOT4A D TOPBOT5A D TopBotAtr 1a dim(5) overlay(TopBotAtrDS) D CardIdDS ds D CVALT1 D CVALT2 D CVALT3 D CVALT4 D CVALT5 D CardID 2a dim(5) overlay(CardIdDS) D BorderSidesDS ds D SIDE11L D SIDE12L Overlay(SIDE11L) D SIDE13L Overlay(SIDE11L) D SIDE14L Overlay(SIDE11L) D SIDE15L Overlay(SIDE11L) D SIDE16L Overlay(SIDE11L) D SIDE17L Overlay(SIDE11L) D SIDE18L Overlay(SIDE11L) D SIDE19L Overlay(SIDE11L) D SIDE110L Overlay(SIDE11L) D SIDE111L Overlay(SIDE11L) D SIDE11R Overlay(SIDE11L) D SIDE12R Overlay(SIDE11L) D SIDE13R Overlay(SIDE11L) D SIDE14R Overlay(SIDE11L) D SIDE15R Overlay(SIDE11L) D SIDE16R Overlay(SIDE11L) D SIDE17R Overlay(SIDE11L) D SIDE18R Overlay(SIDE11L) D SIDE19R Overlay(SIDE11L) D SIDE110R Overlay(SIDE11L) D SIDE111R Overlay(SIDE11L) D SIDE21L D SIDE22L Overlay(SIDE21L) D SIDE23L Overlay(SIDE21L) D SIDE24L Overlay(SIDE21L) D SIDE25L Overlay(SIDE21L) D SIDE26L Overlay(SIDE21L) D SIDE27L Overlay(SIDE21L) D SIDE28L Overlay(SIDE21L) D SIDE29L Overlay(SIDE21L) D SIDE210L Overlay(SIDE21L) D SIDE211L Overlay(SIDE21L) D SIDE21R Overlay(SIDE21L) D SIDE22R Overlay(SIDE21L) D SIDE23R Overlay(SIDE21L) D SIDE24R Overlay(SIDE21L) D SIDE25R Overlay(SIDE21L) D SIDE26R Overlay(SIDE21L) D SIDE27R Overlay(SIDE21L) D SIDE28R Overlay(SIDE21L) D SIDE29R Overlay(SIDE21L) D SIDE210R Overlay(SIDE21L) D SIDE211R Overlay(SIDE21L) D SIDE31L D SIDE32L Overlay(SIDE31L) D SIDE33L Overlay(SIDE31L) D SIDE34L Overlay(SIDE31L) D SIDE35L Overlay(SIDE31L) D SIDE36L Overlay(SIDE31L) D SIDE37L Overlay(SIDE31L) D SIDE38L Overlay(SIDE31L) D SIDE39L Overlay(SIDE31L) D SIDE310L Overlay(SIDE31L) D SIDE311L Overlay(SIDE31L) D SIDE31R Overlay(SIDE31L) D SIDE32R Overlay(SIDE31L) D SIDE33R Overlay(SIDE31L) D SIDE34R Overlay(SIDE31L) D SIDE35R Overlay(SIDE31L) D SIDE36R Overlay(SIDE31L) D SIDE37R Overlay(SIDE31L) D SIDE38R Overlay(SIDE31L) D SIDE39R Overlay(SIDE31L) D SIDE310R Overlay(SIDE31L) D SIDE311R Overlay(SIDE31L) D SIDE41L D SIDE42L Overlay(SIDE41L) D SIDE43L Overlay(SIDE41L) D SIDE44L Overlay(SIDE41L) D SIDE45L Overlay(SIDE41L) D SIDE46L Overlay(SIDE41L) D SIDE47L Overlay(SIDE41L) D SIDE48L Overlay(SIDE41L) D SIDE49L Overlay(SIDE41L) D SIDE410L Overlay(SIDE41L) D SIDE411L Overlay(SIDE41L) D SIDE41R Overlay(SIDE41L) D SIDE42R Overlay(SIDE41L) D SIDE43R Overlay(SIDE41L) D SIDE44R Overlay(SIDE41L) D SIDE45R Overlay(SIDE41L) D SIDE46R Overlay(SIDE41L) D SIDE47R Overlay(SIDE41L) D SIDE48R Overlay(SIDE41L) D SIDE49R Overlay(SIDE41L) D SIDE410R Overlay(SIDE41L) D SIDE411R Overlay(SIDE41L) D SIDE51L D SIDE52L Overlay(SIDE51L) D SIDE53L Overlay(SIDE51L) D SIDE54L Overlay(SIDE51L) D SIDE55L Overlay(SIDE51L) D SIDE56L Overlay(SIDE51L) D SIDE57L Overlay(SIDE51L) D SIDE58L Overlay(SIDE51L) D SIDE59L Overlay(SIDE51L) D SIDE510L Overlay(SIDE51L) D SIDE511L Overlay(SIDE51L) D SIDE51R Overlay(SIDE51L) D SIDE52R Overlay(SIDE51L) D SIDE53R Overlay(SIDE51L) D SIDE54R Overlay(SIDE51L) D SIDE55R Overlay(SIDE51L) D SIDE56R Overlay(SIDE51L) D SIDE57R Overlay(SIDE51L) D SIDE58R Overlay(SIDE51L) D SIDE59R Overlay(SIDE51L) D SIDE510R Overlay(SIDE51L) D SIDE511R Overlay(SIDE51L) D BorderSides 1a dim(5) overlay(BorderSidesDS) // Card Faces D screenDS ds D C111 D C112 D C113 D C114 D C121 D C122 D C123 D C124 D C131 D C132 D C133 D C134 D C141 D C142 D C143 D C144 D C151 D C152 D C153 D C154 D C161 D C162 D C163 D C164 D C171 D C172 D C173 D C174 D C211 D C212 D C213 D C214 D C221 D C222 D C223 D C224 D C231 D C232 D C233 D C234 D C241 D C242 D C243 D C244 D C251 D C252 D C253 D C254 D C261 D C262 D C263 D C264 D C271 D C272 D C273 D C274 D C311 D C312 D C313 D C314 D C321 D C322 D C323 D C324 D C331 D C332 D C333 D C334 D C341 D C342 D C343 D C344 D C351 D C352 D C353 D C354 D C361 D C362 D C363 D C364 D C371 D C372 D C373 D C374 D C411 D C412 D C413 D C414 D C421 D C422 D C423 D C424 D C431 D C432 D C433 D C434 D C441 D C442 D C443 D C444 D C451 D C452 D C453 D C454 D C461 D C462 D C463 D C464 D C471 D C472 D C473 D C474 D C511 D C512 D C513 D C514 D C521 D C522 D C523 D C524 D C531 D C532 D C533 D C534 D C541 D C542 D C543 D C544 D C551 D C552 D C553 D C554 D C561 D C562 D C563 D C564 D C571 D C572 D C573 D C574 // Card face attributes D C111A D C112A D C113A D C114A D C121A D C122A D C123A D C124A D C131A D C132A D C133A D C134A D C141A D C142A D C143A D C144A D C151A D C152A D C153A D C154A D C161A D C162A D C163A D C164A D C171A D C172A D C173A D C174A D C211A D C212A D C213A D C214A D C221A D C222A D C223A D C224A D C231A D C232A D C233A D C234A D C241A D C242A D C243A D C244A D C251A D C252A D C253A D C254A D C261A D C262A D C263A D C264A D C271A D C272A D C273A D C274A D C311A D C312A D C313A D C314A D C321A D C322A D C323A D C324A D C331A D C332A D C333A D C334A D C341A D C342A D C343A D C344A D C351A D C352A D C353A D C354A D C361A D C362A D C363A D C364A D C371A D C372A D C373A D C374A D C411A D C412A D C413A D C414A D C421A D C422A D C423A D C424A D C431A D C432A D C433A D C434A D C441A D C442A D C443A D C444A D C451A D C452A D C453A D C454A D C461A D C462A D C463A D C464A D C471A D C472A D C473A D C474A D C511A D C512A D C513A D C514A D C521A D C522A D C523A D C524A D C531A D C532A D C533A D C534A D C541A D C542A D C543A D C544A D C551A D C552A D C553A D C554A D C561A D C562A D C563A D C564A D C571A D C572A D C573A D C574A //--*ENTRY PARMS *NONE* ----------------------------------- /free // Load initial splash screen to get game started. Credits = 100; WonLost = 0; exsr srResetSides; Face(1).Row = f_LoadFace('P '); Face(2).Row = f_LoadFace('O '); Face(3).Row = f_LoadFace('K '); Face(4).Row = f_LoadFace('E '); Face(5).Row = f_LoadFace('R '); 1b for ac = 1 to 5; 2b if ac = 1 or ac = 5; Color = %bitor(RED: RI); 2x elseif ac = 2; Color = %bitor(WHITE: RI); 2x elseif ac = 3; Color = %bitor(YELLOW: RI); 2x elseif ac = 4; Color = %bitor(BLUE: RI); 2e endif; TopBotAtr(ac) = Color; //-load Card colors---------- 2b for ax = 1 to 7; //Rows Attr(ac).Row(ax).Col(*) = Color; 2e endfor; 1e endfor; evalr scDow = %trimr(f_GetDayName()); exfmt SCREEN; 1b if InfdsFkey = f03; *inlr = *on; return; 1e endif; //--------------------------------------------------------- // Play the game. 1b dou 1 = 2; NewDeck = f_ShuffleDeck(); // Deal 5 Cards to users hand. // Sort hand by Card value then load images to screen. ax = 0; 2b for deal = 1 to 5; ax += 1; UserHand(ax) = NewDeck(Deal); 2e endfor; sorta UserHand; exsr srLoadUserScreen; exsr srEvalHandVal; Ind.ScreenCtl = *on; WonLost = 0; exfmt SCREEN; 2b if InfdsFkey = f03; 1v leave; 2e endif; // Deal Cards from the deck to replace cards user has X ed. ax = 5; 2b for deal = 1 to 5; 3b if DisCardArry(deal) > ' '; ax += 1; UserHand(Deal) = NewDeck(ax); 3e endif; 2e endfor; sorta UserHand; exsr srLoadUserScreen; clear disCardDS; exsr srEvalHandVal; exsr srCreditAdjust; Ind.ScreenCtl = *off; exfmt SCREEN; 2b if InfdsFkey = f03; 1v leave; 2e endif; 1e enddo; *inlr = *on; return; // See what is highest value of hand and payout. // Order is Royal Flush 250: 1 // Straight Flush 50: 1 // Four of a kind 25: 1 // Full House 8: 1 // Flush 5: 1 // Straight 4: 1 // Three of a kind 3: 1 // Two Pair 2: 1 // Jacks or Better 1: 1 begsr srEvalHandVal; clear HandValue; IsFlush = *off; IsStraight = *off; IsRoyalStraight = *off; // Set Flush Flag. 1b if UserSuite(1) = UserSuite(2) and UserSuite(1) = UserSuite(3) and UserSuite(1) = UserSuite(4) and UserSuite(1) = UserSuite(5); IsFlush = *on; 1e endif; // Set Straight Flag. This is complicated a bit as an ACE can either be 1 or 11. // Going to use concept of Straight and Royal Straight. Royal Straight will only // mean something different than Straight if Flush Flag is on. 1b if UserCard(1) = UserCard(2) - 1 and UserCard(1) = UserCard(3) - 2 and UserCard(1) = UserCard(4) - 3 and UserCard(1) = UserCard(5) - 4; IsStraight = *on; 1e endif; 1b if UserCard(1) = 1 and UserCard(2) = 10 and UserCard(3) = 11 and UserCard(4) = 12 and UserCard(5) = 13; IsRoyalStraight = *on; 1e endif; // Check for Straight Royal Flush 1b if IsFlush and IsRoyalStraight; HandValue = 'ROYAL FLUSH! Pays 250 to 1'; // set all Cards to reverse image outline 2b for ac = 1 to 5; exsr srReverseImageOutLine; 2e endfor; // Check for Straight Flush 1x elseif IsFlush and IsStraight; HandValue = 'STRAIGHT FLUSH! Pays 50 to 1'; // set all Cards to reverse image outline 2b for ac = 1 to 5; exsr srReverseImageOutLine; 2e endfor; // Check for 4 of a kind. Either 1st four or last 4 have to match. 1x elseif (UserCard(1) = UserCard(2) or UserCard(4) = UserCard(5)) and UserCard(2) = UserCard(3) and UserCard(2) = UserCard(4); HandValue = 'FOUR OF A KIND! Pays 25 to 1'; // Determine which Cards to reverse image outline 2b for ac = 1 to 2; 3b if UserCard(ac) = UserCard(ac + 1); exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; 3e endif; 2e endfor; // Check for Full House. First 2 have to match and last 3 have to match // or first 3 have to match and last 2 have to match. 1x elseif (UserCard(1) = UserCard(2) and UserCard(3) = UserCard(4) and UserCard(3) = UserCard(5)) or (UserCard(1) = UserCard(2) and UserCard(1) = UserCard(3) and UserCard(4) = UserCard(5)); HandValue = 'FULL HOUSE! Pays 8 to 1'; // set all Cards to reverse image outline 2b for ac = 1 to 5; exsr srReverseImageOutLine; 2e endfor; // Check for Flush 1x elseif IsFlush; HandValue = 'FLUSH! Pays 5 to 1'; // set all Cards to reverse image outline 2b for ac = 1 to 5; exsr srReverseImageOutLine; 2e endfor; // Check for Straight. 1x elseif IsStraight or IsRoyalStraight; HandValue = 'STRAIGHT! Pays 4 to 1'; // set all Cards to reverse image outline 2b for ac = 1 to 5; exsr srReverseImageOutLine; 2e endfor; // here Card 1,2,3 must match or 2,3,4 must match or 3,4,5 must match. 1x elseif (UserCard(3) = UserCard(1) and UserCard(3) = UserCard(2)) or (UserCard(3) = UserCard(2) and UserCard(3) = UserCard(4)) or (UserCard(3) = UserCard(4) and UserCard(3) = UserCard(5)); HandValue = '3 OF A KIND! Pays 3 to 1'; // Determine which Cards to reverse image outline 2b for ac = 1 to 3; 3b if UserCard(ac) = UserCard(ac + 1); exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; 3e endif; 2e endfor; // Check for 2 pairs // here Card if (1=2 then 3=4 or 4=5) or 2=3 and 4=5) 1x elseif (UserCard(1) = UserCard(2) and (UserCard(3) = UserCard(4) or UserCard(4) = UserCard(5))) or (UserCard(2) = UserCard(3) and UserCard(4) = UserCard(5)); HandValue = '2 PAIR Pays 2 to 1'; // Determine which Cards to reverse image outline 2b for ac = 1 to 4; 3b if UserCard(ac) = UserCard(ac + 1); exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; 3e endif; 2e endfor; //--------------------------------------------------------- // Check for 1 pair (any pair for now) // here Card 1=2 or 2=3 or 3=4 or 4=5) // To determine Jacks or better is again complicated by fact that aces // are represented by 1. If hand has two 1s, or 11s, or 12s, or 13s. // Fastest way might be to spin through array accumulating buckets. // If after loop if any bucket is > 2 then I have jacks or better. 1x elseif UserCard(1) = UserCard(2) or UserCard(2) = UserCard(3) or UserCard(3) = UserCard(4) or UserCard(4) = UserCard(5); AceBucket = 0; JackBucket = 0; QueenBucket = 0; KingBucket = 0; 2b for ax = 1 to 5; 3b if UserCard(ax) = 1; AceBucket += 1; 3x elseif UserCard(ax) = 11; JackBucket += 1; 3x elseif UserCard(ax) = 12; QueenBucket += 1; 3x elseif UserCard(ax) = 13; KingBucket += 1; 3e endif; 2e endfor; 2b if AceBucket = 2 or JackBucket = 2 or QueenBucket = 2 or KingBucket = 2; HandValue = 'JACKS OR BETTER. Pays 1 to 1'; 2x else; HandValue = 'PAIR Need Jacks or Better.'; 2e endif; // Determine which Cards to reverse image outline 2b for ac = 1 to 4; 3b if UserCard(ac) = UserCard(ac + 1); exsr srReverseImageOutLine; ac += 1; exsr srReverseImageOutLine; 3e endif; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // set Card outline to reverse image outline and same color as Card face. begsr srReverseImageOutLine; TopBotAtr(ac) = CardIdAtr(ac); BorderTopBot(ac) = *blanks; BorderSides(ac) = *blanks; BorderAtr(ac) = CardIdAtr(ac); endsr; //--------------------------------------------------------- // Adjust credit balance begsr srCreditAdjust; 1b if HandValue = 'ROYAL FLUSH! Pays 250 to 1'; WonLost = 2500; 1x elseif HandValue = 'STRAIGHT FLUSH! Pays 50 to 1'; WonLost = 1000; 1x elseif HandValue = 'FOUR OF A KIND! Pays 25 to 1'; WonLost = 500; 1x elseif HandValue = 'FULL HOUSE! Pays 8 to 1'; WonLost = 160; 1x elseif HandValue = 'FLUSH! Pays 5 to 1'; WonLost = 100; 1x elseif HandValue = 'STRAIGHT! Pays 4 to 1'; WonLost = 80; 1x elseif HandValue = '3 OF A KIND! Pays 3 to 1'; WonLost = 60; 1x elseif HandValue = '2 PAIR Pays 2 to 1'; WonLost = 40; 1x elseif HandValue = 'JACKS OR BETTER. Pays 1 to 1'; WonLost = 20; 1x else; //LOSER! WonLost = -(10); 1e endif; Credits += WonLost; endsr; //--------------------------------------------------------- // Load Card images to screen. // Mostly concerned with loading proper headings, messages, and setting indicators. begsr srLoadUserScreen; Face(*) = *blanks; Attr(*) = *blanks; exsr srResetSides; Attr(*) = *allx'00'; 1b for ac = 1 to 5; CardIdAtr(ac) = f_GetCardColor(UserSuite(ac)); CardID(ac) = f_GetCardFace(UserCard(ac)); Face(ac).Row = f_LoadFace(CardID(ac)); 2b for xx = 1 to 28; 3b if %subst(Face(ac):xx:1) <> ' '; %subst(Attr(ac):xx:1) = CardIdAtr(ac); 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // Set Card top and sides to default outline begsr srResetSides; BorderTopBot(*) = *blanks; BorderSides(*) = '|'; TopBotAtr(*) = %bitor(WHITE: UL); BorderAtr(*) = WHITE; endsr; /end-free //--------------------------------------------------------- // Return 7R X 4C array of selected character P f_LoadFace b D f_LoadFace PI 4a dim(7) D p_BaseChar 2a const D Line s 4a dim(7) /free 1b if p_BaseChar = 'A ' or p_BaseChar = 'A1 ' ; Line(1) = ' AA '; Line(2) = 'A A'; Line(3) = 'A A'; Line(4) = 'AAAA'; Line(5) = 'A A'; Line(6) = 'A A'; Line(7) = 'A A'; 1x elseif p_BaseChar = 'K '; Line(1) = 'K K'; Line(2) = 'K K '; Line(3) = 'KK '; Line(4) = 'K '; Line(5) = 'KK '; Line(6) = 'K K '; Line(7) = 'K K'; 1x elseif p_BaseChar = 'Q '; Line(1) = ' QQ '; Line(2) = 'Q Q'; Line(3) = 'Q Q'; Line(4) = 'Q Q'; Line(5) = 'Q Q'; Line(6) = 'Q QQ'; Line(7) = ' QQ '; 1x elseif p_BaseChar = 'J '; Line(1) = 'JJJJ'; Line(2) = ' J '; Line(3) = ' J '; Line(4) = ' J '; Line(5) = ' J '; Line(6) = 'J J '; Line(7) = 'JJJ '; 1x elseif p_BaseChar = '10'; Line(1) = '1000'; Line(2) = '10 0'; Line(3) = '10 0'; Line(4) = '10 0'; Line(5) = '10 0'; Line(6) = '10 0'; Line(7) = '1000'; 1x elseif p_BaseChar = '9 '; Line(1) = '9999'; Line(2) = '9 9'; Line(3) = '9 9'; Line(4) = '9999'; Line(5) = ' 9'; Line(6) = ' 9'; Line(7) = '9999'; 1x elseif p_BaseChar = '8 '; Line(1) = '8888'; Line(2) = '8 8'; Line(3) = '8 8'; Line(4) = '8888'; Line(5) = '8 8'; Line(6) = '8 8'; Line(7) = '8888'; 1x elseif p_BaseChar = '7 '; Line(1) = '7777'; Line(2) = ' 7'; Line(3) = ' 7'; Line(4) = ' 7 '; Line(5) = ' 7 '; Line(6) = '7 '; Line(7) = '7 '; 1x elseif p_BaseChar = '6 '; Line(1) = '6666'; Line(2) = '6 '; Line(3) = '6 '; Line(4) = '6666'; Line(5) = '6 6'; Line(6) = '6 6'; Line(7) = '6666'; 1x elseif p_BaseChar = '5 '; Line(1) = '5555'; Line(2) = '5 '; Line(3) = '5 '; Line(4) = '5555'; Line(5) = ' 5'; Line(6) = ' 5'; Line(7) = '5555'; 1x elseif p_BaseChar = '4 '; Line(1) = ' 44'; Line(2) = ' 4 4'; Line(3) = '4 4'; Line(4) = '4444'; Line(5) = ' 4'; Line(6) = ' 4'; Line(7) = ' 4'; 1x elseif p_BaseChar = '3 '; Line(1) = '3333'; Line(2) = ' 3'; Line(3) = ' 3'; Line(4) = ' 333'; Line(5) = ' 3'; Line(6) = ' 3'; Line(7) = '3333'; 1x elseif p_BaseChar = '2 '; Line(1) = '2222'; Line(2) = ' 2'; Line(3) = ' 2'; Line(4) = '2222'; Line(5) = '2 '; Line(6) = '2 '; Line(7) = '2222'; 1x elseif p_BaseChar = 'P '; Line(1) = 'PPPP'; Line(2) = 'P P'; Line(3) = 'P P'; Line(4) = 'PPPP'; Line(5) = 'P '; Line(6) = 'P '; Line(7) = 'P '; 1x elseif p_BaseChar = 'O '; Line(1) = ' OO '; Line(2) = 'O O'; Line(3) = 'O O'; Line(4) = 'O O'; Line(5) = 'O O'; Line(6) = 'O O'; Line(7) = ' OO '; 1x elseif p_BaseChar = 'E '; Line(1) = 'EEEE'; Line(2) = 'E '; Line(3) = 'E '; Line(4) = 'EEE '; Line(5) = 'E '; Line(6) = 'E '; Line(7) = 'EEEE'; 1x elseif p_BaseChar = 'R '; Line(1) = 'RRR '; Line(2) = 'R R'; Line(3) = 'R R'; Line(4) = 'RRR '; Line(5) = 'R R '; Line(6) = 'R R'; Line(7) = 'R R'; 1e endif; return Line; /end-free P f_LoadFace e ]]> v5r4 *---------------------------------------------------------------- * JCRGMPOKD - Video Poker - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A BORDER1A 1A P A BORDER2A 1A P A BORDER3A 1A P A BORDER4A 1A P A BORDER5A 1A P A TOPBOT1A 1A P A TOPBOT2A 1A P A TOPBOT3A 1A P A TOPBOT4A 1A P A TOPBOT5A 1A P A CARDID1A 1A P A CARDID2A 1A P A CARDID3A 1A P A CARDID4A 1A P A CARDID5A 1A P A C111A 1A P A C112A 1A P A C113A 1A P A C114A 1A P A C124A 1A P A C134A 1A P A C144A 1A P A C214A 1A P A C224A 1A P A C234A 1A P A C244A 1A P A C314A 1A P A C324A 1A P A C334A 1A P A C344A 1A P A C414A 1A P A C424A 1A P A C434A 1A P A C444A 1A P A C514A 1A P A C524A 1A P A C534A 1A P A C544A 1A P A C151A 1A P A C152A 1A P A C153A 1A P A C154A 1A P A C251A 1A P A C252A 1A P A C253A 1A P A C254A 1A P A C351A 1A P A C352A 1A P A C353A 1A P A C354A 1A P A C451A 1A P A C452A 1A P A C453A 1A P A C454A 1A P A C551A 1A P A C552A 1A P A C553A 1A P A C554A 1A P A C121A 1A P A C122A 1A P A C123A 1A P A C131A 1A P A C132A 1A P A C133A 1A P A C141A 1A P A C142A 1A P A C143A 1A P A C211A 1A P A C212A 1A P A C213A 1A P A C221A 1A P A C222A 1A P A C223A 1A P A C231A 1A P A C232A 1A P A C233A 1A P A C241A 1A P A C242A 1A P A C243A 1A P A C311A 1A P A C312A 1A P A C313A 1A P A C321A 1A P A C322A 1A P A C323A 1A P A C331A 1A P A C332A 1A P A C333A 1A P A C341A 1A P A C342A 1A P A C343A 1A P A C411A 1A P A C412A 1A P A C413A 1A P A C421A 1A P A C422A 1A P A C423A 1A P A C431A 1A P A C432A 1A P A C433A 1A P A C441A 1A P A C442A 1A P A C443A 1A P A C511A 1A P A C512A 1A P A C513A 1A P A C521A 1A P A C522A 1A P A C523A 1A P A C531A 1A P A C532A 1A P A C533A 1A P A C541A 1A P A C542A 1A P A C543A 1A P A C161A 1A P A C162A 1A P A C163A 1A P A C164A 1A P A C261A 1A P A C262A 1A P A C263A 1A P A C264A 1A P A C361A 1A P A C362A 1A P A C363A 1A P A C364A 1A P A C461A 1A P A C462A 1A P A C463A 1A P A C464A 1A P A C561A 1A P A C562A 1A P A C563A 1A P A C564A 1A P A C171A 1A P A C172A 1A P A C173A 1A P A C174A 1A P A C271A 1A P A C272A 1A P A C273A 1A P A C274A 1A P A C371A 1A P A C372A 1A P A C373A 1A P A C374A 1A P A C471A 1A P A C472A 1A P A C473A 1A P A C474A 1A P A C571A 1A P A C572A 1A P A C573A 1A P A C574A 1A P A 1 3'JCRGMPOK' COLOR(BLU) A 1 14'DRAW POKER!' COLOR(BLU) A 1 27'(Jacks or Better)' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A HANDVALUE 30A O 3 3 A BORDERTOP1 13A O 4 4DSPATR(&TOPBOT1A) A BORDERTOP2 13A O 4 19DSPATR(&TOPBOT2A) A BORDERTOP3 13A O 4 34DSPATR(&TOPBOT3A) A BORDERTOP4 13A O 4 49DSPATR(&TOPBOT4A) A BORDERTOP5 13A O 4 64DSPATR(&TOPBOT5A) A SIDE11L 1A O 5 4DSPATR(&BORDER1A) A CVALT1 2A O 5 6DSPATR(&CARDID1A) A SIDE11R 1A O 5 16DSPATR(&BORDER1A) A SIDE21L 1A O 5 19DSPATR(&BORDER2A) A CVALT2 2A O 5 21DSPATR(&CARDID2A) A SIDE21R 1A O 5 31DSPATR(&BORDER2A) A SIDE31L 1A O 5 34DSPATR(&BORDER3A) A CVALT3 2A O 5 36DSPATR(&CARDID3A) A SIDE31R 1A O 5 46DSPATR(&BORDER3A) A SIDE41L 1A O 5 49DSPATR(&BORDER4A) A CVALT4 2A O 5 51DSPATR(&CARDID4A) A SIDE41R 1A O 5 61DSPATR(&BORDER4A) A SIDE51L 1A O 5 64DSPATR(&BORDER5A) A CVALT5 2A O 5 66DSPATR(&CARDID5A) A SIDE51R 1A O 5 76DSPATR(&BORDER5A) A SIDE12L 1A O 6 4DSPATR(&BORDER1A) A SIDE12R 1A O 6 16DSPATR(&BORDER1A) A SIDE22L 1A O 6 19DSPATR(&BORDER2A) A SIDE22R 1A O 6 31DSPATR(&BORDER2A) A SIDE32L 1A O 6 34DSPATR(&BORDER3A) A SIDE32R 1A O 6 46DSPATR(&BORDER3A) A SIDE42L 1A O 6 49DSPATR(&BORDER4A) A SIDE42R 1A O 6 61DSPATR(&BORDER4A) A SIDE52L 1A O 6 64DSPATR(&BORDER5A) A SIDE52R 1A O 6 76DSPATR(&BORDER5A) A SIDE13L 1A O 7 4DSPATR(&BORDER1A) A C111 1A O 7 7DSPATR(&C111A) A C112 1A O 7 9DSPATR(&C112A) A C113 1A O 7 11DSPATR(&C113A) A C114 1A O 7 13DSPATR(&C114A) A SIDE13R 1A O 7 16DSPATR(&BORDER1A) A SIDE23L 1A O 7 19DSPATR(&BORDER2A) A C211 1A O 7 22DSPATR(&C211A) A C212 1A O 7 24DSPATR(&C212A) A C213 1A O 7 26DSPATR(&C213A) A C214 1A O 7 28DSPATR(&C214A) A SIDE23R 1A O 7 31DSPATR(&BORDER2A) A SIDE33L 1A O 7 34DSPATR(&BORDER3A) A C311 1A O 7 37DSPATR(&C311A) A C312 1A O 7 39DSPATR(&C312A) A C313 1A O 7 41DSPATR(&C313A) A C314 1A O 7 43DSPATR(&C314A) A SIDE33R 1A O 7 46DSPATR(&BORDER3A) A SIDE43L 1A O 7 49DSPATR(&BORDER4A) A C411 1A O 7 52DSPATR(&C411A) A C412 1A O 7 54DSPATR(&C412A) A C413 1A O 7 56DSPATR(&C413A) A C414 1A O 7 58DSPATR(&C414A) A SIDE43R 1A O 7 61DSPATR(&BORDER4A) A SIDE53L 1A O 7 64DSPATR(&BORDER5A) A C511 1A O 7 67DSPATR(&C511A) A C512 1A O 7 69DSPATR(&C512A) A C513 1A O 7 71DSPATR(&C513A) A C514 1A O 7 73DSPATR(&C514A) A SIDE53R 1A O 7 76DSPATR(&BORDER5A) A SIDE14L 1A O 8 4DSPATR(&BORDER1A) A C121 1A O 8 7DSPATR(&C121A) A C122 1A O 8 9DSPATR(&C122A) A C123 1A O 8 11DSPATR(&C123A) A C124 1A O 8 13DSPATR(&C124A) A SIDE14R 1A O 8 16DSPATR(&BORDER1A) A SIDE24L 1A O 8 19DSPATR(&BORDER2A) A C221 1A O 8 22DSPATR(&C221A) A C222 1A O 8 24DSPATR(&C222A) A C223 1A O 8 26DSPATR(&C223A) A C224 1A O 8 28DSPATR(&C224A) A SIDE24R 1A O 8 31DSPATR(&BORDER2A) A SIDE34L 1A O 8 34DSPATR(&BORDER3A) A C321 1A O 8 37DSPATR(&C321A) A C322 1A O 8 39DSPATR(&C322A) A C323 1A O 8 41DSPATR(&C323A) A C324 1A O 8 43DSPATR(&C324A) A SIDE34R 1A O 8 46DSPATR(&BORDER3A) A SIDE44L 1A O 8 49DSPATR(&BORDER4A) A C421 1A O 8 52DSPATR(&C421A) A C422 1A O 8 54DSPATR(&C422A) A C423 1A O 8 56DSPATR(&C423A) A C424 1A O 8 58DSPATR(&C424A) A SIDE44R 1A O 8 61DSPATR(&BORDER4A) A SIDE54L 1A O 8 64DSPATR(&BORDER5A) A C521 1A O 8 67DSPATR(&C521A) A C522 1A O 8 69DSPATR(&C522A) A C523 1A O 8 71DSPATR(&C523A) A C524 1A O 8 73DSPATR(&C524A) A SIDE54R 1A O 8 76DSPATR(&BORDER5A) A SIDE15L 1A O 9 4DSPATR(&BORDER1A) A C131 1A O 9 7DSPATR(&C131A) A C132 1A O 9 9DSPATR(&C132A) A C133 1A O 9 11DSPATR(&C133A) A C134 1A O 9 13DSPATR(&C134A) A SIDE15R 1A O 9 16DSPATR(&BORDER1A) A SIDE25L 1A O 9 19DSPATR(&BORDER2A) A C231 1A O 9 22DSPATR(&C231A) A C232 1A O 9 24DSPATR(&C232A) A C233 1A O 9 26DSPATR(&C233A) A C234 1A O 9 28DSPATR(&C234A) A SIDE25R 1A O 9 31DSPATR(&BORDER2A) A SIDE35L 1A O 9 34DSPATR(&BORDER3A) A C331 1A O 9 37DSPATR(&C331A) A C332 1A O 9 39DSPATR(&C332A) A C333 1A O 9 41DSPATR(&C333A) A C334 1A O 9 43DSPATR(&C334A) A SIDE35R 1A O 9 46DSPATR(&BORDER3A) A SIDE45L 1A O 9 49DSPATR(&BORDER4A) A C431 1A O 9 52DSPATR(&C431A) A C432 1A O 9 54DSPATR(&C432A) A C433 1A O 9 56DSPATR(&C433A) A C434 1A O 9 58DSPATR(&C434A) A SIDE45R 1A O 9 61DSPATR(&BORDER4A) A SIDE55L 1A O 9 64DSPATR(&BORDER5A) A C531 1A O 9 67DSPATR(&C531A) A C532 1A O 9 69DSPATR(&C532A) A C533 1A O 9 71DSPATR(&C533A) A C534 1A O 9 73DSPATR(&C534A) A SIDE55R 1A O 9 76DSPATR(&BORDER5A) A SIDE16L 1A O 10 4DSPATR(&BORDER1A) A C141 1A O 10 7DSPATR(&C141A) A C142 1A O 10 9DSPATR(&C142A) A C143 1A O 10 11DSPATR(&C143A) A C144 1A O 10 13DSPATR(&C144A) A SIDE16R 1A O 10 16DSPATR(&BORDER1A) A SIDE26L 1A O 10 19DSPATR(&BORDER2A) A C241 1A O 10 22DSPATR(&C241A) A C242 1A O 10 24DSPATR(&C242A) A C243 1A O 10 26DSPATR(&C243A) A C244 1A O 10 28DSPATR(&C244A) A SIDE26R 1A O 10 31DSPATR(&BORDER2A) A SIDE36L 1A O 10 34DSPATR(&BORDER3A) A C341 1A O 10 37DSPATR(&C341A) A C342 1A O 10 39DSPATR(&C342A) A C343 1A O 10 41DSPATR(&C343A) A C344 1A O 10 43DSPATR(&C344A) A SIDE36R 1A O 10 46DSPATR(&BORDER3A) A SIDE46L 1A O 10 49DSPATR(&BORDER4A) A C441 1A O 10 52DSPATR(&C441A) A C442 1A O 10 54DSPATR(&C442A) A C443 1A O 10 56DSPATR(&C443A) A C444 1A O 10 58DSPATR(&C444A) A SIDE46R 1A O 10 61DSPATR(&BORDER4A) A SIDE56L 1A O 10 64DSPATR(&BORDER5A) A C541 1A O 10 67DSPATR(&C541A) A C542 1A O 10 69DSPATR(&C542A) A C543 1A O 10 71DSPATR(&C543A) A C544 1A O 10 73DSPATR(&C544A) A SIDE56R 1A O 10 76DSPATR(&BORDER5A) A SIDE17L 1A O 11 4DSPATR(&BORDER1A) A C151 1A O 11 7DSPATR(&C151A) A C152 1A O 11 9DSPATR(&C152A) A C153 1A O 11 11DSPATR(&C153A) A C154 1A O 11 13DSPATR(&C154A) A SIDE17R 1A O 11 16DSPATR(&BORDER1A) A SIDE27L 1A O 11 19DSPATR(&BORDER2A) A C251 1A O 11 22DSPATR(&C251A) A C252 1A O 11 24DSPATR(&C252A) A C253 1A O 11 26DSPATR(&C253A) A C254 1A O 11 28DSPATR(&C254A) A SIDE27R 1A O 11 31DSPATR(&BORDER2A) A SIDE37L 1A O 11 34DSPATR(&BORDER3A) A C351 1A O 11 37DSPATR(&C351A) A C352 1A O 11 39DSPATR(&C352A) A C353 1A O 11 41DSPATR(&C353A) A C354 1A O 11 43DSPATR(&C354A) A SIDE37R 1A O 11 46DSPATR(&BORDER3A) A SIDE47L 1A O 11 49DSPATR(&BORDER4A) A C451 1A O 11 52DSPATR(&C451A) A C452 1A O 11 54DSPATR(&C452A) A C453 1A O 11 56DSPATR(&C453A) A C454 1A O 11 58DSPATR(&C454A) A SIDE47R 1A O 11 61DSPATR(&BORDER4A) A SIDE57L 1A O 11 64DSPATR(&BORDER5A) A C551 1A O 11 67DSPATR(&C551A) A C552 1A O 11 69DSPATR(&C552A) A C553 1A O 11 71DSPATR(&C553A) A C554 1A O 11 73DSPATR(&C554A) A SIDE57R 1A O 11 76DSPATR(&BORDER5A) A SIDE18L 1A O 12 4DSPATR(&BORDER1A) A C161 1A O 12 7DSPATR(&C161A) A C162 1A O 12 9DSPATR(&C162A) A C163 1A O 12 11DSPATR(&C163A) A C164 1A O 12 13DSPATR(&C164A) A SIDE18R 1A O 12 16DSPATR(&BORDER1A) A SIDE28L 1A O 12 19DSPATR(&BORDER2A) A C261 1A O 12 22DSPATR(&C261A) A C262 1A O 12 24DSPATR(&C262A) A C263 1A O 12 26DSPATR(&C263A) A C264 1A O 12 28DSPATR(&C264A) A SIDE28R 1A O 12 31DSPATR(&BORDER2A) A SIDE38L 1A O 12 34DSPATR(&BORDER3A) A C361 1A O 12 37DSPATR(&C361A) A C362 1A O 12 39DSPATR(&C362A) A C363 1A O 12 41DSPATR(&C363A) A C364 1A O 12 43DSPATR(&C364A) A SIDE38R 1A O 12 46DSPATR(&BORDER3A) A SIDE48L 1A O 12 49DSPATR(&BORDER4A) A C461 1A O 12 52DSPATR(&C461A) A C462 1A O 12 54DSPATR(&C462A) A C463 1A O 12 56DSPATR(&C463A) A C464 1A O 12 58DSPATR(&C464A) A SIDE48R 1A O 12 61DSPATR(&BORDER4A) A SIDE58L 1A O 12 64DSPATR(&BORDER5A) A C561 1A O 12 67DSPATR(&C561A) A C562 1A O 12 69DSPATR(&C562A) A C563 1A O 12 71DSPATR(&C563A) A C564 1A O 12 73DSPATR(&C564A) A SIDE58R 1A O 12 76DSPATR(&BORDER5A) A SIDE19L 1A O 13 4DSPATR(&BORDER1A) A C171 1A O 13 7DSPATR(&C171A) A C172 1A O 13 9DSPATR(&C172A) A C173 1A O 13 11DSPATR(&C173A) A C174 1A O 13 13DSPATR(&C174A) A SIDE19R 1A O 13 16DSPATR(&BORDER1A) A SIDE29L 1A O 13 19DSPATR(&BORDER2A) A C271 1A O 13 22DSPATR(&C271A) A C272 1A O 13 24DSPATR(&C272A) A C273 1A O 13 26DSPATR(&C273A) A C274 1A O 13 28DSPATR(&C274A) A SIDE29R 1A O 13 31DSPATR(&BORDER2A) A SIDE39L 1A O 13 34DSPATR(&BORDER3A) A C371 1A O 13 37DSPATR(&C371A) A C372 1A O 13 39DSPATR(&C372A) A C373 1A O 13 41DSPATR(&C373A) A C374 1A O 13 43DSPATR(&C374A) A SIDE39R 1A O 13 46DSPATR(&BORDER3A) A SIDE49L 1A O 13 49DSPATR(&BORDER4A) A C471 1A O 13 52DSPATR(&C471A) A C472 1A O 13 54DSPATR(&C472A) A C473 1A O 13 56DSPATR(&C473A) A C474 1A O 13 58DSPATR(&C474A) A SIDE49R 1A O 13 61DSPATR(&BORDER4A) A SIDE59L 1A O 13 64DSPATR(&BORDER5A) A C571 1A O 13 67DSPATR(&C571A) A C572 1A O 13 69DSPATR(&C572A) A C573 1A O 13 71DSPATR(&C573A) A C574 1A O 13 73DSPATR(&C574A) A SIDE59R 1A O 13 76DSPATR(&BORDER5A) A SIDE110L 1A O 14 4DSPATR(&BORDER1A) A SIDE110R 1A O 14 16DSPATR(&BORDER1A) A SIDE210L 1A O 14 19DSPATR(&BORDER2A) A SIDE210R 1A O 14 31DSPATR(&BORDER2A) A SIDE310L 1A O 14 34DSPATR(&BORDER3A) A SIDE310R 1A O 14 46DSPATR(&BORDER3A) A SIDE410L 1A O 14 49DSPATR(&BORDER4A) A SIDE410R 1A O 14 61DSPATR(&BORDER4A) A SIDE510L 1A O 14 64DSPATR(&BORDER5A) A SIDE510R 1A O 14 76DSPATR(&BORDER5A) A SIDE111L 1A O 15 4DSPATR(&BORDER1A) A SIDE111R 1A O 15 16DSPATR(&BORDER1A) A SIDE211L 1A O 15 19DSPATR(&BORDER2A) A SIDE211R 1A O 15 31DSPATR(&BORDER2A) A SIDE311L 1A O 15 34DSPATR(&BORDER3A) A SIDE311R 1A O 15 46DSPATR(&BORDER3A) A SIDE411L 1A O 15 49DSPATR(&BORDER4A) A SIDE411R 1A O 15 61DSPATR(&BORDER4A) A SIDE511L 1A O 15 64DSPATR(&BORDER5A) A SIDE511R 1A O 15 76DSPATR(&BORDER5A) A BORDERBOT1 13A O 16 4DSPATR(&TOPBOT1A) A BORDERBOT2 13A O 16 19DSPATR(&TOPBOT2A) A BORDERBOT3 13A O 16 34DSPATR(&TOPBOT3A) A BORDERBOT4 13A O 16 49DSPATR(&TOPBOT4A) A BORDERBOT5 13A O 16 64DSPATR(&TOPBOT5A) A 10 DISCARD1 1A B 17 10COLOR(WHT) A 10 DISCARD2 1A B 17 25COLOR(WHT) A 10 DISCARD3 1A B 17 40COLOR(WHT) A 10 DISCARD4 1A B 17 55COLOR(WHT) A 10 DISCARD5 1A B 17 70COLOR(WHT) A 10 19 5'X' COLOR(WHT) A 10 19 7'the DISCARDS. Press ENTER' A COLOR(BLU) A N10 19 49'Won' COLOR(BLU) A 19 57'Credits' COLOR(BLU) A WONLOST 5Y 0O 20 47EDTCDE(M) A CREDITS 5Y 0O 20 58EDTCDE(L) A N10 21 5'Press ENTER to DEAL' A COLOR(BLU) DSPATR(RI) A 22 48' ' DSPATR(RI) COLOR(YLW) A 22 50'=Clubs' A 22 59' ' DSPATR(RI) COLOR(WHT) A 22 61'=Diamonds' A 23 48' ' DSPATR(RI) COLOR(RED) A 23 50'=Hearts' A 23 59' ' DSPATR(RI) COLOR(BLU) A 23 61'=Spades' A 24 2'F3=Exit' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRGMPYR - Pyramid Solitaire // Addictive fun! // Goal is to select two cards whose values added together=13 till all cards played // NOTE: J + 2 = 13 Q + A = 13 // // After playing this a lot, I noticed there are many hands that are // obviously impossible to win. I am going to re-deal those hands. // Note: It is still not easy to win. // // added 'auto-match' section code to cut down on number times you // press the tab key. If you select a 9, the program will find the corresponding 4. etc. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMPYRD cf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D scrCardFaces s 2a dim(35) based(ptr1) D scrSelect s 1a dim(35) based(ptr2) D PrvCards s 2a dim(17) based(ptr3) D XinArrayCnt s 3u 0 D XinTotalCnt s 3u 0 D IndexFrom s 3u 0 D IndexTo s 3u 0 D xx s 3u 0 D yy s 3u 0 D zz s 3u 0 D row s 3u 0 inz(1) D col s 3u 0 inz(1) D AutoMatchVal s 3u 0 D FaceCounts s 3u 0 dim(13) D RowHigh s 3u 0 dim(13) D RowLow s 3u 0 dim(13) D RowMapper s 3u 0 dim(35) D ColMapper s 3u 0 dim(35) D SaveXIndex s 3u 0 dim(2) D UnDoArray s dim(37) like(screends) D UnDoCount s 3u 0 D IsError s n D IsPlayFromDeck s n D IsPlayFromPrv s n D IsPossible s n D IsAutoMatch s n D AutoMatchXLOC s 10a D FieldsNameArry s 10a dim(35) ctdata perrcd(1) D ptr1 s * inz(%addr(r1c1)) D ptr2 s * inz(%addr(x1c1)) D ptr3 s * inz(%addr(prvCard)) //--*COPY DEFINES------------------------------------------ /Define Sds /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetCardFace /Define f_RmvSflMsg /Define f_ShuffleDeck /Define f_SndSflMsg /Define f_GetRowColumn /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D ds D NewDeck 2a dim(52) inz D scrCardVals 3u 0 overlay(newdeck:1) D CardAtr ds dim(8) qualified based(ptr4) D Col 1a dim(7) D ptr4 s * inz(%addr(CardAtrDS)) D SelcRow ds dim(8) likeds(CardAtr) based(ptr5) D ptr5 s * inz(%addr(SelcAtrDS)) D scrCardFaces2d ds dim(8) likeds(CardAtr) inz // map screen fields into DS so ptrs to data can overlay // and undo function can work D ScreenDS ds inz D R1C1 D R2C1 D R2C2 D R3C1 D R3C2 D R3C3 D R4C1 D R4C2 D R4C3 D R4C4 D R5C1 D R5C2 D R5C3 D R5C4 D R5C5 D R6C1 D R6C2 D R6C3 D R6C4 D R6C5 D R6C6 D R7C1 D R7C2 D R7C3 D R7C4 D R7C5 D R7C6 D R7C7 D RFC1 D RFC2 D RFC3 D RFC4 D RFC5 D RFC6 D RFC7 D X1C1 D X2C1 D X2C2 D X3C1 D X3C2 D X3C3 D X4C1 D X4C2 D X4C3 D X4C4 D X5C1 D X5C2 D X5C3 D X5C4 D X5C5 D X6C1 D X6C2 D X6C3 D X6C4 D X6C5 D X6C6 D X7C1 D X7C2 D X7C3 D X7C4 D X7C5 D X7C6 D X7C7 D XFC1 D XFC2 D XFC3 D XFC4 D XFC5 D XFC6 D XFC7 D NextX D PrvX D PrvCard D PrvCard2 D PrvCard3 D PrvCard4 D PrvCard5 D PrvCard6 D PrvCard7 D PrvCard8 D PrvCard9 D PrvCard10 D PrvCard11 D PrvCard12 D PrvCard13 D PrvCard14 D PrvCard15 D PrvCard16 D PrvCard17 D CardsLeft D CardsInDec D NextCard D PrvCardVal 3u 0 D DeckCardVal 3u 0 D NxtPlayC 3u 0 // I am dealing with asymmetrical 2 dim array in the shape of a pyramid. // row 1 will be 1,1 // row 2 will be 2,1 then 2,2, etc. D CardAtrDS DS D CardAtr11 D CardAtr21 overlay(CardAtrDS:8) D CardAtr22 D CardAtr31 overlay(CardAtrDS:15) D CardAtr32 D CardAtr33 D CardAtr41 overlay(CardAtrDS:22) D CardAtr42 D CardAtr43 D CardAtr44 D CardAtr51 overlay(CardAtrDS:29) D CardAtr52 D CardAtr53 D CardAtr54 D CardAtr55 D CardAtr61 overlay(CardAtrDS:36) D CardAtr62 D CardAtr63 D CardAtr64 D CardAtr65 D CardAtr66 D CardAtr71 overlay(CardAtrDS:43) D CardAtr72 D CardAtr73 D CardAtr74 D CardAtr75 D CardAtr76 D CardAtr77 D CardAtr81 overlay(CardAtrDS:50) D CardAtr82 D CardAtr83 D CardAtr84 D CardAtr85 D CardAtr86 D CardAtr87 D SelcAtrDS DS D SelcAtr11 D SelcAtr21 overlay(SelcAtrDS:8) D SelcAtr22 D SelcAtr31 overlay(SelcAtrDS:15) D SelcAtr32 D SelcAtr33 D SelcAtr41 overlay(SelcAtrDS:22) D SelcAtr42 D SelcAtr43 D SelcAtr44 D SelcAtr51 overlay(SelcAtrDS:29) D SelcAtr52 D SelcAtr53 D SelcAtr54 D SelcAtr55 D SelcAtr61 overlay(SelcAtrDS:36) D SelcAtr62 D SelcAtr63 D SelcAtr64 D SelcAtr65 D SelcAtr66 D SelcAtr71 overlay(SelcAtrDS:43) D SelcAtr72 D SelcAtr73 D SelcAtr74 D SelcAtr75 D SelcAtr76 D SelcAtr77 D SelcAtr81 overlay(SelcAtrDS:50) D SelcAtr82 D SelcAtr83 D SelcAtr84 D SelcAtr85 D SelcAtr86 D SelcAtr87 //--*ENTRY PARMS *NONE* ----------------------------------- //--------------------------------------------------------- // The program deals with cards as a string of values or // with cards as a two dim array, // Some sections have to deal with both, so I am going to load // a 'mapper' array of rows and columns // string position 1 = row 1, column 1 // string position 2 = row 2, column 1 // string position 3 = row 2, column 2 //--------------------------------------------------------- /free 1b for xx = 1 to 35; RowMapper(xx) = Row; ColMapper(xx) = Col; 2b if Col = Row; Col = 0; Row += 1; 2e endif; Col += 1; 1e endfor; f_RmvSflMsg(ProgId); exsr srNewStart; 1b dou 1 = 2; 2b if cardsleft = 0; f_SndSflMsg(ProgId: ' ************** WINNER **************'); 2e endif; 2b if not IsError and InfdsFkey <> f05; UnDoCount += 1; UnDoArray(UnDoCount) = ScreenDS; 2e endif; write MSGCTL; exfmt SCREEN; f_RmvSflMsg(ProgId); AutoMatchXLOC = *blanks; csrrow = 9; csrcol = 7; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2x elseif InfdsFkey = f01 and CardsInDec > 0; exsr srNextCard; 2x elseif InfdsFkey = f05; exsr srUnDo; exsr srSetHiLite; 2x elseif InfdsFkey = F09; exsr srNewStart; 2x else; exsr srEditSelect; 3b if not IsError; exsr srSetHiLite; 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- // Reset SCREEN back to previous state begsr srUnDo; 1b if UnDoCount <> 1; UnDoCount -= 1; 1e endif; ScreenDS = UnDoArray(UnDoCount); 1b for row = 7 to 8; SelcRow(row).Col(*) = %bitor(Green:UL); 1e endfor; 1b if UnDoCount = 1; f_SndSflMsg(ProgId: ' GAME START. X TWO CARDS=13. PRESS ENTER'); 1e endif; endsr; //--------------------------------------------------------- begsr srGetPrevC; PrvCard = *blank; PrvX = *blanks; PrvCardVal = 0; 1b if prvCards(2) > *blanks; 2b for zz = 2 to 17; PrvCards(zz-1) = PrvCards(zz); 2e endfor; // Load numeric value from face value. 2b if PrvCards(1) = 'A '; PrvCardVal = 1; 2x elseif PrvCards(1) = 'J '; PrvCardVal = 11; 2x elseif PrvCards(1) = 'Q '; PrvCardVal = 12; 2x elseif PrvCards(1) = 'K '; PrvCardVal = 13; 2x else; PrvCardVal = %uns(PrvCards(1)); 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Autoskip if King is next card. begsr srNextCard; PrvX = *blanks; NextX = *blanks; scrSelect(*) = *blanks; 1b if NxtPlayC < 53; 2b if not (IsPlayFromDeck or IsPlayFromPrv); 3b for zz = 17 downto 2; PrvCards(zz) = PrvCards(zz-1); 3e endfor; PrvCards(1) = NextCard; PrvCardVal = DeckCardVal; 2e endif; IsPlayFromDeck = *off; 2b dou scrCardVals(NxtPlayC) <> 13; NxtPlayC += 1; 3b if NxtPlayC >= 53; clear NextCard; DeckCardVal = 0; CardsInDec = 0; 2v leave; 3x else; NextCard = f_GetCardFace(scrCardVals(NxtPlayC)); DeckCardVal = scrCardVals(NxtPlayC); CardsInDec -= 1; 3e endif; 2e enddo; 1e endif; endsr; //--------------------------------------------------------- // Make sure user only X's two selections and they total 13. // Note if single value is selected, that evokes the auto-match function // where the computer finds the corresponding = 13 matching card. // It is important to know where the single X was located (AutoMatchXLOC) // as the X in different place causes different search patterns based // on what I consider the user is most likely wanting to do. begsr srEditSelect; IsError = *off; XinTotalCnt = 0; XinArrayCnt = 0; yy = 0; 1b if Nextx > ' '; AutoMatchVal = DeckCardVal; AutoMatchXLOC = 'SIDE NEXT'; XinTotalCnt += 1; 1e endif; 1b if PrvX > ' '; AutoMatchVal = PrvCardVal; AutoMatchXLOC = 'SIDE PRV '; XinTotalCnt += 1; 1e endif; 1b for xx = 1 to 35; 2b if scrSelect(xx) > ' '; XinTotalCnt += 1; XinArrayCnt += 1; 3b if XinTotalCnt < 3; yy += 1; SaveXIndex(yy) = xx; // index of card with 'X' AutoMatchVal = scrCardVals(xx); 4b if xx <= 28; AutoMatchXLOC = 'MIDDLE '; 4x else; AutoMatchXLOC = 'BOTTOM '; 4e endif; 3e endif; 2e endif; 1e endfor; 1b if XinTotalCnt = 1; //only selected one IsError = *off; exsr SrAutoMatch; 2b if not IsAutoMatch; f_SndSflMsg(ProgId: ' NO AUTO-MATCH FOUND.'); IsError = *on; //----------------------------------------------------------- // execute function to return row/column for position cursor // first find the X. 3b if NextX > ' '; CsrRowColDS = f_GetRowColumn('NEXTX ':InfdsFile:InfdsLib:InfdsRcdfmt); 3x elseif PrvX > ' '; CsrRowColDS = f_GetRowColumn('PRVX ':InfdsFile:InfdsLib:InfdsRcdfmt); 3x else; 4b for xx = 1 to 35; 5b if scrSelect(xx) > ' '; CsrRowColDS = f_GetRowColumn(FieldsNameArry(xx): InfdsFile:InfdsLib:InfdsRcdfmt); 4v leave; 5e endif; 4e endfor; 3e endif; 2e endif; 1e endif; 1b if XinTotalCnt > 2; //more than 2 selected f_SndSflMsg(ProgId: ' TOO MANY CARDS SELECTED.'); IsError = *on; 1x elseif XinTotalCnt < 1; //None selected f_SndSflMsg(ProgId: ' PLEASE SELECT CARDS.'); IsError = *on; 1x elseif XinTotalCnt = 2; 2b if XinArrayCnt = 2; //both from array 3b if scrCardVals(SaveXIndex(1)) + scrCardVals(SaveXIndex(2)) <> 13; f_SndSflMsg(ProgId: ' SELECT TWO CARDS = 13.'); IsError = *on; 3x else; //two selected = 13 f_RmvSflMsg(ProgId); scrCardFaces(SaveXIndex(1)) = *blanks; scrCardFaces(SaveXIndex(2)) = *blanks; scrSelect(SaveXIndex(1)) = *blanks; scrSelect(SaveXIndex(2)) = *blanks; 3e endif; // picked next card and one from tree 2x elseif XinArrayCnt = 1 and NextX > ' '; 3b if scrCardVals(SaveXIndex(1)) + DeckCardVal <> 13; f_SndSflMsg(ProgId: ' SELECT TWO CARDS = 13.'); IsError = *on; 3x else; //two selected = 13 f_RmvSflMsg(ProgId); scrCardFaces(SaveXIndex(1)) = *blanks; scrSelect(SaveXIndex(1)) = *blanks; IsPlayFromDeck = *on; exsr srNextCard; 3e endif; // picked prv card and one from tree 2x elseif XinArrayCnt = 1 and PrvX > ' '; 3b if scrCardVals(SaveXIndex(1)) + PrvCardVal <> 13; f_SndSflMsg(ProgId: ' SELECT TWO CARDS = 13.'); IsError = *on; 3x else; //two selected = 13 f_RmvSflMsg(ProgId); scrCardFaces(SaveXIndex(1)) = *blanks; scrSelect(SaveXIndex(1)) = *blanks; exsr srGetPrevC; 3e endif; // picked next card from deck and prv card from deck 2x elseif NextX > ' ' and PrvX > ' '; 3b if (DeckCardVal + PrvCardVal) <> 13; f_SndSflMsg(ProgId: ' SELECT TWO CARDS = 13.'); IsError = *on; 3x else; //two selected = 13 f_RmvSflMsg(ProgId); NextX = *blanks; PrvX = *blanks; IsPlayFromPrv = *on; exsr srNextCard; exsr srGetPrevC; IsPlayFromPrv = *off; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // If two cards that would overlap this card from below are = *blanks and // card > *blanks, then highlight new available field. // First step is to get cards into 2 dim pyramid array. begsr srSetHiLite; CardsLeft = 0; 1b for xx = 1 to 35; scrCardFaces2d(RowMapper(xx)).Col(ColMapper(xx)) = scrCardFaces(xx); 2b if scrCardFaces(xx) > *blanks and RowMapper(xx) <> 8; CardsLeft += 1; 2e endif; 1e endfor; // now that cards are in two dim array I can set SCREEN attributes 1b for xx = 1 to 35; row = RowMapper(xx); col = ColMapper(xx); 2b if row <= 6; 3b if (scrCardFaces2d(Row).Col(Col) = *blanks or (scrCardFaces2d(Row).Col(Col) > *blanks and (scrCardFaces2d(Row + 1).Col(Col) > *blanks or scrCardFaces2d(Row + 1).Col(Col + 1) > *blanks))); CardAtr(row).Col(col) = Green; SelcRow(row).Col(col) = %bitor(ND: PR); 3x else; CardAtr(row).Col(col) = White; SelcRow(row).Col(col) = %bitor(Green: UL); 3e endif; 2x else; 3b if scrCardFaces2d(Row).Col(Col) = *blanks; SelcRow(row).Col(col) = %bitor(ND: PR); 3x else; CardAtr(row).Col(col) = White; 3e endif; 2e endif; 1e endfor; endsr; //------------------------------------------------------------------------- // Complete the auto match process. // User has to select at least one card, for example they X an 8. // The program will search in sequence // 1) the middle section (triangle) starting at the bottom right and // working up to the top to find a 5 that is open to play. // 2) the side section (previous card first then card from deck) // 3) the free card or bottom section. // This feature will significantly reduce number of times user has to press tab key // and really speed up play // Screen attributes that are white can be tested for = 13. // (yeah, the screen attributes are references as a 2 dim array) // // If 'X' is on Next card ('SIDE NEXT') then only search the middle for a match. // If 'X' is on Previous card ('SIDE PRV ') then search middle, the free cards // for a match. // If 'X' is in middle triangle, ('MIDDLE ') search middle, then PRV, then NEXT, then FREE // if 'X' is in Bottom or Free card section ('BOTTOM ') search middle. //------------------------------------------------------------------------- begsr SrAutoMatch; isAutoMatch = *off; IndexFrom = 28; IndexTo = 1; exsr srAutoMatch_Search; 1b if AutoMatchXLOC = 'SIDE NEXT' or AutoMatchXLOC = 'SIDE PRV '; 2b if isAutoMatch; SaveXIndex(1) = xx; scrSelect(xx) = 'X'; 2x else; // search bottom IndexFrom = 35; IndexTo = 29; exsr srAutoMatch_Search; 3b if isAutoMatch; SaveXIndex(1) = xx; scrSelect(xx) = 'X'; 3e endif; 2e endif; 1x elseif AutoMatchXLOC = 'MIDDLE '; 2b if isAutoMatch; SaveXIndex(2) = xx; scrSelect(xx) = 'X'; 2x else; // check previous card 3b if PrvCardVal + AutoMatchVal = 13; PrvX = 'X'; IsAutoMatch = *on; XinTotalCnt += 1; // next next dealt card 3x elseif DeckCardVal + AutoMatchVal = 13; NextX = 'X'; IsAutoMatch = *on; XinTotalCnt += 1; // check across bottom of free cards 3x else; IndexFrom = 35; IndexTo = 29; exsr srAutoMatch_Search; 4b if isAutoMatch; SaveXIndex(2) = xx; scrSelect(xx) = 'X'; 4e endif; 3e endif; 2e endif; 1x elseif AutoMatchXLOC = 'BOTTOM '; 2b if isAutoMatch; SaveXIndex(2) = xx; scrSelect(xx) = 'X'; 2e endif; 1e endif; endsr; //------------------------------------------------------------------------- begsr srAutoMatch_Search; 1b for xx = IndexFrom downto IndexTo; 2b if scrCardFaces(xx) > *blanks and %bitand(CardAtr(RowMapper(xx)).Col(ColMapper(xx)): White) = White and (scrCardVals(xx) + AutoMatchVal) = 13; isAutoMatch = *on; XinTotalCnt += 1; XinArrayCnt += 1; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr srNewStart; csrrow = 9; csrcol = 7; clear screenDS; evalr scDow = %trimr(f_GetDayName()); // Deal 35 cards to pyramid and free use cards. 1b dou IsPossible; RowHigh(*) = 9; RowLow(*) = 0; IsPossible = *on; FaceCounts(*) = 0; NewDeck = f_ShuffleDeck(); // easier if free deck is full (no kings) 2b for xx = 29 to 35; 3b if scrCardVals(xx) = 13; IsPossible = *off; 2v leave; 3e endif; 2e endfor; 2b if not IsPossible; 1i iter; 2e endif; sorta %subarr(scrCardVals:29:7); scrCardFaces(*) = *blanks; //--------------------------------------------------------- // Idea is check for hands that are impossible to win // FaceCounts array is loaded with count of each type card // Element 1 would be total number of aces in pyramid. // Element 2 would be total number of two in pyramid. 2b for xx = 1 to 35; zz = scrCardVals(xx); 3b if xx < 29; FaceCounts(zz) += 1; 4b if RowMapper(xx) < RowHigh(zz); RowHigh(zz) = RowMapper(xx); 4e endif; 4b if RowMapper(xx) > RowLow(zz); RowLow(zz) = RowMapper(xx); 4e endif; 3e endif; 3b if zz <> 13; scrCardFaces(xx) = f_GetCardFace(zz); 3e endif; 2e endfor; // four of anything in not-free rows will 99% spell defeat 2b for xx = 1 to 12; 3b if FaceCounts(xx) = 4; IsPossible = *off; 2v leave; 3e endif; //--------------------------------------------------------- // Next winner killer is 3 of same card higher or lower than 2 of // that card's =13 partner. Ex. 3 Aces over 2 Queens usually cannot win. 3b if FaceCounts(xx) = 3; 4b if FaceCounts(13 - xx) > 1; 5b if RowLow(xx) < RowHigh(13 - xx) or RowHigh(xx) > RowLow(13 - xx); IsPossible = *off; 2v leave; 5e endif; 4e endif; 3e endif; 2e endfor; 1e enddo; xx = 36; 1b dow scrCardVals(xx) = 13; xx += 1; 1e enddo; CardsInDec = 53 - xx; NextCard = f_GetCardFace(scrCardVals(xx)); DeckCardVal = scrCardVals(xx); NxtPlayC = xx; 1b for row = 7 to 8; SelcRow(row).Col(*) = %bitor(Green:UL); 1e endfor; exsr srSetHiLite; UnDoCount = 0; f_SndSflMsg(ProgId: ' X TWO CARDS=13. PRESS ENTER'); endsr; //-------------------------------------------------------------------- // If user selects a single X for which there is not // auto-match, I want to position the cursor on the field name // that was X'ed. Unfortunately I need to know the name of that field // so I can retrieve the row/column to put the cursor ** FieldsNameArry X1C1 X2C1 X2C2 X3C1 X3C2 X3C3 X4C1 X4C2 X4C3 X4C4 X5C1 X5C2 X5C3 X5C4 X5C5 X6C1 X6C2 X6C3 X6C4 X6C5 X6C6 X7C1 X7C2 X7C3 X7C4 X7C5 X7C6 X7C7 XFC1 XFC2 XFC3 XFC4 XFC5 XFC6 XFC7 ]]> v5r4 *---------------------------------------------------------------- * JCRGMPYRD - Pyramid Solitaire - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA01 CA03 CA05 CA09 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN OVERLAY CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A CARDATR11 1A P A CARDATR21 1A P A CARDATR22 1A P A CARDATR31 1A P A CARDATR32 1A P A CARDATR33 1A P A CARDATR41 1A P A CARDATR42 1A P A CARDATR43 1A P A CARDATR44 1A P A CARDATR51 1A P A CARDATR52 1A P A CARDATR53 1A P A CARDATR54 1A P A CARDATR55 1A P A CARDATR61 1A P A CARDATR62 1A P A CARDATR63 1A P A CARDATR64 1A P A CARDATR65 1A P A CARDATR66 1A P A CARDATR71 1A P A CARDATR72 1A P A CARDATR73 1A P A CARDATR74 1A P A CARDATR75 1A P A CARDATR76 1A P A CARDATR77 1A P A CARDATR81 1A P A CARDATR82 1A P A CARDATR83 1A P A CARDATR84 1A P A CARDATR85 1A P A CARDATR86 1A P A CARDATR87 1A P A SELCATR11 1A P A SELCATR21 1A P A SELCATR22 1A P A SELCATR31 1A P A SELCATR32 1A P A SELCATR33 1A P A SELCATR41 1A P A SELCATR42 1A P A SELCATR43 1A P A SELCATR44 1A P A SELCATR51 1A P A SELCATR52 1A P A SELCATR53 1A P A SELCATR54 1A P A SELCATR55 1A P A SELCATR61 1A P A SELCATR62 1A P A SELCATR63 1A P A SELCATR64 1A P A SELCATR65 1A P A SELCATR66 1A P A SELCATR71 1A P A SELCATR72 1A P A SELCATR73 1A P A SELCATR74 1A P A SELCATR75 1A P A SELCATR76 1A P A SELCATR77 1A P A SELCATR81 1A P A SELCATR82 1A P A SELCATR83 1A P A SELCATR84 1A P A SELCATR85 1A P A SELCATR86 1A P A SELCATR87 1A P A 1 3'JCRGMPYR' COLOR(BLU) A 1 14'PYRAMID' COLOR(BLU) A 1 23'(Match pairs totaling 13)' A COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 3'Cards in Deck' COLOR(BLU) A 3 36'Cards in Pyramid' COLOR(BLU) A CARDSINDEC 3Y 0O 4 5EDTCDE(3) COLOR(BLU) A R1C1 2A O 4 25DSPATR(&CARDATR11) A CARDSLEFT 3Y 0O 4 40EDTCDE(3) COLOR(BLU) A X1C1 1A B 5 25DSPATR(&SELCATR11) A R2C1 2A O 6 23DSPATR(&CARDATR21) A R2C2 2A O 6 27DSPATR(&CARDATR22) A 6 48'List of Previous' A COLOR(BLU) DSPATR(UL) A 7 6'Deck' COLOR(BLU) A X2C1 1A B 7 23DSPATR(&SELCATR21) A X2C2 1A B 7 27DSPATR(&SELCATR22) A PRVCARD2 2A O 7 48 A NEXTCARD 2A O 8 6DSPATR(HI) A R3C1 2A O 8 21DSPATR(&CARDATR31) A R3C2 2A O 8 25DSPATR(&CARDATR32) A R3C3 2A O 8 29DSPATR(&CARDATR33) A PRVCARD3 2A O 8 48 A NEXTX 1A B 9 7 A X3C1 1A B 9 21DSPATR(&SELCATR31) A X3C2 1A B 9 25DSPATR(&SELCATR32) A X3C3 1A B 9 29DSPATR(&SELCATR33) A PRVCARD4 2A O 9 48 A R4C1 2A O 10 19DSPATR(&CARDATR41) A R4C2 2A O 10 23DSPATR(&CARDATR42) A R4C3 2A O 10 27DSPATR(&CARDATR43) A R4C4 2A O 10 31DSPATR(&CARDATR44) A PRVCARD5 2A O 10 48 A X4C1 1A B 11 19DSPATR(&SELCATR41) A X4C2 1A B 11 23DSPATR(&SELCATR42) A X4C3 1A B 11 27DSPATR(&SELCATR43) A X4C4 1A B 11 31DSPATR(&SELCATR44) A PRVCARD6 2A O 11 48 A 12 6'Prv' COLOR(BLU) A R5C1 2A O 12 17DSPATR(&CARDATR51) A R5C2 2A O 12 21DSPATR(&CARDATR52) A R5C3 2A O 12 25DSPATR(&CARDATR53) A R5C4 2A O 12 29DSPATR(&CARDATR54) A R5C5 2A O 12 33DSPATR(&CARDATR55) A PRVCARD7 2A O 12 48 A PRVCARD 2A O 13 6DSPATR(HI) A X5C1 1A B 13 17DSPATR(&SELCATR51) A X5C2 1A B 13 21DSPATR(&SELCATR52) A X5C3 1A B 13 25DSPATR(&SELCATR53) A X5C4 1A B 13 29DSPATR(&SELCATR54) A X5C5 1A B 13 33DSPATR(&SELCATR55) A PRVCARD8 2A O 13 48 A PRVX 1A B 14 7 A R6C1 2A O 14 15DSPATR(&CARDATR61) A R6C2 2A O 14 19DSPATR(&CARDATR62) A R6C3 2A O 14 23DSPATR(&CARDATR63) A R6C4 2A O 14 27DSPATR(&CARDATR64) A R6C5 2A O 14 31DSPATR(&CARDATR65) A R6C6 2A O 14 35DSPATR(&CARDATR66) A PRVCARD9 2A O 14 48 A X6C1 1A B 15 15DSPATR(&SELCATR61) A X6C2 1A B 15 19DSPATR(&SELCATR62) A X6C3 1A B 15 23DSPATR(&SELCATR63) A X6C4 1A B 15 27DSPATR(&SELCATR64) A X6C5 1A B 15 31DSPATR(&SELCATR65) A X6C6 1A B 15 35DSPATR(&SELCATR66) A PRVCARD10 2A O 15 48 A R7C1 2A O 16 13DSPATR(&CARDATR71) A R7C2 2A O 16 17DSPATR(&CARDATR72) A R7C3 2A O 16 21DSPATR(&CARDATR73) A R7C4 2A O 16 25DSPATR(&CARDATR74) A R7C5 2A O 16 29DSPATR(&CARDATR75) A R7C6 2A O 16 33DSPATR(&CARDATR76) A R7C7 2A O 16 37DSPATR(&CARDATR77) A PRVCARD11 2A O 16 48 A X7C1 1A B 17 13DSPATR(&SELCATR71) A X7C2 1A B 17 17DSPATR(&SELCATR72) A X7C3 1A B 17 21DSPATR(&SELCATR73) A X7C4 1A B 17 25DSPATR(&SELCATR74) A X7C5 1A B 17 29DSPATR(&SELCATR75) A X7C6 1A B 17 33DSPATR(&SELCATR76) A X7C7 1A B 17 37DSPATR(&SELCATR77) A PRVCARD12 2A O 17 48 A 18 12' ' A DSPATR(UL) A PRVCARD13 2A O 18 48 A 19 6'Free' COLOR(BLU) A RFC1 2A O 19 13DSPATR(&CARDATR81) A RFC2 2A O 19 17DSPATR(&CARDATR82) A RFC3 2A O 19 21DSPATR(&CARDATR83) A RFC4 2A O 19 25DSPATR(&CARDATR84) A RFC5 2A O 19 29DSPATR(&CARDATR85) A RFC6 2A O 19 33DSPATR(&CARDATR86) A RFC7 2A O 19 37DSPATR(&CARDATR87) A PRVCARD14 2A O 19 48 A XFC1 1A B 20 13DSPATR(&SELCATR81) A XFC2 1A B 20 17DSPATR(&SELCATR82) A XFC3 1A B 20 21DSPATR(&SELCATR83) A XFC4 1A B 20 25DSPATR(&SELCATR84) A XFC5 1A B 20 29DSPATR(&SELCATR85) A XFC6 1A B 20 33DSPATR(&SELCATR86) A XFC7 1A B 20 37DSPATR(&SELCATR87) A PRVCARD15 2A O 20 48 A 21 12' ' A DSPATR(UL) A PRVCARD16 2A O 21 48 A PRVCARD17 2A O 22 48 A 23 2'F3=Exit' COLOR(BLU) A 23 15'F1=Turn up Next Card' COLOR(BLU) A 23 43'F5=UnDo' COLOR(BLU) A 23 57'F9=New Game' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 //--------------------------------------------------------- // JCRGMRCB - RUBIK'S CUBE // Original idea was to test functions as virtual 3d array indexes. Getx() function // emulates 3d addressing quite nicely. // // Challenge begin when I realized rubik cube is not concerned with what is in // array element. (You think of the cube as a 3x3x3 array). It is concerned with behavior // of outside 'faces' of each element. // I use a 6X3X3 array definition with each of 6 faces of the cube having a 3X3 // world to play in. The majority of program is mapping these 3x3 elements on one face to // another face when cube is rotated. //--------------------------------------------------------- // This led to interesting concept of planes. // Rotating cube from side to side. Front, Sides, and Back are in // same plane(A). 1,1,1 corresponds to 2,1,1 to 3,1,1 to 4,1,1 etc. // // Rotating cube top to bottom. // Top and Bottom can be defined as being in same plane(B) as Front. // If rotating cube this way in physical world, Back is also in plane(B). o // However, RPG does not allow field to be defined in multiple data structures. // Function altp() was defined to allow index mapping across different rotational planes // // Finally, twists from side>top>other side>bottom have no coordinates in the same // plane. At this point I ran out of headspace, bought a cube, labeled all surfaces, // and mapped from results of manual twists. //--------------------------------------------------------- // Game Play: Game function mimic physical rubik's cube. You can also play // 'Beat the Computer' version with rules designed by Peter Suber at // http://www.earlham.edu/~peters/writing/cube.htm . // It was from his page where I got the idea for allowing user to control number // of initial randomizing spins. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMRCBD cf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D AlphaCol s 1a D AlphaRow s 1a D cc s 3u 0 D Col s 3u 0 D ForCount s 3u 0 D Row s 3u 0 D rr s 3u 0 D SelectView s 3u 0 D Side s 3u 0 D ss s 3u 0 D xx s 3u 0 D yy s 3u 0 //--*DATA STRUCTURES--------------------------------------- // 3d structure for cube face values D Face ds dim(6) qualified based(Ptr1) D Row likeds(Rowa) dim(3) D Rowa ds qualified D Col 2a dim(3) D Ptr1 s * inz(%addr(top1)) D FaceSave ds dim(6) likeds(Face) // 3d structure for cube face attributes D Attr ds dim(6) qualified based(Ptr2) D Row likeds(Rowb) dim(3) D Rowb ds qualified D Col 1a dim(3) D Ptr2 s * inz(%addr(Attrt1)) D AttrSave ds dim(6) likeds(Attr) // 2d structure for showing different views of cube D ViewFace ds dim(3) qualified based(Ptr3) D Col 2a dim(3) D Ptr3 s * inz(%addr(view1)) D ViewAttr ds dim(3) qualified based(Ptr4) D Col 1a dim(3) D Ptr4 s * inz(%addr(Attrv1)) //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetRandom /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- // get co-ordinates for different math planes D altp PR 3u 0 D 3u 0 const //--*DATA STRUCTURES--------------------------------------- // map screen fields into DS so pointers to data can overlay D screenDS ds // TOP Attributes D AttrT1 D AttrT2 D AttrT3 D AttrT4 D AttrT5 D AttrT6 D AttrT7 D AttrT8 D AttrT9 // BOTTOM Attributes D AttrB1 D AttrB2 D AttrB3 D AttrB4 D AttrB5 D AttrB6 D AttrB7 D AttrB8 D AttrB9 // FRONT Attributes D AttrF1 D AttrF2 D AttrF3 D AttrF4 D AttrF5 D AttrF6 D AttrF7 D AttrF8 D AttrF9 // RIGHT Attributes D AttrR1 D AttrR2 D AttrR3 D AttrR4 D AttrR5 D AttrR6 D AttrR7 D AttrR8 D AttrR9 // AFT Attributes D AttrA1 D AttrA2 D AttrA3 D AttrA4 D AttrA5 D AttrA6 D AttrA7 D AttrA8 D AttrA9 // LEFT Attributes D AttrL1 D AttrL2 D AttrL3 D AttrL4 D AttrL5 D AttrL6 D AttrL7 D AttrL8 D AttrL9 // VIEW Attributes D AttrV1 D AttrV2 D AttrV3 D AttrV4 D AttrV5 D AttrV6 D AttrV7 D AttrV8 D AttrV9 D TOP1 D TOP2 D TOP3 D TOP4 D TOP5 D TOP6 D TOP7 D TOP8 D TOP9 D BOT1 D BOT2 D BOT3 D BOT4 D BOT5 D BOT6 D BOT7 D BOT8 D BOT9 D FRONT1 D FRONT2 D FRONT3 D FRONT4 D FRONT5 D FRONT6 D FRONT7 D FRONT8 D FRONT9 D RIGHT1 D RIGHT2 D RIGHT3 D RIGHT4 D RIGHT5 D RIGHT6 D RIGHT7 D RIGHT8 D RIGHT9 D AFT1 D AFT2 D AFT3 D AFT4 D AFT5 D AFT6 D AFT7 D AFT8 D AFT9 D LEFT1 D LEFT2 D LEFT3 D LEFT4 D LEFT5 D LEFT6 D LEFT7 D LEFT8 D LEFT9 D VIEW1 D VIEW2 D VIEW3 D VIEW4 D VIEW5 D VIEW6 D VIEW7 D VIEW8 D VIEW9 //--*ENTRY PARMS *NONE* ----------------------------------- /free exsr srNewStart; 1b dou 1 = 2; exfmt SCREEN; 2b if InfdsFkey = f20; exsr srNewStart; 3b if randmoves > 0; exsr srRandomCube; 3e endif; 2x elseif InfdsFkey = f12; 1v leave; // user selected to change view in work area. 2x elseif InfdsFkey = f09; //F9 FRONT avTop = Blue; avLeft = Blue; avFront = %bitor(White:UL); SelectView = 3; exsr srLoadView; 2x elseif InfdsFkey = f10; //F10 TOP avFront = Blue; avLeft = Blue; avTop = %bitor(White:UL); SelectView = 1; exsr srLoadView; 2x elseif InfdsFkey = f11; //F11 LEFT avFront = Blue; avTop = Blue; avLeft = %bitor(White:UL); SelectView = 6; exsr srLoadView; //--------------------------------------------------------- // user selected to rotate cube. // Each command key represents different direction. 2x elseif InfdsFkey = f01 or InfdsFkey = f02 or InfdsFkey = f03 or InfdsFkey = f04 or InfdsFkey = f05 or InfdsFkey = f06 or InfdsFkey = f13 or InfdsFkey = f14 or InfdsFkey = f15 or InfdsFkey = f16 or InfdsFkey = f17 or InfdsFkey = f18; TwistCount += 1; 3b if InfdsFkey = f13; yy = 1; 3x elseif InfdsFkey = f14; yy = 2; 3x elseif InfdsFkey = f15; yy = 3; 3x elseif InfdsFkey = f16; yy = 4; 3x elseif InfdsFkey = f17; yy = 5; 3x elseif InfdsFkey = f18; yy = 6; 3x elseif InfdsFkey = f03; yy = 7; 3x elseif InfdsFkey = f02; yy = 8; 3x elseif InfdsFkey = f01; yy = 9; 3x elseif InfdsFkey = f06; yy = 10; 3x elseif InfdsFkey = f05; yy = 11; 3x elseif InfdsFkey = f04; yy = 12; 3e endif; exsr srRotateCube; exsr srLoadView; 2e endif; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // now the fun begins. At this point user has selected view and rotation direction. // There are 6 faces, 6 Row/Col, and 12 possible directions to roll. Hmmmmm. begsr srRotateCube; AttrSave = Attr; FaceSave = Face; //--------------------------------------------------------- // rotating up or down will cross a plane. // Front, top and bottom are in same plane ( x,1,1 will always go to y,1,1) . // Back has already been defined as being in same plan as sides, so I // have to do some mapping from top to back and back to bottom. // if yy=1 spin left face 1/4 turn, if yy=3 spin right face 1/4 turn 1b if (SelectView = 1 //TOP or SelectView = 3) and //FRONT (yy = 1 or yy = 2 or yy = 3); 2b if yy = 1; cc = 1; ss = 6; //rotate left side 2x elseif yy = 2; cc = 2; 2x elseif yy = 3; cc = 3; ss = 4; //rotate right side 2e endif; 2b for xx = 1 to 3; //Front to Top Face(1).Row(xx).Col(cc) = FaceSave(3).Row(xx).Col(cc); Attr(1).Row(xx).Col(cc) = AttrSave(3).Row(xx).Col(cc); //Bottom to Front Face(3).Row(xx).Col(cc) = FaceSave(2).Row(xx).Col(cc); Attr(3).Row(xx).Col(cc) = AttrSave(2).Row(xx).Col(cc); //Top to Rear Face(5).Row(altp(xx)).Col(altp(cc)) = FaceSave(1).Row(xx).Col(cc); Attr(5).Row(altp(xx)).Col(altp(cc)) = AttrSave(1).Row(xx).Col(cc); //Rear to Bottom Face(2).Row(xx).Col(cc) = FaceSave(5).Row(altp(xx)).Col(altp(cc)); Attr(2).Row(xx).Col(cc) = AttrSave(5).Row(altp(xx)).Col(altp(cc)); // Rotate left side counter clockwise or right side clockwise 3b if cc = 1; exsr srRotateCCW; //counter clockwise 3x elseif cc = 3; exsr srRotateCW; //clockwise 3e endif; 2e endfor; //--------------------------------------------------------- // TOP AND FRONT if use selects to rotate downward, // same as above just in other direction 1x elseif (SelectView = 1 //TOP or SelectView = 3) and //FRONT (yy = 7 or yy = 8 or yy = 9); 2b if yy = 9; cc = 1; ss = 6; //rotate left side 2x elseif yy = 8; cc = 2; 2x elseif yy = 7; cc = 3; ss = 4; //rotate right side 2e endif; 2b for xx = 1 to 3; // Top to Front Face(3).Row(xx).Col(cc) = FaceSave(1).Row(xx).Col(cc); Attr(3).Row(xx).Col(cc) = AttrSave(1).Row(xx).Col(cc); //Front to bottom Face(2).Row(xx).Col(cc) = FaceSave(3).Row(xx).Col(cc); Attr(2).Row(xx).Col(cc) = AttrSave(3).Row(xx).Col(cc); //Rear To Top Face(1).Row(altp(xx)).Col(cc) = FaceSave(5).Row(xx).Col(altp(cc)); Attr(1).Row(altp(xx)).Col(cc) = AttrSave(5).Row(xx).Col(altp(cc)); //Bottom to Rear Face(5).Row(altp(xx)).Col(altp(cc)) = FaceSave(2).Row(xx).Col(cc); Attr(5).Row(altp(xx)).Col(altp(cc)) = AttrSave(2).Row(xx).Col(cc); // Rotate left side clockwise or right side counter clockwise 3b if cc = 1; exsr srRotateCW; //clockwise 3x elseif cc = 3; exsr srRotateCCW; //counter clockwise 3e endif; 2e endfor; //--------------------------------------------------------- // rotating right goes to same coordinates on next face. // In other words x,1,1 will always go to y,1,1. // if yy=1 spin top face 1/4 turn, // if yy=3 spin bottom face 1/4 turn 1x elseif (SelectView = 3 or //TOP SelectView = 6) and //FRONT (yy = 4 or yy = 5 or yy = 6); 2b if yy = 4; rr = 1; ss = 1; //rotate top side 2x elseif yy = 5; rr = 2; 2x elseif yy = 6; rr = 3; ss = 2; //rotate bottom side 2e endif; 2b for xx = 1 to 3; //Front to right Face(4).Row(rr).Col(xx) = FaceSave(3).Row(rr).Col(xx); Attr(4).Row(rr).Col(xx) = AttrSave(3).Row(rr).Col(xx); //Right to Rear Face(5).Row(rr).Col(xx) = FaceSave(4).Row(rr).Col(xx); Attr(5).Row(rr).Col(xx) = AttrSave(4).Row(rr).Col(xx); //Rear to left Face(6).Row(rr).Col(xx) = FaceSave(5).Row(rr).Col(xx); Attr(6).Row(rr).Col(xx) = AttrSave(5).Row(rr).Col(xx); //Left to Front Face(3).Row(rr).Col(xx) = FaceSave(6).Row(rr).Col(xx); Attr(3).Row(rr).Col(xx) = AttrSave(6).Row(rr).Col(xx); // Rotate bottom side clockwise or top side counter clockwise 3b if rr = 3; exsr srRotateCW; //clockwise 3x elseif rr = 1; exsr srRotateCCW; //counter clockwise 3e endif; 2e endfor; //--------------------------------------------------------- // FRONT AND LEFT if use selects to rotate left 1x elseif (SelectView = 3 or //TOP SelectView = 6) and //FRONT (yy = 10 or yy = 11 or yy = 12); 2b if yy = 12; rr = 1; ss = 1; //rotate left side 2x elseif yy = 11; rr = 2; 2x elseif yy = 10; rr = 3; ss = 2; //rotate right side 2e endif; 2b for xx = 1 to 3; //Right to Front Face(3).Row(rr).Col(xx) = FaceSave(4).Row(rr).Col(xx); Attr(3).Row(rr).Col(xx) = AttrSave(4).Row(rr).Col(xx); //Rear to Right Face(4).Row(rr).Col(xx) = FaceSave(5).Row(rr).Col(xx); Attr(4).Row(rr).Col(xx) = AttrSave(5).Row(rr).Col(xx); //Left to rear Face(5).Row(rr).Col(xx) = FaceSave(6).Row(rr).Col(xx); Attr(5).Row(rr).Col(xx) = AttrSave(6).Row(rr).Col(xx); //Front to Left Face(6).Row(rr).Col(xx) = FaceSave(3).Row(rr).Col(xx); Attr(6).Row(rr).Col(xx) = AttrSave(3).Row(rr).Col(xx); // Rotate bottom side counter clockwise or top side clockwise 3b if rr = 1; exsr srRotateCW; //clockwise 3x elseif rr = 3; exsr srRotateCCW; //counter clockwise 3e endif; 2e endfor; //--------------------------------------------------------- // VIEWING FROM LEFT>> way different // rotating up or down goes to different coordinates on next face // The deal is you are rotating into a different plane. // I am going to design function ALTP for diff plane mappings. // if yy=1 spin back face 1/4 turn, if yy = 3 spin front face 1/4 turn 1x elseif (SelectView = 6 and //Left (yy = 1 or yy = 2 or yy = 3)) or (SelectView = 1 and //top (yy = 4 or yy = 5 or yy = 6)); 2b if yy = 1 or yy = 4; rr = 1; ss = 5; //rotate rear 2x elseif yy = 2 or yy = 5; rr = 2; 2x elseif yy = 3 or yy = 6; rr = 3; ss = 3; //rotate front 2e endif; 2b for xx = 1 to 3; //Left To Top Face(1).Row(rr).Col(altp(xx)) = FaceSave(6).Row(xx).Col(rr); Attr(1).Row(rr).Col(altp(xx)) = AttrSave(6).Row(xx).Col(rr); //Top to Right Face(4).Row(xx).Col(altp(rr)) = FaceSave(1).Row(rr).Col(xx); Attr(4).Row(xx).Col(altp(rr)) = AttrSave(1).Row(rr).Col(xx); //Right To Bottom Face(2).Row(altp(rr)).Col(altp(xx)) = FaceSave(4).Row(xx).Col(altp(rr)); Attr(2).Row(altp(rr)).Col(altp(xx)) = AttrSave(4).Row(xx).Col(altp(rr)); //Bottom to Left Face(6).Row(altp(xx)).Col(rr) = FaceSave(2).Row(altp(rr)).Col(altp(xx)); Attr(6).Row(altp(xx)).Col(rr) = AttrSave(2).Row(altp(rr)).Col(altp(xx)); // Rotate rear side counter clockwise or front side clockwise 3b if rr = 3; exsr srRotateCW; 3x elseif rr = 1; exsr srRotateCCW; 3e endif; 2e endfor; //--------------------------------------------------------- // LEFT if user selects to rotate downward. 1x elseif (SelectView = 6 and // left side (yy = 7 or yy = 8 or yy = 9)) or (SelectView = 1 and // top (yy = 10 or yy = 11 or yy = 12)); 2b if yy = 9 or yy = 12; rr = 1; ss = 5; //rotate back 2x elseif yy = 8 or yy = 11; rr = 2; 2x elseif yy = 7 or yy = 10; rr = 3; ss = 3; 2e endif; 2b for xx = 1 to 3; //top to left Face(6).Row(altp(xx)).Col(rr) = FaceSave(1).Row(rr).Col(xx); Attr(6).Row(altp(xx)).Col(rr) = AttrSave(1).Row(rr).Col(xx); //bottom to right Face(4).Row(altp(xx)).Col(altp(rr)) = FaceSave(2).Row(altp(rr)).Col(xx); Attr(4).Row(altp(xx)).Col(altp(rr)) = AttrSave(2).Row(altp(rr)).Col(xx); //right to top Face(1).Row(rr).Col(xx) = FaceSave(4).Row(xx).Col(altp(rr)); Attr(1).Row(rr).Col(xx) = AttrSave(4).Row(xx).Col(altp(rr)); //left to bottom Face(2).Row(altp(rr)).Col(xx) = FaceSave(6).Row(xx).Col(rr); Attr(2).Row(altp(rr)).Col(xx) = AttrSave(6).Row(xx).Col(rr); // Rotate rear side clockwise or front side counter clockwise 3b if rr = 1; exsr srRotateCW; 3x elseif rr = 3; exsr srRotateCCW; 3e endif; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // Load user selected view to work area begsr srLoadView; 1b for Row = 1 to 3; ViewFace(Row).Col(*) = Face(SelectView).Row(Row).Col(*); ViewAttr(Row).Col(*) = Attr(SelectView).Row(Row).Col(*); 1e endfor; endsr; //--------------------------------------------------------- // Rotate face clockwise. begsr srRotateCW; Face(ss).Row(xx).Col(1) = FaceSave(ss).Row(3).Col(xx); Attr(ss).Row(xx).Col(1) = AttrSave(ss).Row(3).Col(xx); Face(ss).Row(xx).Col(2) = FaceSave(ss).Row(2).Col(xx); Attr(ss).Row(xx).Col(2) = AttrSave(ss).Row(2).Col(xx); Face(ss).Row(xx).Col(3) = FaceSave(ss).Row(1).Col(xx); Attr(ss).Row(xx).Col(3) = AttrSave(ss).Row(1).Col(xx); endsr; //--------------------------------------------------------- // Rotate face counter clockwise begsr srRotateCCW; Face(ss).Row(1).Col(xx) = FaceSave(ss).Row(xx).Col(3); Attr(ss).Row(1).Col(xx) = AttrSave(ss).Row(xx).Col(3); Face(ss).Row(2).Col(xx) = FaceSave(ss).Row(xx).Col(2); Attr(ss).Row(2).Col(xx) = AttrSave(ss).Row(xx).Col(2); Face(ss).Row(3).Col(xx) = FaceSave(ss).Row(xx).Col(1); Attr(ss).Row(3).Col(xx) = AttrSave(ss).Row(xx).Col(1); endsr; //--------------------------------------------------------- // Reload cube to beginning state. begsr srNewStart; avFront = Blue; avTop = Blue; avLeft = Blue; evalr scDow = %trimr(f_GetDayName()); TwistCount = 0; 1b for side = 1 to 6; 2b for Row = 1 to 3; 3b for Col = 1 to 3; AlphaRow = %char(Row); AlphaCol = %char(Col); Face(side).Row(Row).Col(Col) = AlphaRow + AlphaCol; 4b if side = 1; //top Attr(side).Row(Row).Col(Col) = %bitor(BLUE: RI); 4x elseif side = 2; //bottom Attr(side).Row(Row).Col(Col) = %bitor(WHITE: RI); 4x elseif side = 3; //front Attr(side).Row(Row).Col(Col) = %bitor(RED: RI); 4x elseif side = 4; //right Attr(side).Row(Row).Col(Col) = %bitor(GREEN: RI); 4x elseif side = 5; //aft Attr(side).Row(Row).Col(Col) = %bitor(PINK: RI); 4x elseif side = 6; //left Attr(side).Row(Row).Col(Col) = %bitor(YELLOW: RI); 4e endif; 3e endfor; 2e endfor; 1e endfor; SelectView = 3; exsr srLoadView; avFront = %bitor(White:UL); endsr; //--------------------------------------------------------- // make number of random moves specified by user. // Program will call random routine twice for each number of moves selected. // First call will select random face, second call will select random slice and direction begsr srRandomCube; 1b for ForCount = 1 to RandMoves; yy = f_GetRandom(12); SelectView = f_GetRandom(3); // Note: three views that can be selected are 1=top, 3=front and 6=left side. // Random view is coming back as 1 or 2 or 3. need to map 2 to 6 view. // Always leave user view as front. 2b if SelectView = 2; SelectView = 6; 2e endif; exsr srRotateCube; SelectView = 3; exsr srLoadView; write screen; 1e endfor; endsr; /end-free //--------------------------------------------------------- // convert X from one math plane to alternate plane Paltp B D PI 3u 0 D p_Index 3u 0 const /free 1b if p_Index = 1; return 3; 1x elseif p_Index = 3; return 1; 1e endif; return 2; /end-free Paltp E ]]> v5r4 *---------------------------------------------------------------- * JCRGMRCBD - Rubicks Cube - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA11 CF20 CA12 A CA01 CA02 CA03 CA04 CA05 CA06 CA13 A CA14 CA15 CA16 CA17 CA18 CA09 CA10 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN FRCDTA A ATTRT1 1A P TEXT('TOP ATTRIBUTES') A ATTRT2 1A P A ATTRT3 1A P A ATTRT4 1A P A ATTRT5 1A P A ATTRT6 1A P A ATTRT7 1A P A ATTRT8 1A P A ATTRT9 1A P A ATTRB1 1A P TEXT('BOTTOM ATTRIBUTES') A ATTRB2 1A P A ATTRB3 1A P A ATTRB4 1A P A ATTRB5 1A P A ATTRB6 1A P A ATTRB7 1A P A ATTRB8 1A P A ATTRB9 1A P A ATTRF1 1A P TEXT('FRONT ATTRIBUTES') A ATTRF2 1A P A ATTRF3 1A P A ATTRF4 1A P A ATTRF5 1A P A ATTRF6 1A P A ATTRF7 1A P A ATTRF8 1A P A ATTRF9 1A P A ATTRR1 1A P TEXT('RIGHT ATTRIBUTES') A ATTRR2 1A P A ATTRR3 1A P A ATTRR4 1A P A ATTRR5 1A P A ATTRR6 1A P A ATTRR7 1A P A ATTRR8 1A P A ATTRR9 1A P A ATTRA1 1A P TEXT('AFT ATTRIBUTES') A ATTRA2 1A P A ATTRA3 1A P A ATTRA4 1A P A ATTRA5 1A P A ATTRA6 1A P A ATTRA7 1A P A ATTRA8 1A P A ATTRA9 1A P A ATTRL1 1A P TEXT('LEFT ATTRIBUTES') A ATTRL2 1A P A ATTRL3 1A P A ATTRL4 1A P A ATTRL5 1A P A ATTRL6 1A P A ATTRL7 1A P A ATTRL8 1A P A ATTRL9 1A P A ATTRV1 1A P TEXT('VIEW ATTRIBUTES') A ATTRV2 1A P A ATTRV3 1A P A ATTRV4 1A P A ATTRV5 1A P A ATTRV6 1A P A ATTRV7 1A P A ATTRV8 1A P A ATTRV9 1A P A AVFRONT 1A P A AVTOP 1A P A AVLEFT 1A P A 1 3'JCRGMRCB' COLOR(BLU) A 1 14'RUBICKS CUBE' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 20'Top' COLOR(BLU) A 3 53'|' COLOR(BLU) A 3 56'Select number of times' A TOP1 2A O 4 18DSPATR(&ATTRT1) A TOP2 2A O 4 21DSPATR(&ATTRT2) A TOP3 2A O 4 24DSPATR(&ATTRT3) A 4 53'|' COLOR(BLU) A 4 56'for the computer to make' A COLOR(BLU) A TOP4 2A O 5 18DSPATR(&ATTRT4) A TOP5 2A O 5 21DSPATR(&ATTRT5) A TOP6 2A O 5 24DSPATR(&ATTRT6) A AFT1 2A O 5 39DSPATR(&ATTRA1) A AFT2 2A O 5 42DSPATR(&ATTRA2) A AFT3 2A O 5 45DSPATR(&ATTRA3) A 5 53'|'COLOR(BLU) A 5 56'random twists.' COLOR(BLU) A 5 71'Press F20' COLOR(BLU) A TOP7 2A O 6 18DSPATR(&ATTRT7) A TOP8 2A O 6 21DSPATR(&ATTRT8) A TOP9 2A O 6 24DSPATR(&ATTRT9) A AFT4 2A O 6 39DSPATR(&ATTRA4) A AFT5 2A O 6 42DSPATR(&ATTRA5) A AFT6 2A O 6 45DSPATR(&ATTRA6) A 6 53'|' COLOR(BLU) A AFT7 2A O 7 39DSPATR(&ATTRA7) A AFT8 2A O 7 42DSPATR(&ATTRA8) A AFT9 2A O 7 45DSPATR(&ATTRA9) A 7 53'|' COLOR(BLU) A 7 56'The computer always' COLOR(BLU) A LEFT1 2A O 8 7DSPATR(&ATTRL1) A LEFT2 2A O 8 10DSPATR(&ATTRL2) A LEFT3 2A O 8 13DSPATR(&ATTRL3) A FRONT1 2A O 8 18DSPATR(&ATTRF1) A FRONT2 2A O 8 21DSPATR(&ATTRF2) A FRONT3 2A O 8 24DSPATR(&ATTRF3) A RIGHT1 2A O 8 29DSPATR(&ATTRR1) A RIGHT2 2A O 8 32DSPATR(&ATTRR2) A RIGHT3 2A O 8 35DSPATR(&ATTRR3) A 8 41'Rear' COLOR(PNK) A 8 53'|' COLOR(BLU) A 8 56'starts from a solved' COLOR(BLU) A LEFT4 2A O 9 7DSPATR(&ATTRL4) A LEFT5 2A O 9 10DSPATR(&ATTRL5) A LEFT6 2A O 9 13DSPATR(&ATTRL6) A FRONT4 2A O 9 18DSPATR(&ATTRF4) A FRONT5 2A O 9 21DSPATR(&ATTRF5) A FRONT6 2A O 9 24DSPATR(&ATTRF6) A RIGHT4 2A O 9 29DSPATR(&ATTRR4) A RIGHT5 2A O 9 32DSPATR(&ATTRR5) A RIGHT6 2A O 9 35DSPATR(&ATTRR6) A 9 53'|' COLOR(BLU) A 9 56'cube.' COLOR(BLU) A LEFT7 2A O 10 7DSPATR(&ATTRL7) A LEFT8 2A O 10 10DSPATR(&ATTRL8) A LEFT9 2A O 10 13DSPATR(&ATTRL9) A FRONT7 2A O 10 18DSPATR(&ATTRF7) A FRONT8 2A O 10 21DSPATR(&ATTRF8) A FRONT9 2A O 10 24DSPATR(&ATTRF9) A RIGHT7 2A O 10 29DSPATR(&ATTRR7) A RIGHT8 2A O 10 32DSPATR(&ATTRR8) A RIGHT9 2A O 10 35DSPATR(&ATTRR9) A 10 53'|' COLOR(BLU) A 11 8'Left' COLOR(YLW) A 11 19'Front' COLOR(RED) A 11 30'Right' COLOR(GRN) A 11 53'|' COLOR(BLU) A 11 56'Select 0 if you wish' COLOR(BLU) A BOT1 2A O 12 18DSPATR(&ATTRB1) A BOT2 2A O 12 21DSPATR(&ATTRB2) A BOT3 2A O 12 24DSPATR(&ATTRB3) A 12 53'|' COLOR(BLU) A 12 56'to start with a solved' A COLOR(BLU) A BOT4 2A O 13 18DSPATR(&ATTRB4) A BOT5 2A O 13 21DSPATR(&ATTRB5) A BOT6 2A O 13 24DSPATR(&ATTRB6) A 13 53'|' COLOR(BLU) A 13 56'cube.' COLOR(BLU) A BOT7 2A O 14 18DSPATR(&ATTRB7) A BOT8 2A O 14 21DSPATR(&ATTRB8) A BOT9 2A O 14 24DSPATR(&ATTRB9) A 14 53'|' COLOR(BLU) A 15 19'Bottom' COLOR(WHT) A 15 53'|' COLOR(BLU) A 15 56'Press Cmd Keys to select' A COLOR(BLU) A 16 2' - A ' A COLOR(BLU) DSPATR(UL) A 16 53'|' COLOR(BLU) A 16 56'view of cube or slice' COLOR(BLU) A 17 2'F9 =Front' DSPATR(&AVFRONT) A 17 17'f13' COLOR(BLU) A 17 21'14' COLOR(BLU) A 17 24'15' COLOR(BLU) A 17 53'|' COLOR(BLU) A 17 56'and rotation direction.' A COLOR(BLU) A 18 2'F10=Top' DSPATR(&AVTOP) A 18 15'f4' COLOR(BLU) A VIEW1 2A O 18 18DSPATR(&ATTRV1) A VIEW2 2A O 18 21DSPATR(&ATTRV2) A VIEW3 2A O 18 24DSPATR(&ATTRV3) A 18 27'f16' COLOR(BLU) A 18 53'|' COLOR(BLU) A 19 2'F11=Left' DSPATR(&AVLEFT) A 19 15'f5' COLOR(BLU) A VIEW4 2A O 19 18DSPATR(&ATTRV4) A VIEW5 2A O 19 21DSPATR(&ATTRV5) A VIEW6 2A O 19 24DSPATR(&ATTRV6) A 19 27'f17' COLOR(BLU) A 19 53'|' COLOR(BLU) A 20 15'f6' COLOR(BLU) A VIEW7 2A O 20 18DSPATR(&ATTRV7) A VIEW8 2A O 20 21DSPATR(&ATTRV8) A VIEW9 2A O 20 24DSPATR(&ATTRV9) A 20 27'f18' COLOR(BLU) A 20 53'|' COLOR(BLU) A 20 56'Twist Count' COLOR(BLU) A TWISTCOUNT 3S 0O 20 68COLOR(BLU) A 21 18'f1' COLOR(BLU) A 21 21'f2' COLOR(BLU) A 21 24'f3' COLOR(BLU) A 24 3'F12=Exit' COLOR(BLU) A 24 36'F20=Make' COLOR(BLU) A RANDMOVES 2Y 0B 24 45EDTCDE(4) COLOR(BLU) A 24 48'random twists to begin game.' A COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRGMTIC - TicTacToe //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMTICD cf e workstn Infds(Infds) //--*STAND ALONE------------------------------------------- D CheckXO s 1a D Row s 3u 0 D Col s 3u 0 D IsFirstMove s n D IsPlaced s n D IsWinner s n //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetRandom /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_FillGrid PR 9a dim(5) D 1a const //--*DATA STRUCTURES--------------------------------------- // define two-dim array to control attributes of selection field D ProtectA ds dim(3) qualified based(ProtectPtr) D Col 1a dim(3) D ProtectPtr s * inz(%addr(ProtectDS)) // define two-dim array to hold selection grid D Choice ds dim(3) likeds(ProtectA) based(SelPtr) D SelPtr s * inz(%addr(SelectionDS)) // map screen fields into DS D SelectionDS ds inz D Row1 3a D r1c1 overlay(Row1:1) D r1c2 overlay(Row1:*next) D r1c3 overlay(Row1:*next) D Row2 3a D r2c1 overlay(Row2:1) D r2c2 overlay(Row2:*next) D r2c3 overlay(Row2:*next) D Row3 3a D r3c1 overlay(Row3:1) D r3c2 overlay(Row3:*next) D r3c3 overlay(Row3:*next) D ProtectDS ds D ProcAtr11 D ProcAtr12 D ProcAtr13 D ProcAtr21 D ProcAtr22 D ProcAtr23 D ProcAtr31 D ProcAtr32 D ProcAtr33 D DspDS ds D Grid11_L1 D Grid11_L2 D Grid11_L3 D Grid11_L4 D Grid11_L5 D Grid12_L1 D Grid12_L2 D Grid12_L3 D Grid12_L4 D Grid12_L5 D Grid13_L1 D Grid13_L2 D Grid13_L3 D Grid13_L4 D Grid13_L5 D Grid21_L1 D Grid21_L2 D Grid21_L3 D Grid21_L4 D Grid21_L5 D Grid22_L1 D Grid22_L2 D Grid22_L3 D Grid22_L4 D Grid22_L5 D Grid23_L1 D Grid23_L2 D Grid23_L3 D Grid23_L4 D Grid23_L5 D Grid31_L1 D Grid31_L2 D Grid31_L3 D Grid31_L4 D Grid31_L5 D Grid32_L1 D Grid32_L2 D Grid32_L3 D Grid32_L4 D Grid32_L5 D Grid33_L1 D Grid33_L2 D Grid33_L3 D Grid33_L4 D Grid33_L5 D ATRDS ds D atr11 D atr12 D atr13 D atr21 D atr22 D atr23 D atr31 D atr32 D atr33 // Define 3D array for row, column, then 5 lines D DspRow ds dim(3) qualified based(DspPtr) D DspCol likeds(DspColx) dim(3) D DspColx ds qualified D DspLine 9a dim(5) D DspPtr s * inz(%addr(DspDs)) D AtrRow ds dim(3) qualified based(AtrPtr) D AtrCol 1a dim(3) D AtrPtr s * inz(%addr(AtrDs)) //--*ENTRY PARMS *NONE* ----------------------------------- /free evalr scDow = %trimr(f_GetDayName()); // Load TIC TAC TOE in variety of colors to starting screen DspRow(1).DspCol(1).DspLine = f_FillGrid('T'); DspRow(1).DspCol(2).DspLine = f_FillGrid('I'); DspRow(1).DspCol(3).DspLine = f_FillGrid('C'); DspRow(2).DspCol(1).DspLine = f_FillGrid('T'); DspRow(2).DspCol(2).DspLine = f_FillGrid('A'); DspRow(2).DspCol(3).DspLine = f_FillGrid('C'); DspRow(3).DspCol(1).DspLine = f_FillGrid('T'); DspRow(3).DspCol(2).DspLine = f_FillGrid('O'); DspRow(3).DspCol(3).DspLine = f_FillGrid('E'); AtrRow(1).AtrCol(1) = Yellow; AtrRow(1).AtrCol(2) = White; AtrRow(1).AtrCol(3) = Red; AtrRow(2).AtrCol(1) = Turq; AtrRow(2).AtrCol(2) = Green; AtrRow(2).AtrCol(3) = Pink; AtrRow(3).AtrCol(1) = White; AtrRow(3).AtrCol(2) = Red; AtrRow(3).AtrCol(3) = Blue; 1b for Row = 1 to 3; ProtectA(Row).Col(*) = %bitor(ND: PR); 1e endfor; aWelcome = White; // welcome message aStart = ND; // game start message aNotes = ND; // Game note exfmt SCREEN; 1b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 1e endif; DspRow(*) = *blanks; AtrRow(*) = *blanks; 1b for Row = 1 to 3; ProtectA(Row).Col(*) = %bitor(Green: UL); 1e endfor; aWelcome = ND; aStart = Pink; aNotes = Blue; //--------------------------------------------------------- 1b dou 1 = 2; exfmt SCREEN; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; 2b if InfdsFkey = f09; Choice(*) = *blanks; DspRow(*) = *blanks; AtrRow(*) = *blanks; IsWinner = *off; IsFirstMove = *off; exsr srLoadCharacter; 3b for Row = 1 to 3; ProtectA(Row).Col(*) = %bitor(Green: UL); 3e endfor; aStart = Pink; aNotes = ND; 1i iter; 2e endif; aStart = ND; aNotes = ND; //--------------------------------------------------------- // If this is first move and center square is not 'X' then load 'O' to center // square. If first move and center square is 'X' then load 'O' into random square. 2b if not IsFirstMove; 3b if Choice(2).Col(2) = ' '; Choice(2).Col(2) = 'O'; 3x else; 4b dou not (Row = 2 and Col = 2); //not in center Row = f_GetRandom(3); Col = f_GetRandom(3); 4e enddo; Choice(Row).Col(Col) = 'O'; 3e endif; IsFirstMove = *on; exsr srLoadCharacter; 2x else; // Check to see of x won exsr srLoadCharacter; exsr srCheckWinner; 3b if IsWinner; 1i iter; 3e endif; //--------------------------------------------------------- // See if any single O will block X from win or if single O will win. exsr srBlockOrWin; //Block that win! exsr srLoadCharacter; exsr srCheckWinner; 3b if IsWinner; 1i iter; 3e endif; // If no Block or Win assignment was made, then some strategy comes into play. 3b if not IsPlaced; exsr srStrategy; //--------------------------------------------------------- // If no spaces where available for a strategy move, ie game is going to tie and // there are only few spaces left, then fill in first available space. 4b if not IsPlaced; exsr srPutAnywhereO; 4e endif; exsr srLoadCharacter; 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- // Protect selections from change. begsr srLoadCharacter; 1b for Row = 1 to 3; 2b for Col = 1 to 3; 3b if Choice(Row).Col(Col) = 'X'; DspRow(Row).DspCol(Col).DspLine = f_FillGrid('X'); AtrRow(Row).AtrCol(Col) = Pink; ProtectA(Row).Col(Col) = %bitor(ND: PR); 3x elseif Choice(Row).Col(Col) = 'O'; DspRow(Row).DspCol(Col).DspLine = f_FillGrid('O'); AtrRow(Row).AtrCol(Col) = White; ProtectA(Row).Col(Col) = %bitor(ND: PR); 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // Good for Offense or Defense! First spin through all 24 possible // places that a single O could win game. If I can't find clear game winner // then make sure I block any scenarios where single X could win game. begsr srBlockOrWin; 1b for Col = 1 to 2; 2b if Col = 1; CheckXO = 'O'; 2x else; CheckXO = 'X'; 2e endif; IsPlaced = *off; 2b for Row = 1 to 3; // Row123---------------------------------------- 3b if Choice(Row).Col(1) = CheckXO and Choice(Row).Col(1) = Choice(Row).Col(2) and // XX_ or OO_ Choice(Row).Col(3) = ' '; Choice(Row).Col(3) = 'O'; IsPlaced = *on; 3x elseif Choice(Row).Col(1) = CheckXO and Choice(Row).Col(1) = Choice(Row).Col(3) and // X_X or O_O Choice(Row).Col(2) = ' '; Choice(Row).Col(2) = 'O'; IsPlaced = *on; 3x elseif Choice(Row).Col(2) = CheckXO and Choice(Row).Col(2) = Choice(Row).Col(3) and // _XX or _OO Choice(Row).Col(1) = ' '; Choice(Row).Col(1) = 'O'; IsPlaced = *on; // Col123--------------------------------------- 3x elseif Choice(1).Col(Row) = CheckXO and Choice(1).Col(Row) = Choice(2).Col(Row) and // XX_ or OO_ Choice(3).Col(Row) = ' '; Choice(3).Col(Row) = 'O'; IsPlaced = *on; 3x elseif Choice(1).Col(Row) = CheckXO and Choice(1).Col(Row) = Choice(3).Col(Row) and // X_X or O_O Choice(2).Col(Row) = ' '; Choice(2).Col(Row) = 'O'; IsPlaced = *on; 3x elseif Choice(2).Col(Row) = CheckXO and Choice(2).Col(Row) = Choice(3).Col(Row) and // _XX or _OO Choice(1).Col(Row) = ' '; Choice(1).Col(Row) = 'O'; IsPlaced = *on; 3e endif; 3b if IsPlaced; 2v leave; 3e endif; 2e endfor; 2b if not IsPlaced; // DIAGR 1,1 2,2 3,3 ----------------------- 3b if Choice(1).Col(1) = CheckXO and Choice(1).Col(1) = Choice(2).Col(2) and //XX_ or OO_ Choice(3).Col(3) = ' '; Choice(3).Col(3) = 'O'; IsPlaced = *on; 3x elseif Choice(2).Col(2) = ' ' and Choice(1).Col(1) = Choice(3).Col(3) and Choice(1).Col(1) = CheckXO; Choice(2).Col(2) = 'O'; IsPlaced = *on; 3x elseif Choice(1).Col(1) = ' ' and Choice(2).Col(2) = Choice(3).Col(3) and Choice(2).Col(2) = CheckXO; Choice(1).Col(1) = 'O'; IsPlaced = *on; // DIAGL 1,3 2,2 3,1 --------------------- 3x elseif Choice(1).Col(3) = CheckXO and Choice(1).Col(3) = Choice(2).Col(2) and //XX_ or OO_ Choice(3).Col(1) = ' '; Choice(3).Col(1) = 'O'; IsPlaced = *on; 3x elseif Choice(2).Col(2) = ' ' and Choice(1).Col(3) = Choice(3).Col(1) and Choice(1).Col(3) = CheckXO; Choice(2).Col(2) = 'O'; IsPlaced = *on; 3x elseif Choice(1).Col(3) = ' ' and Choice(2).Col(2) = Choice(3).Col(1) and Choice(2).Col(2) = CheckXO; Choice(1).Col(3) = 'O'; IsPlaced = *on; 3e endif; 2e endif; 2b if IsPlaced; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Check to see if someone WON! // Process Rows 1 , 2 and 3 first. // then check Columns 1, 2 and 3 // then check left diagonal then right diagonal begsr srCheckWinner; IsWinner = *off; // Rows----------------------------------- 1b if Row1 = 'XXX' or Row1 = 'OOO'; IsWinner = *on; AtrRow(1).AtrCol(1) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(1).AtrCol(2) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(1).AtrCol(3) = %bitor(AtrRow(1).AtrCol(1):RI); 1x elseif Row2 = 'XXX' or Row2 = 'OOO'; IsWinner = *on; AtrRow(2).AtrCol(1) = %bitor(AtrRow(2).AtrCol(1):RI); AtrRow(2).AtrCol(2) = %bitor(AtrRow(2).AtrCol(1):RI); AtrRow(2).AtrCol(3) = %bitor(AtrRow(2).AtrCol(1):RI); 1x elseif Row3 = 'XXX' or Row3 = 'OOO'; IsWinner = *on; AtrRow(3).AtrCol(1) = %bitor(AtrRow(3).AtrCol(1):RI); AtrRow(3).AtrCol(2) = %bitor(AtrRow(3).AtrCol(1):RI); AtrRow(3).AtrCol(3) = %bitor(AtrRow(3).AtrCol(1):RI); // Columns----------------------------------- 1x elseif Choice(1).Col(1) > ' ' and Choice(1).Col(1) = Choice(2).Col(1) and Choice(2).Col(1) = Choice(3).Col(1); IsWinner = *on; AtrRow(1).AtrCol(1) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(2).AtrCol(1) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(3).AtrCol(1) = %bitor(AtrRow(1).AtrCol(1):RI); 1x elseif Choice(1).Col(2) > ' ' and Choice(1).Col(2) = Choice(2).Col(2) and Choice(2).Col(2) = Choice(3).Col(2); IsWinner = *on; AtrRow(1).AtrCol(2) = %bitor(AtrRow(1).AtrCol(2):RI); AtrRow(2).AtrCol(2) = %bitor(AtrRow(1).AtrCol(2):RI); AtrRow(3).AtrCol(2) = %bitor(AtrRow(1).AtrCol(2):RI); 1x elseif Choice(1).Col(3) > ' ' and Choice(1).Col(3) = Choice(2).Col(3) and Choice(1).Col(3) = Choice(3).Col(3); IsWinner = *on; AtrRow(1).AtrCol(3) = %bitor(AtrRow(1).AtrCol(3):RI); AtrRow(2).AtrCol(3) = %bitor(AtrRow(1).AtrCol(3):RI); AtrRow(3).AtrCol(3) = %bitor(AtrRow(1).AtrCol(3):RI); // Right Diagonal---------------------------------- 1x elseif Choice(1).Col(1) > ' ' and Choice(1).Col(1) = Choice(2).Col(2) and Choice(1).Col(1) = Choice(3).Col(3); IsWinner = *on; AtrRow(1).AtrCol(1) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(2).AtrCol(2) = %bitor(AtrRow(1).AtrCol(1):RI); AtrRow(3).AtrCol(3) = %bitor(AtrRow(1).AtrCol(1):RI); // Left Diagonal----------------------------------- 1x elseif Choice(1).Col(3) > ' ' and Choice(1).Col(3) = Choice(2).Col(2) and Choice(1).Col(3) = Choice(3).Col(1); IsWinner = *on; AtrRow(1).AtrCol(3) = %bitor(AtrRow(1).AtrCol(3):RI); AtrRow(2).AtrCol(2) = %bitor(AtrRow(1).AtrCol(3):RI); AtrRow(3).AtrCol(1) = %bitor(AtrRow(1).AtrCol(3):RI); 1e endif; 1b if IsWinner; // reset all selections 2b for Row = 1 to 3; ProtectA(Row).Col(*) = %bitor(ND: PR); 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // Don't care by this point. Load first available empty space with O. begsr srPutAnywhereO; 1b for Row = 1 to 3; 2b for Col = 1 to 3; 3b if Choice(Row).Col(Col) = ' '; Choice(Row).Col(Col) = 'O'; LV leavesr; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // There are some standard situations that can be setup to block or win. // It will be messy as I am now coding for situations depending on how // grid is filled to this point. begsr srStrategy; IsPlaced = *off; //--------------------------------------------------------- // First one to squelch is // __X // _O_ // X__ opening gambit. // Proper move for O here is 1,2 | 2,1 | 2,3 | or 3,2 //--------------------------------------------------------- 1b if Row1 = ' X' and Row2 = ' O ' and Row3 = 'X '; Choice(1).Col(2) = 'O'; IsPlaced = *on; //--------------------------------------------------------- // Second one to sQuelch is ___ or X__ or ___ // _OX _OX _OX // X__ ___ proper block is 1,3 _X_ // proper move for O here is 3,3 block is 1, //--------------------------------------------------------- 1x elseif Row1 = ' ' and Row2 = ' OX' and Row3 = 'X '; Choice(3).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = 'X ' and Row2 = ' OX' and Row3 = ' '; Choice(1).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = ' ' and Row2 = ' OX' and Row3 = ' X '; Choice(1).Col(3) = 'O'; IsPlaced = *on; //--------------------------------------------------------- // _X_ __X // _O_ _O_ // __X _X_ // proper move for O here is 2,1 or 2,3 or 3,3 //--------------------------------------------------------- 1x elseif Row1 = ' X ' and Row2 = ' O ' and Row3 = ' X'; Choice(2).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = ' X' and Row2 = ' O ' and Row3 = ' X '; Choice(2).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = 'X ' and Row2 = ' O ' and Row3 = ' X '; Choice(2).Col(3) = 'O'; IsPlaced = *on; //--------------------------------------------------------- // These next 4 are defense related. // O__ or __O or X__ or __X // _X_ _X_ _X_ _X_ // __X X__ __O O__ // proper move for 1 is 3,1 2=3,3 3=1,3 4=1,1 //--------------------------------------------------------- 1x elseif Choice(1).Col(2) = ' ' and Choice(2).Col(1) = ' ' and Choice(2).Col(3) = ' ' and Choice(3).Col(2) = ' ' and Choice(2).Col(2) = 'X'; 2b if Choice(1).Col(1) = 'O' and Choice(3).Col(3) = 'X'; Choice(3).Col(1) = 'O'; IsPlaced = *on; 2x elseif Choice(1).Col(3) = 'O' and Choice(3).Col(1) = 'X'; Choice(3).Col(3) = 'O'; IsPlaced = *on; 2x elseif Choice(3).Col(1) = 'O' and Choice(1).Col(3) = 'X'; Choice(1).Col(1) = 'O'; IsPlaced = *on; 2x elseif Choice(3).Col(3) = 'O' and Choice(1).Col(1) = 'X'; Choice(1).Col(3) = 'O'; IsPlaced = *on; 2e endif; //--------------------------------------------------------- // If O goes first, always select center square on first move. // As you know, If first move is to center then game will always be tie, // I am going to give X the widest range of options to make a mistake // but still cover our fannies. // if O has center square and X in any corner, place O in opposite corner. 1x elseif Row1 = 'X ' and Row2 = ' O ' and Row3 = ' '; Choice(3).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = ' X' and Row2 = ' O ' and Row3 = ' '; Choice(3).Col(1) = 'O'; IsPlaced = *on; 1x elseif Row1 = ' ' and Row2 = ' O ' and Row3 = 'X '; Choice(1).Col(3) = 'O'; IsPlaced = *on; 1x elseif Row1 = ' ' and Row2 = ' O ' and Row3 = ' X'; Choice(1).Col(1) = 'O'; IsPlaced = *on; //--------------------------------------------------------- // Various other gambits //--------------------------------------------------------- 1x elseif Row1 = 'OX ' and Row2 = ' O ' and Row3 = ' X'; Choice(2).Col(1) = 'O'; IsPlaced = *on; 1x elseif Row1 = 'X ' and Row2 = ' OX' and Row3 = ' O'; Choice(3).Col(2) = 'O'; IsPlaced = *on; 1x elseif Row1 = 'X ' and Row2 = ' O ' and Row3 = ' XO'; Choice(2).Col(3) = 'O'; IsPlaced = *on; 1e endif; endsr; /end-free //--------------------------------------------------------- // Return 5 X 9 array of selected character P f_FillGrid b D f_FillGrid PI 9a dim(5) D p_BaseChar 1a const D Line s 9a dim(5) /free 1b if p_BaseChar = 'X'; Line(1) = 'xxx xxx'; Line(2) = ' xxx xxx '; Line(3) = ' xxx '; Line(4) = ' xxx xxx '; Line(5) = 'xxx xxx'; 1x elseif p_BaseChar = 'O'; Line(1) = ' ooooo '; Line(2) = ' oo oo '; Line(3) = 'oo oo'; Line(4) = ' oo oo '; Line(5) = ' ooooo '; 1x elseif p_BaseChar = 'T'; Line(1) = 'TTTTTTTTT'; Line(2) = ' TTT '; Line(3) = ' TTT '; Line(4) = ' TTT '; Line(5) = ' TTT '; 1x elseif p_BaseChar = 'I'; Line(1) = ' IIIIIII '; Line(2) = ' III '; Line(3) = ' III '; Line(4) = ' III '; Line(5) = ' IIIIIII '; 1x elseif p_BaseChar = 'C'; Line(1) = ' CCCCC '; Line(2) = ' CCC '; Line(3) = 'CCC '; Line(4) = ' CCC '; Line(5) = ' CCCCC '; 1x elseif p_BaseChar = 'A'; Line(1) = ' AAA '; Line(2) = ' AA AA '; Line(3) = 'AAAAAAAAA'; Line(4) = 'AA AA'; Line(5) = 'AA AA'; 1x elseif p_BaseChar = 'E'; Line(1) = ' EEEEEE '; Line(2) = 'EE '; Line(3) = 'EEEEE '; Line(4) = 'EE '; Line(5) = ' EEEEEE '; 1e endif; return Line; /end-free P f_FillGrid e ]]> v5r4 *---------------------------------------------------------------- * JCRGMTICD - Tic-Tac-Toe - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA09 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A AWELCOME 1A P A ASTART 1A P A ANOTES 1A P A PROCATR11 1A P A PROCATR12 1A P A PROCATR13 1A P A PROCATR21 1A P A PROCATR22 1A P A PROCATR23 1A P A PROCATR31 1A P A PROCATR32 1A P A PROCATR33 1A P A ATR11 1A P A ATR12 1A P A ATR13 1A P A ATR21 1A P A ATR22 1A P A ATR23 1A P A ATR31 1A P A ATR32 1A P A ATR33 1A P A 1 3'JCRGMTIC' COLOR(BLU) A 1 13'TIC TAC TOE' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A GRID11_L1 9A O 2 13DSPATR(&ATR11) A 2 25' ' COLOR(BLU) DSPATR(RI) A GRID12_L1 9A O 2 29DSPATR(&ATR12) A 2 41' ' COLOR(BLU) DSPATR(RI) A GRID13_L1 9A O 2 45DSPATR(&ATR13) A GRID11_L2 9A O 3 13DSPATR(&ATR11) A 3 25' ' COLOR(BLU) DSPATR(RI) A GRID12_L2 9A O 3 29DSPATR(&ATR12) A 3 41' ' COLOR(BLU) DSPATR(RI) A GRID13_L2 9A O 3 45DSPATR(&ATR13) A 3 57'Welcome to TIC TAC TOE!' A DSPATR(&AWELCOME) A GRID11_L3 9A O 4 13DSPATR(&ATR11) A 4 25' ' COLOR(BLU) DSPATR(RI) A GRID12_L3 9A O 4 29DSPATR(&ATR12) A 4 41' ' COLOR(BLU) DSPATR(RI) A GRID13_L3 9A O 4 45DSPATR(&ATR13) A GRID11_L4 9A O 5 13DSPATR(&ATR11) A 5 25' ' COLOR(BLU) DSPATR(RI) A GRID12_L4 9A O 5 29DSPATR(&ATR12) A 5 41' ' COLOR(BLU) DSPATR(RI) A GRID13_L4 9A O 5 45DSPATR(&ATR13) A 5 57'PRESS ENTER TO BEGIN' A DSPATR(&AWELCOME) A GRID11_L5 9A O 6 13DSPATR(&ATR11) A 6 25' ' COLOR(BLU) DSPATR(RI) A GRID12_L5 9A O 6 29DSPATR(&ATR12) A 6 41' ' COLOR(BLU) DSPATR(RI) A GRID13_L5 9A O 6 45DSPATR(&ATR13) A 6 57'You can either start' A DSPATR(&ASTART) A R1C1 1A B 7 17DSPATR(&PROCATR11) A COMP(EQ 'X') CHECK(ER) A 7 25' ' COLOR(BLU) DSPATR(RI) A R1C2 1A B 7 33DSPATR(&PROCATR12) A COMP(EQ 'X') CHECK(ER) A 7 41' ' COLOR(BLU) DSPATR(RI) A R1C3 1A B 7 49DSPATR(&PROCATR13) A COMP(EQ 'X') A CHECK(ER) A 7 57'the game with an X, ' A DSPATR(&ASTART) A 8 13'----------------------------------- A -------' COLOR(BLU) A 8 57'or press Enter to let' A DSPATR(&ASTART) A 9 25' ' COLOR(BLU) DSPATR(RI) A 9 41' ' COLOR(BLU) DSPATR(RI) A 9 57'O go first.' DSPATR(&ASTART) A GRID21_L1 9A O 10 13DSPATR(&ATR21) A 10 25' ' COLOR(BLU) DSPATR(RI) A GRID22_L1 9A O 10 29DSPATR(&ATR22) A 10 41' ' COLOR(BLU) DSPATR(RI) A GRID23_L1 9A O 10 45DSPATR(&ATR23) A GRID21_L2 9A O 11 13DSPATR(&ATR21) A 11 25' ' COLOR(BLU) DSPATR(RI) A GRID22_L2 9A O 11 29DSPATR(&ATR22) A 11 41' ' COLOR(BLU) DSPATR(RI) A GRID23_L2 9A O 11 45DSPATR(&ATR23) A 11 57'Note: It is the' DSPATR(&ANOTES) A GRID21_L3 9A O 12 13DSPATR(&ATR21) A 12 25' ' COLOR(BLU) DSPATR(RI) A GRID22_L3 9A O 12 29DSPATR(&ATR22) A 12 41' ' COLOR(BLU) DSPATR(RI) A GRID23_L3 9A O 12 45DSPATR(&ATR23) A 12 57'nature of the game' A DSPATR(&ANOTES) A GRID21_L4 9A O 13 13DSPATR(&ATR21) A 13 25' ' COLOR(BLU) DSPATR(RI) A GRID22_L4 9A O 13 29DSPATR(&ATR22) A 13 41' ' COLOR(BLU) DSPATR(RI) A GRID23_L4 9A O 13 45DSPATR(&ATR23) A 13 57'that the only one' A DSPATR(&ANOTES) A GRID21_L5 9A O 14 13DSPATR(&ATR21) A 14 25' ' COLOR(BLU) DSPATR(RI) A GRID22_L5 9A O 14 29DSPATR(&ATR22) A 14 41' ' COLOR(BLU) DSPATR(RI) A GRID23_L5 9A O 14 45DSPATR(&ATR23) A 14 57'you can possibly win' A DSPATR(&ANOTES) A R2C1 1A B 15 17DSPATR(&PROCATR21) A COMP(EQ 'X') CHECK(ER) A 15 25' ' COLOR(BLU) DSPATR(RI) A R2C2 1A B 15 33DSPATR(&PROCATR22) A COMP(EQ 'X') CHECK(ER) A 15 41' ' COLOR(BLU) DSPATR(RI) A R2C3 1A B 15 49DSPATR(&PROCATR23) A COMP(EQ 'X') CHECK(ER) A 15 57'is when you start ' A DSPATR(&ANOTES) A 16 13'----------------------------------- A -------' COLOR(BLU) A 16 57'with a center X, and' A DSPATR(&ANOTES) A 17 25' ' COLOR(BLU) DSPATR(RI) A 17 41' ' COLOR(BLU) DSPATR(RI) A 17 57'O does not start in ' A DSPATR(&ANOTES) A GRID31_L1 9A O 18 13DSPATR(&ATR31) A 18 25' ' COLOR(BLU) DSPATR(RI) A GRID32_L1 9A O 18 29DSPATR(&ATR32) A 18 41' ' COLOR(BLU) DSPATR(RI) A GRID33_L1 9A O 18 45DSPATR(&ATR33) A 18 57'a corner.' DSPATR(&ANOTES) A GRID31_L2 9A O 19 13DSPATR(&ATR31) A 19 25' ' COLOR(BLU) DSPATR(RI) A GRID32_L2 9A O 19 29DSPATR(&ATR32) A 19 41' ' COLOR(BLU) DSPATR(RI) A GRID33_L2 9A O 19 45DSPATR(&ATR33) A GRID31_L3 9A O 20 13DSPATR(&ATR31) A 20 25' ' COLOR(BLU) DSPATR(RI) A GRID32_L3 9A O 20 29DSPATR(&ATR32) A 20 41' ' COLOR(BLU) DSPATR(RI) A GRID33_L3 9A O 20 45DSPATR(&ATR33) A GRID31_L4 9A O 21 13DSPATR(&ATR31) A 21 25' ' COLOR(BLU) DSPATR(RI) A GRID32_L4 9A O 21 29DSPATR(&ATR32) A 21 41' ' COLOR(BLU) DSPATR(RI) A GRID33_L4 9A O 21 45DSPATR(&ATR33) A GRID31_L5 9A O 22 13DSPATR(&ATR31) A 22 25' ' COLOR(BLU) DSPATR(RI) A GRID32_L5 9A O 22 29DSPATR(&ATR32) A 22 41' ' COLOR(BLU) DSPATR(RI) A GRID33_L5 9A O 22 45DSPATR(&ATR33) A R3C1 1A B 23 17DSPATR(&PROCATR31) A COMP(EQ 'X') CHECK(ER) A 23 25' ' COLOR(BLU) DSPATR(RI) A R3C2 1A B 23 33DSPATR(&PROCATR32) A COMP(EQ 'X') CHECK(ER) A 23 41' ' COLOR(BLU) DSPATR(RI) A R3C3 1A B 23 49DSPATR(&PROCATR33) A COMP(EQ 'X') CHECK(ER) A 24 2'F3=Exit' COLOR(BLU) A 24 57'F9=New Game' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRGMYAT - Yahtzee //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGMYATD cf e workstn infds(Infds) indds(Ind) //--*STAND ALONE------------------------------------------- D Color s 1a D DiceNum s 3u 0 D xx s 3u 0 D yy s 3u 0 D Row s 3u 0 D Col s 3u 0 D Throw s 3u 0 D OriginalDice s 3u 0 D UserDice s 3u 0 dim(5) ascend D FourDice s 3u 0 dim(4) D DropDice s 3u 0 D ForCount s 3u 0 D SumAllDots s 3u 0 D IsOneXed s n D ThreeShots s 3u 0 D pCount s 3u 0 D TotGrandA s 3a //--*COPY DEFINES------------------------------------------ /Define Sds /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetRandom /Define f_GetDayName /Define f_RmvSflMsg /Define f_SndSflMsg /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_LoadFace PR 3a dim(3) D 1a const D f_LoadRollCnt PR 4a dim(7) D 3u 0 //--*DATA STRUCTURES--------------------------------------- D SumDS ds D CalcSixes 3u 0 D CalcFives 3u 0 D CalcFours 3u 0 D CalcThrees 3u 0 D CalcTwos 3u 0 D CalcOnes 3u 0 D Calc3ofaKind 3u 0 D Calc4ofaKind 3u 0 D CalcFullHouse 3u 0 D CalcRunof4s 3u 0 D CalcRunof5s 3u 0 D CalcYahtzee 3u 0 D CalcChance 3u 0 D SumArry 3u 0 dim(13) overlay(SumDS:1) // array of what selections will score. D IsScoreDS ds D IsSixes n D IsFives n D IsFours n D IsThrees n D IsTwos n D IsOnes n D Is3ofaKind n D Is4ofaKind n D IsFullHouse n D IsRunof4s n D IsRunof5s n D IsYahtzee n D IsChance n D IsScoreArry n dim(13) overlay(IsScoreDS:1) // Protect selections that have already been made. D ProtectDS ds D Pro6S 1a D Pro5S 1a D Pro4S 1a D Pro3S 1a D Pro2S 1a D Pro1S 1a D Pro3OfKind 1a D Pro4OfKind 1a D ProFullHou 1a D Pro4InRow 1a D Pro5InRow 1a D ProYahtzee 1a D ProChance 1a D ProtectArry 1a dim(13) overlay(ProtectDS:1) // Total up selections D TotalsDS ds D Tot6S D Tot5S D Tot4S D Tot3S D Tot2S D Tot1S D Tot3OfKind D Tot4OfKind D TotFullHou D Tot4InRow D Tot5InRow D TotYahtzee D TotChance D TotArry dim(13) overlay(TotalsDS:1) D like(Tot6S) // highlight selections that will score D BucketAttrDS ds D A6SA D A5SA D A4SA D A3SA D A2SA D A1SA D A3OFA D A4OFA D AFULLA D A4ROWA D A5ROWA D AYAHA D aChanceA D BucketArryAtr 1a dim(13) overlay(BucketAttrDS:1) // highlight text of selections that will score D TextAttrDS ds D A6SB D A5SB D A4SB D A3SB D A2SB D A1SB D A3OFB D A4OFB D AFULLB D A4ROWB D A5ROWB D AYAHB D aChanceB D TextArryAtr 1a dim(13) overlay(TextAttrDS:1) // highlight totals of selections that will score D TotAttrDS ds D A6SC D A5SC D A4SC D A3SC D A2SC D A1SC D A3OFC D A4OFC D AFULLC D A4ROWC D A5ROWC D AYAHC D aChanceC D TotArryAtr 1a dim(13) overlay(TotAttrDS:1) // highlight ancillary text of selections that will score D Text2AttrDS ds D A3OFD overlay(Text2AttrDS:7) D A4OFD overlay(Text2AttrDS:*next) D AFULLD overlay(Text2AttrDS:*next) D A4ROWD overlay(Text2AttrDS:*next) D A5ROWD overlay(Text2AttrDS:*next) D AYAHD overlay(Text2AttrDS:*next) D aChanceD overlay(Text2AttrDS:*next) D Text2ArryAtr 1a dim(13) overlay(Text2AttrDS:1) // load selections into array for validity checking D BucketsDS ds D Sel6S D Sel5S D Sel4S D Sel3S D Sel2S D Sel1S D Sel3OfKind D Sel4OfKind D SelFullHou D Sel4InRow D Sel5InRow D SelYahtzee D SelChance D xBucketArry 1a dim(13) overlay(BucketsDS:1) // dice outline Border attributes D BorderADS ds D Border1A D Border2A D Border3A D Border4A D Border5A D BorderA 1a dim(5) overlay(BorderADS:1) // Name screen indicators D ind ds qualified D ScreenCtl n overlay(ind:10) // map screen fields into DS so pointers to data can overlay D DiscardDS ds D Discard1 D Discard2 D Discard3 D Discard4 D Discard5 D DiscardArry 1a dim(5) overlay(DiscardDS) // Define 3D array for dice faces and attributes D Face ds dim(5) qualified based(ptr1) D Row likeds(Rowx) dim(3) D Rowx ds qualified D Col 1a dim(3) D ptr1 s * inz(%addr(s0111)) D FaceAttr ds dim(5) likeds(Face) based(ptr2) D ptr2 s * inz(%addr(s0111a)) // Define 2D arrays for large roll counter and final total D RollCnt ds dim(7) qualified based(ptr6) large roll counter D Col 1a dim(4) D ptr6 s * inz(%addr(C111)) D RollCntA ds dim(7) likeds(RollCnt) based(ptr7) D ptr7 s * inz(%addr(C111a)) D LargeGrand10s ds dim(7) likeds(RollCnt) based(ptr8) large grand 10s D ptr8 s * inz(%addr(C211)) D LargeGrand10sA ds dim(7) likeds(RollCnt) based(ptr9) D ptr9 s * inz(%addr(C211a)) D LargeGrand1s ds dim(7) likeds(RollCnt) based(ptr10) large grand 1s D ptr10 s * inz(%addr(C311)) D LargeGrand1sA ds dim(7) likeds(RollCnt) based(ptr11) D ptr11 s * inz(%addr(C311a)) // map screen fields into DS so arrays can manipulate values D screenDS ds // Dice Faces D s0111 D s0112 D s0113 D s0121 D s0122 D s0123 D s0131 D s0132 D s0133 D s0211 D s0212 D s0213 D s0221 D s0222 D s0223 D s0231 D s0232 D s0233 D s0311 D s0312 D s0313 D s0321 D s0322 D s0323 D s0331 D s0332 D s0333 D s0411 D s0412 D s0413 D s0421 D s0422 D s0423 D s0431 D s0432 D s0433 D s0511 D s0512 D s0513 D s0521 D s0522 D s0523 D s0531 D s0532 D s0533 D C111 D C112 D C113 D C114 D C121 D C122 D C123 D C124 D C131 D C132 D C133 D C134 D C141 D C142 D C143 D C144 D C151 D C152 D C153 D C154 D C161 D C162 D C163 D C164 D C171 D C172 D C173 D C174 D C211 D C212 D C213 D C214 D C221 D C222 D C223 D C224 D C231 D C232 D C233 D C234 D C241 D C242 D C243 D C244 D C251 D C252 D C253 D C254 D C261 D C262 D C263 D C264 D C271 D C272 D C273 D C274 D C311 D C312 D C313 D C314 D C321 D C322 D C323 D C324 D C331 D C332 D C333 D C334 D C341 D C342 D C343 D C344 D C351 D C352 D C353 D C354 D C361 D C362 D C363 D C364 D C371 D C372 D C373 D C374 // dice face attributes D s0111a D s0112a D s0113a D s0121a D s0122a D s0123a D s0131a D s0132a D s0133a D s0211a D s0212a D s0213a D s0221a D s0222a D s0223a D s0231a D s0232a D s0233a D s0311a D s0312a D s0313a D s0321a D s0322a D s0323a D s0331a D s0332a D s0333a D s0411a D s0412a D s0413a D s0421a D s0422a D s0423a D s0431a D s0432a D s0433a D s0511a D s0512a D s0513a D s0521a D s0522a D s0523a D s0531a D s0532a D s0533a D C111A D C112A D C113A D C114A D C121A D C122A D C123A D C124A D C131A D C132A D C133A D C134A D C141A D C142A D C143A D C144A D C151A D C152A D C153A D C154A D C161A D C162A D C163A D C164A D C171A D C172A D C173A D C174A D C211A D C212A D C213A D C214A D C221A D C222A D C223A D C224A D C231A D C232A D C233A D C234A D C241A D C242A D C243A D C244A D C251A D C252A D C253A D C254A D C261A D C262A D C263A D C264A D C271A D C272A D C273A D C274A D C311A D C312A D C313A D C314A D C321A D C322A D C323A D C324A D C331A D C332A D C333A D C334A D C341A D C342A D C343A D C344A D C351A D C352A D C353A D C354A D C361A D C362A D C363A D C364A D C371A D C372A D C373A D C374A //--*ENTRY PARMS *NONE* ----------------------------------- /free f_RmvSflMsg(ProgId); exsr srNewStart; // Load initial splash screen to get game started. Face(1).Row = f_LoadFace('Y'); Face(2).Row = f_LoadFace('A'); Face(3).Row = f_LoadFace('H'); Face(4).Row = f_LoadFace('T'); Face(5).Row = f_LoadFace('Z'); BorderA(*) = Green; 1b for DiceNum = 1 to 5; 2b if DiceNum = 1 or DiceNum = 5; Color = %bitor(Red: RI); 2x elseif DiceNum = 2; Color = %bitor(White: RI); 2x elseif DiceNum = 3; Color = %bitor(Yellow: RI); 2x elseif DiceNum = 4; Color = %bitor(Blue:RI); 2e endif; // load Dice colors 2b for Row = 1 to 3; 3b for Col = 1 to 3; 4b if Face(DiceNum).Row(Row).Col(Col) > ' '; FaceAttr(DiceNum).Row(Row).Col(Col) = Color; 4e endif; 3e endfor; 2e endfor; 1e endfor; // initially protect selections BucketArryAtr(*) = %bitor(ND: PR); ThreeShots = 0; pCount = 0; exsr srColorRollCnt; // show splash screen exfmt SCREEN; 1b if InfdsFkey = f03; *inlr = *on; return; 1e endif; BorderA(*) = Green; exsr srNewStart; //--------------------------------------------------------- // Play the game. 1b dou 1 = 2; 2b for ThreeShots = 1 to 3; exsr srColorRollCnt; 3b if ThreeShots = 1; DiscardArry(*) = *blanks; Ind.ScreenCtl = *on; 3x elseif ThreeShots = 3; Ind.ScreenCtl = *off; 3e endif; 3b if pCount = 13; // all selected exsr srShowFinalScore; 3x else; exsr srRollDaBones; exsr srCalcTotals; /end-free C fixerror tag /free 4b if ThreeShots = 3; f_SndSflMsg(ProgId: 'Select a section category.'); 4e endif; 3e endif; write MSGCTL; exfmt SCREEN; f_RmvSflMsg(ProgId); 3b if InfdsFkey = f03; *inlr = *on; return; 3x elseif InfdsFkey = F09 or pCount = 13; exsr srNewStart; 2v leave; 3e endif; // Check to see if any selection has been 'X'ed thus ending turn // note if player tries to X multiple categories, only first X is used IsOneXed = *off; 3b for xx = 1 to 13; 4b if ProtectArry(xx) <> 'P'; // protected 5b if XbucketArry(xx) > ' '; 6b if IsOneXed; XbucketArry(xx) = *blanks; 6e endif; IsOneXed = *on; 5e endif; 4e endif; 3e endfor; 3b if Threeshots = 3 and not IsOneXed; f_SndSflMsg(ProgId: 'Must select category after three rolls.'); /end-free GO C goto fixerror /free 3e endif; 3b for xx = 1 to 13; 4b if xBucketArry(xx) > ' '; xBucketArry(xx) = ' '; ProtectArry(xx) = 'P'; BucketArryAtr(xx) = %bitor(ND: PR); TextArryAtr(xx) = %bitor(Blue: RI); TotArryAtr(xx) = %bitor(Blue: RI); Text2ArryAtr(xx) = Blue; 4e endif; 3e endfor; 3b if IsOneXed; 2v leave; 3e endif; 2e endfor; // get grand total for protected totals 2b if InfdsFkey <> F09; TotGrand = 0; TotUpper = 0; TotBonus = 0; pCount = 0; 3b for xx = 1 to 13; 4b if ProtectArry(xx) = 'P'; pCount += 1; TotGrand += TotArry(xx); 5b if xx < 7; TotUpper += TotArry(xx); 5e endif; 4e endif; 3e endfor; 3b if TotUpper >= 63; TotBonus = 35; TotGrand += 35; 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- // Idea here, is to show final score in large characters // Using roll count as hundreds digit, then two other // large characters for 10s and 1s. begsr srShowFinalScore; RollMsg = 'Final Score'; Ind.ScreenCtl = *off; f_SndSflMsg(ProgId: 'Game Over - Press F9 for new game.'); Ind.ScreenCtl = *off; evalr TotgrandA = '000' + %char(TotGrand); ThreeShots = %dec(%subst(TotGrandA:3:1) :1 :0); exsr srColorRollCnt; LargeGrand1s(*) = RollCnt(*); LargeGrand1sA(*) = RollCntA(*); ThreeShots = %dec(%subst(TotGrandA:2:1) :1 :0); exsr srColorRollCnt; LargeGrand10s(*) = RollCnt(*); LargeGrand10sA(*) = RollCntA(*); ThreeShots = %dec(%subst(TotGrandA:1:1) :1 :0); exsr srColorRollCnt; endsr; //--------------------------------------------------------- // Throw dice to replace dice user has X ed. // to make game a bit easier, if roll is exact same number // as before, roll again to give a new number. begsr srRollDaBones; 1b if ThreeShots = 1; UserDice(*) = 0; 1e endif; 1b for Throw = 1 to 5; 2b if DiscardArry(Throw) > ' ' or ThreeShots = 1; OriginalDice = UserDice(Throw); 3b dou UserDice(Throw) <> OriginalDice; UserDice(Throw) = f_GetRandom(6); 3e enddo; 2e endif; 1e endfor; sorta UserDice; exsr srLoadUserScreen; DiscardArry(*) = *blanks; endsr; //--------------------------------------------------------- begsr srColorRollCnt; RollCnt = f_LoadRollCnt(ThreeShots); 1b for Row = 1 to 7; 2b for Col = 1 to 4; 3b if RollCnt(Row).Col(Col) > ' '; RollCntA(Row).Col(Col) = %bitor(Blue: RI); 3x else; RollCntA(Row).Col(Col) = ND; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // Load Dice images to screen. // Mostly concerned with loading proper headings, messages, and setting indicators. begsr srLoadUserScreen; 1b for DiceNum = 1 to 5; Face(DiceNum) = *blanks; FaceAttr(DiceNum) = ND; Face(DiceNum).Row = f_LoadFace(%char(UserDice(DiceNum))); 2b for Row = 1 to 3; 3b for Col = 1 to 3; 4b if Face(DiceNum).Row(Row).Col(Col) > ' '; 5b if UserDice(DiceNum) = 1; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(White: RI); 5x elseif UserDice(DiceNum) = 2; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(Yellow: RI); 5x elseif UserDice(DiceNum) = 3; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(Green: RI); 5x elseif UserDice(DiceNum) = 4; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(Pink: RI); 5x elseif UserDice(DiceNum) = 5; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(Red: RI); 5x elseif UserDice(DiceNum) = 6; FaceAttr(DiceNum).Row(Row).Col(Col) = %bitor(Blue: RI); 5e endif; 4e endif; 3e endfor; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // See what will score! // I am going to let all conditions be scored. Example: Even if // player already has 4 of a kind, I will still let 4 of kind be counted // here. In another section of code, I will figure out what player // has already selected and present new options to player. //--------------------------------------------------------- begsr srCalcTotals; SumAllDots = %xfoot(UserDice); IsScoreArry(*) = *off; IsChance = *on; SumArry(*) = 0; CalcChance = SumAllDots; // Check for large straight of 5 DiceNum = 1; 1b if UserDice(DiceNum) = UserDice(DiceNum + 1) -1 and UserDice(DiceNum) = UserDice(DiceNum + 2) -2 and UserDice(DiceNum) = UserDice(DiceNum + 3) -3 and UserDice(DiceNum) = UserDice(DiceNum + 4) -4; IsRunOf5s = *on; IsRunOf4s = *on; 1e endif; //--------------------------------------------------------- // Check for small straight of 4 // Small straight is complicated a bit by need // to remove one dice in hand from consideration. // Example 1 2 2 3 4 // I need to exclude one of the 2s to check for straight. // Remove dice 1 through 5 then check remaining 4 dice for a straight. 1b if not IsRunOf5s; 2b for DropDice = 1 to 5; yy = 0; 3b for xx = 1 to 5; 4b if xx <> DropDice; yy += 1; FourDice(yy) = UserDice(xx); 4e endif; 3e endfor; 3b if FourDice(1) = FourDice(2) -1 and FourDice(1) = FourDice(3) -2 and FourDice(1) = FourDice(4) -3; IsRunOf4s = *on; 2v leave; 3e endif; 2e endfor; 1e endif; 1b if IsRunof5s; CalcRunof5s = 40; 1e endif; 1b if IsRunof4s; CalcRunof4s = 30; 1e endif; //--------------------------------------------------------- // 5 of a kind or Yahtzee DiceNum = 1; 1b if UserDice(DiceNum) = UserDice(DiceNum + 1) and UserDice(DiceNum) = UserDice(DiceNum + 2) and UserDice(DiceNum) = UserDice(DiceNum + 3) and UserDice(DiceNum) = UserDice(DiceNum + 4); IsYahtzee = *on; Is4ofaKind = *on; Is3ofaKind = *on; 1e endif; //--------------------------------------------------------- // 4 of a kind. 1b if not IsYahtzee; 2b for DiceNum = 1 to 2; 3b if UserDice(DiceNum) = UserDice(DiceNum + 1) and UserDice(DiceNum) = UserDice(DiceNum + 2) and UserDice(DiceNum) = UserDice(DiceNum + 3); Is4ofaKind = *on; Is3ofaKind = *on; 2v leave; 3e endif; 2e endfor; //--------------------------------------------------------- // 3 of a kind 2b if not Is4ofaKind; 3b for DiceNum = 1 to 3; 4b if UserDice(DiceNum) = UserDice(DiceNum + 1) and UserDice(DiceNum) = UserDice(DiceNum + 2); Is3ofaKind = *on; 3v leave; 4e endif; 3e endfor; 2e endif; 1e endif; 1b if Is3ofaKind; Calc3ofaKind = SumAllDots; 1e endif; 1b if Is4ofaKind; Calc4ofaKind = SumAllDots; 1e endif; 1b if IsYahtzee; CalcYahtzee = 50; 1e endif; //--------------------------------------------------------- // Check for Full House. First 2 have to match and last 3 have to match // or first 3 have to match and last 2 have to match. 1b if (UserDice(1) = UserDice(2) and UserDice(3) = UserDice(4) and UserDice(3) = UserDice(5)) and UserDice(1) <> UserDice(5) or (UserDice(1) = UserDice(2) and UserDice(1) = UserDice(3) and UserDice(4) = UserDice(5)) and UserDice(1) <> UserDice(5); IsFullHouse = *on; CalcFullHouse = 25; 1e endif; //--------------------------------------------------------- // Check for upper section numbers 1b for DiceNum = 1 to 5; 2b if UserDice(DiceNum) = 1; IsOnes = *on; CalcOnes += 1; 2x elseif UserDice(DiceNum) = 2; IsTwos = *on; CalcTwos += 2; 2x elseif UserDice(DiceNum) = 3; IsThrees = *on; CalcThrees += 3; 2x elseif UserDice(DiceNum) = 4; IsFours = *on; CalcFours += 4; 2x elseif UserDice(DiceNum) = 5; IsFives = *on; CalcFives += 5; 2x elseif UserDice(DiceNum) = 6; IsSixes = *on; CalcSixes += 6; 2e endif; 1e endfor; //--------------------------------------------------------- // now figure out what can score 1b for xx = 1 to 13; 2b if ProtectArry(xx) <> 'P'; 3b if IsScoreArry(xx); TotArry(xx) = SumArry(xx); BucketArryAtr(xx) = %bitor(White: UL); TextArryAtr(xx) = White; TotArryAtr(xx) = White; Text2ArryAtr(xx) = White; 3x else; TotArry(xx) = 0; BucketArryAtr(xx) = x'00'; TextArryAtr(xx) = x'00'; TotArryAtr(xx) = x'00'; Text2ArryAtr(xx) = x'00'; 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr srNewStart; evalr scDow = %trimr(f_GetDayName()); RollMsg = 'Roll Count'; ProtectArry(*) = *blanks; BucketArryAtr(*) = x'00'; TextArryAtr(*) = x'00'; TotArryAtr(*) = x'00'; Text2ArryAtr(*) = x'00'; XbucketArry(*) = *blanks; TotGRAND = 0; TotUpper = 0; TotBonus = 0; 1b for row = 1 to 7; LargeGrand10s(Row).Col(*) = ND; LargeGrand1s(Row).Col(*) = ND; RollCntA(Row).Col(*) = ND; 1e endfor; TotArry(*) = 0; pCount = 0; endsr; /end-free //--------------------------------------------------------- // Return 4 row X 7 column array of roll count number P f_LoadRollCnt b D f_LoadRollCnt PI 4a dim(7) D p_BaseNum 3u 0 D Line s 4a dim(7) /free 1b if p_BaseNum = 3; Line(1) = '333 '; Line(2) = ' 3'; Line(3) = ' 3'; Line(4) = ' 333'; Line(5) = ' 3'; Line(6) = ' 3'; Line(7) = '333 '; 1x elseif p_BaseNum = 2; Line(1) = '222 '; Line(2) = ' 2'; Line(3) = ' 2'; Line(4) = ' 22 '; Line(5) = '2 '; Line(6) = '2 '; Line(7) = '2222'; 1x elseif p_BaseNum = 1; Line(1) = ' 11 '; Line(2) = ' 1 '; Line(3) = ' 1 '; Line(4) = ' 1 '; Line(5) = ' 1 '; Line(6) = ' 1 '; Line(7) = ' 111'; 1x elseif p_BaseNum = 0; Line(1) = ' 00 '; Line(2) = '0 0'; Line(3) = '0 0'; Line(4) = '0 0'; Line(5) = '0 0'; Line(6) = '0 0'; Line(7) = ' 00 '; 1x elseif p_BaseNum = 9; Line(1) = '9999'; Line(2) = '9 9'; Line(3) = '9 9'; Line(4) = '9999'; Line(5) = ' 9'; Line(6) = ' 9'; Line(7) = '9999'; 1x elseif p_BaseNum = 8; Line(1) = '8888'; Line(2) = '8 8'; Line(3) = '8 8'; Line(4) = '8888'; Line(5) = '8 8'; Line(6) = '8 8'; Line(7) = '8888'; 1x elseif p_BaseNum = 7; Line(1) = '7777'; Line(2) = ' 7'; Line(3) = ' 7'; Line(4) = ' 7 '; Line(5) = ' 7 '; Line(6) = '7 '; Line(7) = '7 '; 1x elseif p_BaseNum = 6; Line(1) = '6666'; Line(2) = '6 '; Line(3) = '6 '; Line(4) = '6666'; Line(5) = '6 6'; Line(6) = '6 6'; Line(7) = '6666'; 1x elseif p_BaseNum = 5; Line(1) = '5555'; Line(2) = '5 '; Line(3) = '5 '; Line(4) = '5555'; Line(5) = ' 5'; Line(6) = ' 5'; Line(7) = '5555'; 1x elseif p_BaseNum = 4; Line(1) = ' 44'; Line(2) = ' 4 4'; Line(3) = '4 4'; Line(4) = '4444'; Line(5) = ' 4'; Line(6) = ' 4'; Line(7) = ' 4'; 1e endif; return Line; /end-free P f_LoadRollCnt e //--------------------------------------------------------- // Return 3 X 3 array of dice face. P f_LoadFace b D f_LoadFace PI 3a dim(3) D p_BaseNum 1a const D Line s 3a dim(3) /free 1b if p_BaseNum = '6'; Line(1) = '666'; Line(2) = ' '; Line(3) = '666'; 1x elseif p_BaseNum = '5'; Line(1) = '5 5'; Line(2) = ' 5 '; Line(3) = '5 5'; 1x elseif p_BaseNum = '4'; Line(1) = '4 4'; Line(2) = ' '; Line(3) = '4 4'; 1x elseif p_BaseNum = '3'; Line(1) = '3 '; Line(2) = ' 3 '; Line(3) = ' 3'; 1x elseif p_BaseNum = '2'; Line(1) = '2 '; Line(2) = ' '; Line(3) = ' 2'; 1x elseif p_BaseNum = '1'; Line(1) = ' '; Line(2) = ' 1 '; Line(3) = ' '; 1x elseif p_BaseNum = 'Y'; Line(1) = 'Y Y'; Line(2) = ' Y '; Line(3) = ' Y '; 1x elseif p_BaseNum = 'A'; Line(1) = ' A '; Line(2) = 'A A'; Line(3) = 'A A'; 1x elseif p_BaseNum = 'H'; Line(1) = 'H H'; Line(2) = 'HHH'; Line(3) = 'H H'; 1x elseif p_BaseNum = 'T'; Line(1) = 'TTT'; Line(2) = ' T '; Line(3) = ' T '; 1x elseif p_BaseNum = 'Z'; Line(1) = 'ZZ '; Line(2) = ' Z '; Line(3) = ' ZZ'; 1e endif; return Line; /end-free P f_LoadFace e ]]> v5r4 *---------------------------------------------------------------- * JCRGMYATD - Yahtzee - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CF09 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN OVERLAY A C111A 1A P A C112A 1A P A C113A 1A P A C114A 1A P A C121A 1A P A C122A 1A P A C123A 1A P A C124A 1A P A C131A 1A P A C132A 1A P A C133A 1A P A C134A 1A P A C141A 1A P A C142A 1A P A C143A 1A P A C144A 1A P A C151A 1A P A C152A 1A P A C153A 1A P A C154A 1A P A C161A 1A P A C162A 1A P A C163A 1A P A C164A 1A P A C171A 1A P A C172A 1A P A C173A 1A P A C174A 1A P A C211A 1A P A C212A 1A P A C213A 1A P A C214A 1A P A C221A 1A P A C222A 1A P A C223A 1A P A C224A 1A P A C231A 1A P A C232A 1A P A C233A 1A P A C234A 1A P A C241A 1A P A C242A 1A P A C243A 1A P A C244A 1A P A C251A 1A P A C252A 1A P A C253A 1A P A C254A 1A P A C261A 1A P A C262A 1A P A C263A 1A P A C264A 1A P A C271A 1A P A C272A 1A P A C273A 1A P A C274A 1A P A C311A 1A P A C312A 1A P A C313A 1A P A C314A 1A P A C321A 1A P A C322A 1A P A C323A 1A P A C324A 1A P A C331A 1A P A C332A 1A P A C333A 1A P A C334A 1A P A C341A 1A P A C342A 1A P A C343A 1A P A C344A 1A P A C351A 1A P A C352A 1A P A C353A 1A P A C354A 1A P A C361A 1A P A C362A 1A P A C363A 1A P A C364A 1A P A C371A 1A P A C372A 1A P A C373A 1A P A C374A 1A P A BORDER1A 1A P A BORDER2A 1A P A BORDER3A 1A P A BORDER4A 1A P A BORDER5A 1A P A S0111A 1A P A S0112A 1A P A S0113A 1A P A S0121A 1A P A S0122A 1A P A S0123A 1A P A S0131A 1A P A S0132A 1A P A S0133A 1A P A S0211A 1A P A S0212A 1A P A S0213A 1A P A S0221A 1A P A S0222A 1A P A S0223A 1A P A S0231A 1A P A S0232A 1A P A S0233A 1A P A S0311A 1A P A S0312A 1A P A S0313A 1A P A S0321A 1A P A S0322A 1A P A S0323A 1A P A S0331A 1A P A S0332A 1A P A S0333A 1A P A S0411A 1A P A S0412A 1A P A S0413A 1A P A S0421A 1A P A S0422A 1A P A S0423A 1A P A S0431A 1A P A S0432A 1A P A S0433A 1A P A S0511A 1A P A S0512A 1A P A S0513A 1A P A S0521A 1A P A S0522A 1A P A S0523A 1A P A S0531A 1A P A S0532A 1A P A S0533A 1A P A A6SA 1A P A A6SB 1A P A A6SC 1A P A A5SA 1A P A A5SB 1A P A A5SC 1A P A A4SA 1A P A A4SB 1A P A A4SC 1A P A A3SA 1A P A A3SB 1A P A A3SC 1A P A A2SA 1A P A A2SB 1A P A A2SC 1A P A A1SA 1A P A A1SB 1A P A A1SC 1A P A A3OFA 1A P A A3OFB 1A P A A3OFC 1A P A A3OFD 1A P A A4OFA 1A P A A4OFB 1A P A A4OFC 1A P A A4OFD 1A P A AFULLA 1A P A AFULLB 1A P A AFULLC 1A P A AFULLD 1A P A A4ROWA 1A P A A4ROWB 1A P A A4ROWC 1A P A A4ROWD 1A P A A5ROWA 1A P A A5ROWB 1A P A A5ROWC 1A P A A5ROWD 1A P A AYAHA 1A P A AYAHB 1A P A AYAHC 1A P A AYAHD 1A P A ACHANCEA 1A P A ACHANCEB 1A P A ACHANCEC 1A P A ACHANCED 1A P A 1 3'JCRGMYAT' COLOR(BLU) A 1 14'YATZHEE' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 3'_________' DSPATR(&BORDER1A) A 2 14'_________' DSPATR(&BORDER2A) A 2 25'_________' DSPATR(&BORDER3A) A 2 36'_________' DSPATR(&BORDER4A) A 2 47'_________' DSPATR(&BORDER5A) A 3 3'|' DSPATR(&BORDER1A) A 3 11'|' DSPATR(&BORDER1A) A 3 14'|' DSPATR(&BORDER2A) A 3 22'|' DSPATR(&BORDER2A) A 3 25'|' DSPATR(&BORDER3A) A 3 33'|' DSPATR(&BORDER3A) A 3 36'|' DSPATR(&BORDER4A) A 3 44'|' DSPATR(&BORDER4A) A 3 47'|' DSPATR(&BORDER5A) A 3 55'|' DSPATR(&BORDER5A) A 4 3'|' DSPATR(&BORDER1A) A S0111 1A O 4 5DSPATR(&S0111A) A S0112 1A O 4 7DSPATR(&S0112A) A S0113 1A O 4 9DSPATR(&S0113A) A 4 11'|' DSPATR(&BORDER1A) A 4 14'|' DSPATR(&BORDER2A) A S0211 1A O 4 16DSPATR(&S0211A) A S0212 1A O 4 18DSPATR(&S0212A) A S0213 1A O 4 20DSPATR(&S0213A) A 4 22'|' DSPATR(&BORDER2A) A 4 25'|' DSPATR(&BORDER3A) A S0311 1A O 4 27DSPATR(&S0311A) A S0312 1A O 4 29DSPATR(&S0312A) A S0313 1A O 4 31DSPATR(&S0313A) A 4 33'|' DSPATR(&BORDER3A) A 4 36'|' DSPATR(&BORDER4A) A S0411 1A O 4 38DSPATR(&S0411A) A S0412 1A O 4 40DSPATR(&S0412A) A S0413 1A O 4 42DSPATR(&S0413A) A 4 44'|' DSPATR(&BORDER4A) A 4 47'|' DSPATR(&BORDER5A) A S0511 1A O 4 49DSPATR(&S0511A) A S0512 1A O 4 51DSPATR(&S0512A) A S0513 1A O 4 53DSPATR(&S0513A) A 4 55'|' DSPATR(&BORDER5A) A 5 3'|' DSPATR(&BORDER1A) A S0121 1A O 5 5DSPATR(&S0121A) A S0122 1A O 5 7DSPATR(&S0122A) A S0123 1A O 5 9DSPATR(&S0123A) A 5 11'|' DSPATR(&BORDER1A) A 5 14'|' DSPATR(&BORDER2A) A S0221 1A O 5 16DSPATR(&S0221A) A S0222 1A O 5 18DSPATR(&S0222A) A S0223 1A O 5 20DSPATR(&S0223A) A 5 22'|' DSPATR(&BORDER2A) A 5 25'|' DSPATR(&BORDER3A) A S0321 1A O 5 27DSPATR(&S0321A) A S0322 1A O 5 29DSPATR(&S0322A) A S0323 1A O 5 31DSPATR(&S0323A) A 5 33'|' DSPATR(&BORDER3A) A 5 36'|' DSPATR(&BORDER4A) A S0421 1A O 5 38DSPATR(&S0421A) A S0422 1A O 5 40DSPATR(&S0422A) A S0423 1A O 5 42DSPATR(&S0423A) A 5 44'|' DSPATR(&BORDER4A) A 5 47'|' DSPATR(&BORDER5A) A S0521 1A O 5 49DSPATR(&S0521A) A S0522 1A O 5 51DSPATR(&S0522A) A S0523 1A O 5 53DSPATR(&S0523A) A 5 55'|' DSPATR(&BORDER5A) A 6 3'|' DSPATR(&BORDER1A) A S0131 1A O 6 5DSPATR(&S0131A) A S0132 1A O 6 7DSPATR(&S0132A) A S0133 1A O 6 9DSPATR(&S0133A) A 6 11'|' DSPATR(&BORDER1A) A 6 14'|' DSPATR(&BORDER2A) A S0231 1A O 6 16DSPATR(&S0231A) A S0232 1A O 6 18DSPATR(&S0232A) A S0233 1A O 6 20DSPATR(&S0233A) A 6 22'|' DSPATR(&BORDER2A) A 6 25'|' DSPATR(&BORDER3A) A S0331 1A O 6 27DSPATR(&S0331A) A S0332 1A O 6 29DSPATR(&S0332A) A S0333 1A O 6 31DSPATR(&S0333A) A 6 33'|' DSPATR(&BORDER3A) A 6 36'|' DSPATR(&BORDER4A) A S0431 1A O 6 38DSPATR(&S0431A) A S0432 1A O 6 40DSPATR(&S0432A) A S0433 1A O 6 42DSPATR(&S0433A) A 6 44'|' DSPATR(&BORDER4A) A 6 47'|' DSPATR(&BORDER5A) A S0531 1A O 6 49DSPATR(&S0531A) A S0532 1A O 6 51DSPATR(&S0532A) A S0533 1A O 6 53DSPATR(&S0533A) A 6 55'|' DSPATR(&BORDER5A) A 7 3'|_______|' DSPATR(&BORDER1A) A 7 14'|_______|' DSPATR(&BORDER2A) A 7 25'|_______|' DSPATR(&BORDER3A) A 7 36'|_______|' DSPATR(&BORDER4A) A 7 47'|_______|' DSPATR(&BORDER5A) A 10 DISCARD1 1A B 8 6COLOR(WHT) A 10 DISCARD2 1A B 8 18COLOR(WHT) A 10 DISCARD3 1A B 8 29COLOR(WHT) A 10 DISCARD4 1A B 8 40COLOR(WHT) A 10 DISCARD5 1A B 8 51COLOR(WHT) A 10 6'Upper Section' COLOR(BLU) A 10 22'Lower Section' COLOR(BLU) A ROLLMSG 12A O 10 47COLOR(BLU) A SEL1S 1A I 11 6DSPATR(&A1SA) A 11 8'Ones' DSPATR(&A1SB) A TOT1S 2Y 0O 11 15EDTCDE(3) DSPATR(&A1SC) A SEL3OFKIND 1A I 11 22DSPATR(&A3OFA) A 11 24'3 of Kind' DSPATR(&A3OFB) A TOT3OFKIND 2Y 0O 11 35EDTCDE(3) DSPATR(&A3OFC) A 11 39'(Sum)' DSPATR(&A3OFD) A C111 1A O 11 49DSPATR(&C111A) A C112 1A O 11 51DSPATR(&C112A) A C113 1A O 11 53DSPATR(&C113A) A C114 1A O 11 55DSPATR(&C114A) A C211 1A O 11 58DSPATR(&C211A) A C212 1A O 11 60DSPATR(&C212A) A C213 1A O 11 62DSPATR(&C213A) A C214 1A O 11 64DSPATR(&C214A) A C311 1A O 11 67DSPATR(&C311A) A C312 1A O 11 69DSPATR(&C312A) A C313 1A O 11 71DSPATR(&C313A) A C314 1A O 11 73DSPATR(&C314A) A SEL2S 1A I 12 6DSPATR(&A2SA) A 12 8'Twos' DSPATR(&A2SB) A TOT2S 2Y 0O 12 15EDTCDE(3) DSPATR(&A2SC) A SEL4OFKIND 1A I 12 22DSPATR(&A4OFA) A 12 24'4 of Kind' DSPATR(&A4OFB) A TOT4OFKIND 2Y 0O 12 35EDTCDE(3) DSPATR(&A4OFC) A 12 39'(Sum)' DSPATR(&A4OFD) A C121 1A O 12 49DSPATR(&C121A) A C122 1A O 12 51DSPATR(&C122A) A C123 1A O 12 53DSPATR(&C123A) A C124 1A O 12 55DSPATR(&C124A) A C221 1A O 12 58DSPATR(&C221A) A C222 1A O 12 60DSPATR(&C222A) A C223 1A O 12 62DSPATR(&C223A) A C224 1A O 12 64DSPATR(&C224A) A C321 1A O 12 67DSPATR(&C321A) A C322 1A O 12 69DSPATR(&C322A) A C323 1A O 12 71DSPATR(&C323A) A C324 1A O 12 73DSPATR(&C324A) A SEL3S 1A I 13 6DSPATR(&A3SA) A 13 8'Threes' DSPATR(&A3SB) A TOT3S 2Y 0O 13 15EDTCDE(3) DSPATR(&A3SC) A SELFULLHOU 1A I 13 22DSPATR(&AFULLA) A 13 24'Full House' DSPATR(&AFULLB) A TOTFULLHOU 2Y 0O 13 35EDTCDE(3) DSPATR(&AFULLC) A 13 39'(25)' DSPATR(&AFULLD) A C131 1A O 13 49DSPATR(&C131A) A C132 1A O 13 51DSPATR(&C132A) A C133 1A O 13 53DSPATR(&C133A) A C134 1A O 13 55DSPATR(&C134A) A C231 1A O 13 58DSPATR(&C231A) A C232 1A O 13 60DSPATR(&C232A) A C233 1A O 13 62DSPATR(&C233A) A C234 1A O 13 64DSPATR(&C234A) A C331 1A O 13 67DSPATR(&C331A) A C332 1A O 13 69DSPATR(&C332A) A C333 1A O 13 71DSPATR(&C333A) A C334 1A O 13 73DSPATR(&C334A) A SEL4S 1A I 14 6DSPATR(&A4SA) A 14 8'Fours' DSPATR(&A4SB) A TOT4S 2Y 0O 14 15EDTCDE(3) DSPATR(&A4SC) A SEL4INROW 1A I 14 22DSPATR(&A4ROWA) A 14 24'4 in Row' DSPATR(&A4ROWB) A TOT4INROW 2Y 0O 14 35EDTCDE(3) DSPATR(&A4ROWC) A 14 39'(30)' DSPATR(&A4ROWD) A C141 1A O 14 49DSPATR(&C141A) A C142 1A O 14 51DSPATR(&C142A) A C143 1A O 14 53DSPATR(&C143A) A C144 1A O 14 55DSPATR(&C144A) A C241 1A O 14 58DSPATR(&C241A) A C242 1A O 14 60DSPATR(&C242A) A C243 1A O 14 62DSPATR(&C243A) A C244 1A O 14 64DSPATR(&C244A) A C341 1A O 14 67DSPATR(&C341A) A C342 1A O 14 69DSPATR(&C342A) A C343 1A O 14 71DSPATR(&C343A) A C344 1A O 14 73DSPATR(&C344A) A SEL5S 1A I 15 6DSPATR(&A5SA) A 15 8'Fives' DSPATR(&A5SB) A TOT5S 2Y 0O 15 15EDTCDE(3) DSPATR(&A5SC) A SEL5INROW 1A I 15 22DSPATR(&A5ROWA) A 15 24'5 in Row' DSPATR(&A5ROWB) A TOT5INROW 2Y 0O 15 35EDTCDE(3) DSPATR(&A5ROWC) A 15 39'(40)' DSPATR(&A5ROWD) A C151 1A O 15 49DSPATR(&C151A) A C152 1A O 15 51DSPATR(&C152A) A C153 1A O 15 53DSPATR(&C153A) A C154 1A O 15 55DSPATR(&C154A) A C251 1A O 15 58DSPATR(&C251A) A C252 1A O 15 60DSPATR(&C252A) A C253 1A O 15 62DSPATR(&C253A) A C254 1A O 15 64DSPATR(&C254A) A C351 1A O 15 67DSPATR(&C351A) A C352 1A O 15 69DSPATR(&C352A) A C353 1A O 15 71DSPATR(&C353A) A C354 1A O 15 73DSPATR(&C354A) A SEL6S 1A I 16 6DSPATR(&A6SA) A 16 8'Sixes' DSPATR(&A6SB) A TOT6S 2Y 0O 16 15 EDTCDE(3) DSPATR(&A6SC) A SELYAHTZEE 1A I 16 22DSPATR(&AYAHA) A 16 24'Yahtzee' DSPATR(&AYAHB) A TOTYAHTZEE 2Y 0O 16 35 EDTCDE(3) DSPATR(&AYAHC) A 16 39'(50)' DSPATR(&AYAHD) A C161 1A O 16 49DSPATR(&C161A) A C162 1A O 16 51DSPATR(&C162A) A C163 1A O 16 53DSPATR(&C163A) A C164 1A O 16 55DSPATR(&C164A) A C261 1A O 16 58DSPATR(&C261A) A C262 1A O 16 60DSPATR(&C262A) A C263 1A O 16 62DSPATR(&C263A) A C264 1A O 16 64DSPATR(&C264A) A C361 1A O 16 67DSPATR(&C361A) A C362 1A O 16 69DSPATR(&C362A) A C363 1A O 16 71DSPATR(&C363A) A C364 1A O 16 73DSPATR(&C364A) A SELCHANCE 1A I 17 22DSPATR(&ACHANCEA) A 17 24'Chance' DSPATR(&ACHANCEB) A TOTCHANCE 2Y 0O 17 35EDTCDE(3) DSPATR(&ACHANCEC) A 17 39'(Sum)' DSPATR(&ACHANCED) A C171 1A O 17 49DSPATR(&C171A) A C172 1A O 17 51DSPATR(&C172A) A C173 1A O 17 53DSPATR(&C173A) A C174 1A O 17 55DSPATR(&C174A) A C271 1A O 17 58DSPATR(&C271A) A C272 1A O 17 60DSPATR(&C272A) A C273 1A O 17 62DSPATR(&C273A) A C274 1A O 17 64DSPATR(&C274A) A C371 1A O 17 67DSPATR(&C371A) A C372 1A O 17 69DSPATR(&C372A) A C373 1A O 17 71DSPATR(&C373A) A C374 1A O 17 73DSPATR(&C374A) A 18 5'UpperTot' A TOTUPPER 3Y 0O 18 14EDTCDE(3) A 19 8'Bonus' A TOTBONUS 2Y 0O 19 15EDTCDE(3) A 19 27'Total:' A TOTGRAND 3Y 0O 19 34EDTCDE(3) A 23 2'F3=Exit' COLOR(BLU) A 23 57'F9=New Game' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 //--------------------------------------------------------- // JCRGRAPH - Generate bar-chart to graphically represent data. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRGRAPHD cf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D AttrArry s 1a dim(25) based(Ptr1) D Nelems s 5u 0 D xx s 5u 0 D Ptr1 s * inz(%addr(atr01)) //--*COPY DEFINES------------------------------------------ /Define Infds /Define Dspatr /Define FunctionKeys /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS *NONE* ----------------------------------- /free evalr scDow = %trimr(f_GetDayName()); 1b dou InfdsFkey = f03; exfmt SCREEN; 2b if not (InfdsFkey = f03); clear bargph; AttrArry(*) = Green; Nelems = %unsh(value/2); 3b for xx = 1 to Nelems; %subst(bargph: xx: 1) = '>'; 3e endfor; // The idea here is more to show how neat bitor can set attributes! Nelems = %unsh(value/4); 3b for xx = 1 to Nelems; 4b if xx < 9; AttrArry(xx) = %bitor(TURQ: RI); 4x elseif xx < 18; AttrArry(xx) = %bitor(YELLOW: RI); 4x else; AttrArry(xx) = %bitor(RED: RI); 4e endif; 3e endfor; 2e endif; 1e enddo; *inlr = *on; return; ]]> v5r4 *---------------------------------------------------------------- * JCRGRAPHD - Bar graph demo - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A ATR01 1A P A ATR02 1A P A ATR03 1A P A ATR04 1A P A ATR05 1A P A ATR06 1A P A ATR07 1A P A ATR08 1A P A ATR09 1A P A ATR10 1A P A ATR11 1A P A ATR12 1A P A ATR13 1A P A ATR14 1A P A ATR15 1A P A ATR16 1A P A ATR17 1A P A ATR18 1A P A ATR19 1A P A ATR20 1A P A ATR21 1A P A ATR22 1A P A ATR23 1A P A ATR24 1A P A ATR25 1A P A 1 3'JCRGRAPH' A 1 23'Simple Bar Graph Example' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 16'Enter a numeric value to represent- A on the graph.' DSPATR(HI) A VALUE 3Y 0B 6 16EDTCDE(4) A RANGE(0 100) A CHECK(FE) A CHECK(RB) A 9 16'0 20 40 60 - A 80 100' DSPATR(HI) A 10 16'| | | | | | | - A | | | |' DSPATR(UL) A BARGPH 50A O 11 16DSPATR(HI UL) A FLD001 1A O 16 16DSPATR(&ATR01) A FLD002 1A O 16 18DSPATR(&ATR02) A FLD003 1A O 16 20DSPATR(&ATR03) A FLD004 1A O 16 22DSPATR(&ATR04) A FLD005 1A O 16 24DSPATR(&ATR05) A FLD006 1A O 16 26DSPATR(&ATR06) A FLD007 1A O 16 28DSPATR(&ATR07) A FLD008 1A O 16 30DSPATR(&ATR08) A FLD009 1A O 16 32DSPATR(&ATR09) A FLD010 1A O 16 34DSPATR(&ATR10) A FLD011 1A O 16 36DSPATR(&ATR11) A FLD012 1A O 16 38DSPATR(&ATR12) A FLD013 1A O 16 40DSPATR(&ATR13) A FLD014 1A O 16 42DSPATR(&ATR14) A FLD015 1A O 16 44DSPATR(&ATR15) A FLD016 1A O 16 46DSPATR(&ATR16) A FLD017 1A O 16 48DSPATR(&ATR17) A FLD018 1A O 16 50DSPATR(&ATR18) A FLD019 1A O 16 52DSPATR(&ATR19) A FLD020 1A O 16 54DSPATR(&ATR20) A FLD021 1A O 16 56DSPATR(&ATR21) A FLD022 1A O 16 58DSPATR(&ATR22) A FLD023 1A O 16 60DSPATR(&ATR23) A FLD024 1A O 16 62DSPATR(&ATR24) A FLD025 1A O 16 64DSPATR(&ATR25) A 17 16' - A ' DSPATR(UL) A 23 2'F3=Exit' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRHEXCHR - display biton codes to produce hex characters. // decode integer counter into pseudo-binary bit for checking. // use MI function _SETBTS to set screen character bits. // use C function _cvth to generate hex representations. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRHEXCHRDcf e workstn sfile(SBFDTA1: rrn) indds(Ind) F usropn //--*COPY DEFINES------------------------------------------ /Define Ind /Define Cvthc /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D rrn s 3u 0 D Base2Divisor s 3u 0 inz(128) D BitOn s 10u 0 D Count s 3u 0 D CountWrk s 3u 0 D SetBts PR extproc('_SETBTS') mi set bits D 1a bit string D 10u 0 value bit offset /free rrn = 0; open JCRHEXCHRD; evalr scDow = %trimr(f_GetDayName()); 1b for Count = 65 to 254; scBinVal = x'00'; scBitOn = *blanks; CountWrk = Count; reset Base2Divisor; //--------------------------------------------------------- 2b for BitOn = 0 to 7; 3b if %uns(CountWrk/Base2Divisor) = 1; //binary bit on callp SetBts(scBinVal: BitOn); scBitOn = %trimr(scBitOn) + %char(BitOn); CountWrk -= Base2Divisor; //step to next binary 4b if CountWrk = 0; //completely decoded 2v leave; 4e endif; 3e endif; Base2Divisor /= 2; 2e endfor; //--------------------------------------------------------- cvthc( %addr(scHexCode): %addr(scBinVal): 2); //make hex rrn += 1; write SBFDTA1; 1e endfor; Ind.sfldsp = *on; Ind.sfldspCtl = *on; write SBFCTL1; exfmt SFOOTER1; *inlr = *on; close JCRHEXCHRD; return; ]]> v5r4 *---------------------------------------------------------------- * JCRHEXCHRD - Hex/Biton patterns to produce characters - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SCBINVAL 1A O 3 2DSPATR(HI) A SCHEXCODE 2A O 3 5COLOR(PNK) A SCBITON 8A O 3 8COLOR(PNK) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) BLINK A *DS3 SFLLIN(0002) A *DS4 SFLLIN(0002) A SFLSIZ(256) SFLPAG(95) A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A 1 2'JCRHEXCHR' COLOR(BLU) A 1 23'HEX/BIT PATTERNS TO PRODUCE CHARAC- A TERS' DSPATR(UL HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 1'CHR' DSPATR(UL) A 2 5'HEX' DSPATR(UL) A 2 9'BITON ' DSPATR(UL) A 2 72SYSNAME COLOR(BLU) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 24 2'F3=Exit' COLOR(BLU) ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRIFSCPY - IFS installer/copy from stream file - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Install/Copy from IFS Path') PARM KWD(PATHNAME) TYPE(*CHAR) LEN(64) + DFT('/rutledgec/') MIN(0) PGM(*YES) + PROMPT('IFS Path Name:') ]]> v5r4 *---------------------------------------------------------------- * JCRIFSCPYD - IFS installer/copy from stream file - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA12 INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A HIDEXTEN 10A H A HIDFILENAM 40A H A SBFOPTION 1Y 0B 7 3EDTCDE(4) A DIRNAME 50A O 7 7 A OBJTYPE 11A O 7 58 A SBFACTION 8A O 7 71 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLPAG(15) SFLSIZ(45) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRIFSCPY' COLOR(BLU) A 1 23'Copy/Install from IFS directory' A COLOR(WHT) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2SYSNAME COLOR(BLU) A 2 72TIME COLOR(BLU) A 3 2'Type options, press Enter.' A COLOR(BLU) A 3 30'1=Copy To Stream File' COLOR(BLU) A 3 53'2=XMLPreview Install' COLOR(BLU) A 4 2'Path' COLOR(BLU) A PATHHEAD 64A O 4 7DSPATR(UL) A 6 2'Opt' DSPATR(HI) A 6 7'IFS File Name' DSPATR(HI) A 6 58'Type' DSPATR(HI) A 6 71'Action' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R WINDOW1 WINDOW(3 18 10 52 *NOMSGLIN) A WDWTITLE((*TEXT 'Copy to Stream Fil- A e') (*COLOR WHT) (*DSPATR HI)) A OVERLAY A 2 2'From Path' COLOR(PNK) A WCDIRNAME 50A O 3 2DSPATR(UL) A 5 2'To File' COLOR(PNK) A 5 14'To Lib' COLOR(PNK) A 5 26'To Mbr' COLOR(PNK) A 5 38'To Mbr Type' COLOR(PNK) A WCTOFILE 10A B 6 2DSPATR(HI) A WCTOLIB 10A B 6 14DSPATR(HI) A WCTOMBR 10A B 6 26DSPATR(HI) A WCMBRTYP 10A B 6 38DSPATR(HI) A ERRMSG 48A O 7 2DSPATR(HI) A 8 2'Enter=Proceed' COLOR(BLU) A 8 20'F12=Cancel Copy' COLOR(BLU) *---------------------------------------------------------------- A R WINDOW2 OVERLAY A WINDOW(3 18 10 52 *NOMSGLIN) A WDWTITLE((*TEXT 'XMLINSTALL') (*COL- A OR WHT) (*DSPATR HI)) A 2 2'From Path' COLOR(BLU) A WCDIRNAME 50A O 3 2DSPATR(UL) A 5 2'Install Objects To Lib' COLOR(BLU) A 5 34'Source files(s)' COLOR(BLU) A WCTOLIB 10A B 6 2DSPATR(HI) A WCTOFILE2 10A B 6 34COLOR(BLU) A ERRMSG 48A O 7 2DSPATR(HI) A 8 2'Enter=Proceed' COLOR(BLU) A 8 20'F12=Cancel Install Prompt' A COLOR(BLU) *---------------------------------------------------------------- A R ASSUME ASSUME A 1 2' ' DSPATR(ND) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) OVERLAY A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) *-WINDOW1 ERRMSG SUBFILE----------------------- A R MSGSFLW1 SFL SFLMSGRCD(09) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTLW1 SFLCTL(MSGSFLW1) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A WINDOW(WINDOW1) A PROGID SFLPGMQ(10) *-WINDOW2 ERRMSG SUBFILE----------------------- A R MSGSFLW2 SFL SFLMSGRCD(09) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTLW2 SFLCTL(MSGSFLW2) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A WINDOW(WINDOW2) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRIFSCPY'.Install/Copy from IFS Path (JCRIFSCPY) - Help .*-------------------------------------------------------------------- :P.This JCR command lists directory entries in selected IFS path name. Selection of cpyfrmstmf or utility install using xmlpreview is allowed.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRIFSCPY/PATHNAME'.IFS Path Name - Help :XH3.IFS Path Name (PATHNAME) :P.IFS path name to directory entries.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRIFSCPYR - IFS installer/copy from stream file // Use 'Unix-API's to retrieve IFS directory entries. // Open Directory openDir() // Opendir() function opens directory so that it can be // read with readdir() function. // Functions readdir(), rewinddir(), and closedir() can be called after // successful call to opendir(). First readdir() call reads first directory entry // // Read Directory readDir() returns pointer to dirent // structure describing next directory entry in directory stream. // Close Directory closeDir() closes directory stream indicated by pdir handle // Load entries into subfile. // Process user selections. // 1. Copy to selected member // 2. Run XMLPREVIEW and install. // // This utility was originally intended to make it easy to upload source // members, but it can also be used to upload to data files. In that // case I want to check max number of members allowed. If only 1, // then overlay member name in upload prompt with data files member. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRIFSCPYDcf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D pDir s * D errFlag s 10i 0 D dirName s 50a D EntryName s 1024a D xx s 10i 0 D AlphaString s 500a varying D IsSecondTime s n D TempName s 16a based(pTempName) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define System /Define f_RmvSflMsg /Define f_BuildString /Define f_SndCompMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_GetDayName /Define Qdbrtvfd /Define Fild0100ds /Define f_Qusrmbrd /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- B // structure must be aligned since C struct does NOT have _Packed. D d_dirEnt ds based(pDirEnt ) align D d_Reserved1 16a D d_Fileno_id 10u 0 D d_Fileno 10u 0 D d_Reclen 10u 0 D d_Reserved2 10i 0 D d_Reserved3 8a D d_nlsinfo like(qlg_nls_t) D d_namelen 10u 0 D d_name 640a D nlink_t 5u 0 // structure must be aligned since C struct does NOT have _Packed. D qlg_nls_t DS inz align D ccsid 10i 0 D Country_id 2a D language_id 3a D nls_Reserved 3a // structure must be aligned since C struct does NOT have _Packed. D st_stat DS inz align D st_mode 10u 0 D st_ino 10u 0 D st_nlink 5u 0 D st_uid 10u 0 D st_gid 10u 0 D st_size 10u 0 D st_atime 10u 0 D st_mtime 10u 0 D st_ctime 10u 0 D st_dev 10u 0 D st_blksize 10u 0 D st_allocsize 10u 0 D st_ObjType 11a D st_codepage 5u 0 D st_Reservedl 62a D st_ino_gen_id 10u 0 //--*CALL PROTOTYPES--------------------------------------- D openDir PR * extproc('opendir') D * value options(*string) D readDir PR * extproc('readdir') D * value D closeDir PR 10i 0 extproc('closedir') D * value D getFileInf PR 10i 0 extproc('stat') D * value options(*string) D * value D getTempName PR * extproc('tmpnam') D * value //--*ENTRY PARMS------------------------------------------- D p_JCRIFSCPYR PR extpgm('JCRIFSCPYR') D 64a D p_JCRIFSCPYR PI D p_IfsDir 64a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); SflRcdNbr = 1; 1b if %subst(p_IfsDir: 1: 1) <> '/'; p_IfsDir = '/' + p_IfsDir; 1e endif; clear wctoLib; clear wctoFile; wctoFile2 = '*DEFAULTS'; clear wctoMbr; clear wcMbrTyp; PathHead = p_IfsDir; f_SndStatMsg('List files in path ' + %trimr(p_IfsDir) + ' - in progress.'); pDir = openDir(%trim(p_IfsDir)); 1b if pDir = *null; f_SndSflMsg(ProgId: 'Error Found on OPEN DIRECTORY. Check path name.'); 1x else; f_SndSflMsg(ProgId: 'Select option and press Enter key.'); pDirEnt = readDir(pDir); 2b dow pDirEnt <> *null; dirName = %subst(d_name: 1: d_nameLen); 3b if %subst(dirname: 1: 1) <> '.'; // ... get file information stat() EntryName = %trim(p_IfsDir) + '/' + dirName; errFlag = getFileInf(%trim(EntryName) : %addr(st_stat)); ObjType = %str(%addr(st_ObjType)); // extract file extension to allow future // sorting by extension types clear hidExten; clear hidFileNam; aa = %scan('.': dirName); 4b if aa > 1; hidExten = %subst(dirName: aa + 1); hidFileNam = %subst(dirName: 1: aa - 1); 4x else; hidFileNam = dirName; 4e endif; rrn += 1; write SBFDTA1; 3e endif; pDirEnt = readDir(pDir); 2e enddo; 2b if rrn = 0; f_SndSflMsg(ProgId: 'No entries found in selected directory.'); 2e endif; errFlag = closeDir(pDir); 1e endif; // allow user to make selection from subfile. Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b dow not (InfdsFkey = f03); write SBFCTL1; write MSGCTL; exfmt SFOOTER1; 2b if not Ind.sfldsp or InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; f_RmvSflMsg(ProgId); // selected function. readc SBFDTA1; 2b dow not %eof; 3b if sbfOption > 0; 4b if sbfOption = 1 or sbfOption = 2; exsr srExecuteOpts; 4x else; f_SndSflMsg(ProgId: 'Option ' + %char(sbfOption) + ' is not defined.'); 4e endif; clear sbfOption; update SBFDTA1; 3e endif; SflRcdNbr = rrn; readc SBFDTA1; 2e enddo; 1e enddo; f_SndCompMsg('JCRIFSCPY for path '+%trimr(p_IfsDir)+' - completed.'); *inlr = *on; return; //--------------------------------------------------------- // Execute system command depending of option selected. begsr srExecuteOpts; IsSecondTime = *off; f_RmvSflMsg(ProgId); wcdirname = %trimr(p_IfsDir) + '/' + dirname; 1b if sbfOption = 1; //cpytostmf wctoMbr = %xlate(lo: up: hidFileNam); wcMbrTyp = %xlate(lo: up: hidExten); 2b dou 1 = 2; 3b if IsSecondTime; write msgctlw1; 3e endif; IsSecondTime = *on; exfmt WINDOW1; f_RmvSflMsg(ProgId); 3b if not (InfdsFkey = f03 or InfdsFkey = f12); 4b if wctoLib = *blanks or system('CHKOBJ OBJ(' + %trimr(wctoLib) + ') OBJTYPE(*LIB)') > 0; f_SndSflMsg(ProgId: 'To Library ' + %trimr(wctoLib) + ' Not Valid.'); 2i iter; 4x elseif wctoFile = *blanks or system('CHKOBJ OBJ(' + %trimr(wctoLib) + '/' + %trimr(wctoFile) + ') OBJTYPE(*FILE)') > 0; f_SndSflMsg(ProgId: 'To File ' + %trimr(wctoFile) + ' Not Valid.'); 2i iter; 4x elseif wctoMbr = *blanks; f_SndSflMsg(ProgId: 'To Member must be entered.'); 2i iter; 4x else; //--------------------------------------------------------- // If uploading to data files, I want to check max //number of members allowed. If only 1 member is allowed, // then overlay member name in upload prompt with data files member. Fild0100ptr = %alloc(400); callp QDBRTVFD( Fild0100ds : 400 : ReturnFileQual : 'FILD0100' : wctoFile + wctoLib: '*FIRST ' : '0' : '*FILETYPE ': '*EXT ': ApiErrDS); 5b if Fild0100ds.MaxMbrs = 1; QusrmbrdDS = f_Qusrmbrd( wctoFile + wctoLib: '*FIRST ': 'MBRD0100'); wctoMbr = QusrmbrdDS.Mbr; 5e endif; dealloc Fild0100ptr; 4e endif; AlphaString = ('?CPYFRMSTMF FROMSTMF(' + qs + %trimr(%xlate(up: lo: wcdirname)) + qs + ') toMbr(' + qs + '/qsys.Lib/' + %trimr(wctoLib) + '.Lib/' + %trimr(wctoFile) + '.file/' + %trimr(wctoMbr) + '.mbr' + qs + ') '); xx = system(AlphaString); AlphaString = ('CHGPFM FILE(' + %trimr(wctoLib) + '/' + %trimr(wctoFile) + ') ' + 'MBR(' + %trimr(wctoMbr) + ') SRCTYPE(' + %trimr(wcMbrTyp) + ') TEXT(' + qs + 'member created by jcr JCRIFSCPY' + qs + ')'); xx = system(AlphaString); // load message to screen sbfAction = '*COPIED'; f_SndSflMsg(ProgId: f_BuildString('File & copied to & in library &.': dirname: wctoFile: wctoLib)); 3x else; sbfAction = *blanks; f_SndSflMsg(ProgId: 'Copy Canceled.'); 3e endif; 2v leave; 2e enddo; 1x elseif sbfOption = 2; //xmlpreview //--------------------------------------------------------- // tmpnam() get temporary name // produces valid file name that is not the same as name of any existing file. // It stores this name in pTempName. If pTempName is NULL, tmpnam leaves result in // an internal static buffer. // // Tmpnam function produces different name each time it is called within activation group // In AS/400 Data Management, tmpnam function creates new file named QTEMP/QACXxxxx //--------------------------------------------------------- pTempName = getTempName(*null); 2b if pTempName <> *null; 3b dou 1 = 2; 4b if IsSecondTime; write msgctlw2; 4e endif; IsSecondTime = *on; exfmt WINDOW2; f_RmvSflMsg(ProgId); 4b if not (InfdsFkey = f03 or InfdsFkey = f12); 5b if wctoLib = *blanks or system('CHKOBJ OBJ(' + %trimr(wctoLib) + ') OBJTYPE(*LIB)') > 0; f_SndSflMsg(ProgId: 'To Library ' + %trimr(wctoLib) + ' Not Valid.'); 3i iter; 5e endif; AlphaString = 'CRTSRCPF FILE(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ') RCDLEN(112) MBR(' + %subst(TempName: 7) + ') TEXT(' + qs + 'TEMP JCRIFSCPY' + qs + ')'; xx = system(AlphaString); AlphaString = 'CPYFRMSTMF FROMSTMF(' + qs + %trimr(%xlate(up: lo: wcdirname)) + qs + ') toMbr(' + qs + '/qsys.Lib/' + %trimr(wctoLib) + '.Lib/' + %subst(TempName: 7) + '.file/' + %subst(TempName: 7) + '.mbr' + qs + ') MBROPT(*REPLACE) CVTDTA(*AUTO)'; xx = system(AlphaString); AlphaString = 'XMLPREVIEW UPLOADMBR(' + %subst(TempName: 7) + ') UPLOADSRCF(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ') OUTPUTSRCF(' + %trimr(wctoFile2) + ')'; xx = system(AlphaString); AlphaString = 'DLTF FILE(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ')'; xx = system(AlphaString); // load message to screen sbfAction = '*INSTALLED'; f_SndSflMsg(ProgId: f_BuildString('File & copy/installed to & in library &.': dirname: wctoFile: wctoLib)); 4x else; sbfAction = *blanks; f_SndSflMsg(ProgId: 'Install Canceled.'); 4e endif; 3v leave; 3e enddo; 2e endif; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRIFSMBRV - Validity checking program with verify directory //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D pDir s * //--*CALL PROTOTYPES--------------------------------------- D openDir PR * extproc('opendir') D * value options(*string) D closeDir PR 10i 0 extproc('closedir') D * value //--*ENTRY PARMS------------------------------------------- D p_JCRIFSCPYV PR extpgm('JCRIFSCPYV') D 64a D p_JCRIFSCPYV PI D p_IfsDir 64a //--------------------------------------------------------- /free pDir = openDir(%trim(p_IfsDir)); 1b if pDir = *null; f_SndEscapeMsg('Error found on OPEN DIRECTORY. Check path name.'); 1x else; closeDir(pDir); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRIFSMBR - Copy source member to stream file IFS and zip - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Copy member to IFS Drive') PARM KWD(MBR) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('Member name:') PARM KWD(FILE) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('File name:') PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('Library name:') PARM KWD(ATTRIBUTE) TYPE(*CHAR) LEN(10) MIN(1) + PGM(*YES) CHOICE('RPGLE, CLP, DSPF, PRTF, + etc..') PROMPT('Member Attribute:') PARM KWD(DIRECTORY) TYPE(*CHAR) LEN(50) MIN(0) PROMPT('IFS Directory path:') PARM KWD(ZIPFILE) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Also + create .ZIP file:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRIFSMBR'.Copy Member to IFS Drive (JCRIFSMBR) - Help .*-------------------------------------------------------------------- :P.This JCR command copies selected source member to selected directory on IFS drive. It optionally uses Qshell JAR command to create .zip file from copied source member. :P.After execution you will have .txt file and .zip file in selected directory.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRIFSMBR/MBR'.Member Name - Help :XH3.Member Name (MBR) :P.Member to be copied to IFS directory:EHELP. :HELP NAME='JCRIFSMBR/FILE'.File Name - Help :XH3.File Name (FILE) :P.Source file containing member.:EHELP. :HELP NAME='JCRIFSMBR/LIBRARY'.Library Name - Help :XH3.Library Name (LIBRARY) :P.Library name containing source file.:EHELP. :HELP NAME='JCRIFSMBR/ATTRIBUTE'.Member Attribute - Help :XH3.Attribute (ATTRIBUTE) :P.Member type (CLLE, RPGLE, etc..):EHELP. :HELP NAME='JCRIFSMBR/DIRECTORY'.IFS Directory Path - Help :XH3.Directory (PATH) :P.Copy to IFS directory name.:EHELP. :HELP NAME='JCRIFSMBR/ZIPFILE'.Create Zip File - Help :XH3.Zip File (ZIPFILE) :P.Create .zip file of downloaded member.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRIFSMBRR - Copy source member to stream file IFS and zip // Build copy to stream file command to download files to my IFS directory. // call qsh to .zip the file, then delete the original. // // Set up a PDM option to be CALL JCRIFSMBRR PARM(&N &F &L &S '/jcr/') // then you can place your PDM option beside any member. // NOTE: replace '/jcr/' with your IFS drive folder. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define Constants /Define f_BuildString /Define f_System /Define f_SndStatMsg /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D String s 500a //--*ENTRY PARMS------------------------------------------- D p_JCRIFSMBRR PR extpgm('JCRIFSMBRR') D 10a D 10a D 10a D 10a D 50a D 4a D p_JCRIFSMBRR PI D p_SrcMbr 10a D p_SrcFile 10a D p_SrcLib 10a D p_SrcAttr 10a D p_IfsDir 50a D p_CreateZip 4a //--------------------------------------------------------- /free f_SndStatMsg('Copying member ' + %trimr(p_SrcMbr) + ' to IFS directory ' + %trimr(p_IfsDir) ); // make all lower case p_SrcMbr = %xlate(up: lo: p_SrcMbr); p_SrcFile = %xlate(up: lo: p_SrcFile); p_SrcLib = %xlate(up: lo: p_SrcLib); p_SrcAttr = %xlate(up: lo: p_SrcAttr); p_IfsDir = %xlate(up: lo: p_IfsDir); // copy to stream file command f_System(f_BuildString( 'CPYTOSTMF FROMMBR(&Q/qsys.lib/&.lib/&.file/&.mbr&Q) + TOSTMF(&Q&&.&&Q) STMFOPT(*REPLACE) STMFCODPAG(*PCASCII)': p_SrcLib: p_SrcFile: p_SrcMbr: p_IfsDir: p_SrcMbr: p_SrcAttr)); 1b if p_CreateZip = '*YES'; f_SndStatMsg('Zipping file ' + %trimr(p_SrcMbr) + '.' + %trimr(p_SrcAttr) + ' in IFS directory ' + %trimr(p_IfsDir) ); f_System(f_BuildString( 'QSH CMD(&Qjar -cfM /&&.zip /&&.&&Q)': p_IfsDir: p_SrcMbr: p_IfsDir: p_SrcMbr: p_SrcAttr)); // delete plain text // bldexc = 'QSH CMD(' + qs + // 'rm /' + %trimr(p_IfsDir) + // %trimr(p_SrcMbr) + '.' + // %trimr(p_SrcAttr) + qs + ') ' // f_system(bldexc); 1e endif; f_SndCompMsg('Member ' + %trimr(p_SrcMbr) + '.' + %trimr(p_SrcAttr) + ' copy to IFS directory ' + %trimr(p_IfsDir) + ' - Completed.'); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRIFSMBRV - Validity checking program with verify directory //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D pDir s * //--*CALL PROTOTYPES--------------------------------------- D openDir PR * extproc('opendir') D * value options(*string) D closeDir PR 10i 0 extproc('closedir') D * value //--*ENTRY PARMS------------------------------------------- D p_JCRIFSMBRV PR extpgm('JCRIFSMBRV') D 10a D 10a D 10a D 10a D 50a D 4a D p_JCRIFSMBRV PI D p_SrcMbr 10a D p_SrcFil 10a D p_SrcLib 10a D p_SrcAttr 10a D p_IfsDir 50a D p_CreateZip 4a //--------------------------------------------------------- /free f_CheckMbr(p_SrcFil + p_SrcLib : p_SrcMbr); pDir = openDir(%trim(p_IfsDir)); 1b if pDir = *null; f_SndEscapeMsg('Error found on OPEN DIRECTORY. Check path name.'); 1x else; closeDir(pDir); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRIFSSAV - Copy savf to stream file IFS and zip - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Copy SAVF to IFS Drive and.zip') PARM KWD(SAVF) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('Save file name:') PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('Library name:') PARM KWD(DIRECTORY) TYPE(*CHAR) LEN(50) + DFT('/jcr/') MIN(0) PROMPT('IFS Directory path:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRIFSSAV'.Copy SAVF to IFS Drive and.zip (JCRIFSSAV) - Help .*-------------------------------------------------------------------- :P.This JCR command copies selected savf to selected directory on IFS drive. It uses the Qshell JAR command to create .zip file from copied source member. :P.After execution you will have .savf file and .zip file in selected directory.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRIFSSAV/SAVF'.Save File Name - Help :XH3.File Name (FILE) :P.Savf name.:EHELP. :HELP NAME='JCRIFSSAV/LIBRARY'.Library Name - Help :XH3.Library Name (LIBRARY) :P.Library name.:EHELP. :HELP NAME='JCRIFSSAV/DIRECTORY'.IFS Directory Path - Help :XH3.Directory (DIRECTORY) :P.Copy to IFS directory name.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRIFSSAVR - Copy savf to stream file IFS and zip // Build copy to stream file command to download savf to my IFS directory. // call qsh to .zip the file, then delete original. // // Set up your PDM option to be CALL JCRIFSSAVR PARM(&F &L 'jcr/') // replacing 'jcr/' with your IFS drive folder. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define Constants /Define f_system /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D String s 500a //--*ENTRY PARMS------------------------------------------- D p_JCRIFSSAVR PR extpgm('JCRIFSSAVR') D 10a D 10a D 50a D p_JCRIFSSAVR PI D p_Savf 10a D p_Lib 10a D p_IfsDir 50a //--------------------------------------------------------- /free // make lower case p_Savf = %xlate(up: lo: p_Savf); p_Lib = %xlate(up: lo: p_Lib); p_IfsDir = %xlate(up: lo: p_IfsDir); //--------------------------------------------------------- // build copy to stream file command String = 'CPYTOSTMF FROMMBR(' + qs + '/qsys.lib/' + %trimr(p_Lib) + '.lib/' + %trimr(p_Savf) + '.file' + qs + ') ' + 'TOSTMF(' + qs + %trimr(p_IfsDir) + %trimr(p_Savf) + qs + ') ' + 'STMFOPT(*REPLACE) CVTDTA(*NONE) STMFCODPAG(*STMF) ' + 'ENDLINFMT(*FIXED)'; f_system(String); //--------------------------------------------------------- // zip String = 'QSH CMD(' + qs + 'jar -cfM /' + %trimr(p_IfsDir) + %trimr(p_Savf) + '.zip /' + %trimr(p_IfsDir) + %trimr(p_Savf) + qs + ') '; f_system(String); //--------------------------------------------------------- // delete original savf String = 'QSH CMD(' + qs + 'rm /' + %trimr(p_IfsDir) + %trimr(p_Savf) + qs + ') '; f_system(String); f_SndCompMsg('Save file ' + %trimr(p_Savf) + ' copy to IFS directory ' + %trimr(p_IfsDir) + ' - Completed.'); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRIFSSAVV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D pDir s * //--*CALL PROTOTYPES--------------------------------------- D openDir PR * extproc('opendir') D * value options(*string) path D closeDir PR 10i 0 extproc('closedir') D * value handle //--*ENTRY PARMS------------------------------------------- D p_JCRIFSSAVV PR extpgm('JCRIFSSAVV') D 10a D 10a D 50a D p_JCRIFSSAVV PI D p_Savf 10a D p_Lib 10a D p_IfsDir 50a //--------------------------------------------------------- /free f_CheckObj(p_Savf + p_Lib : '*FILE' ); pDir = openDir(%trim(p_IfsDir)); 1b if pDir = *null; f_SndEscapeMsg('Error found on OPEN DIRECTORY. Check path name.'); 1x else; closeDir(pDir); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRIND - List Indicators used in source code - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Indicators Used') PARM KWD(SRCMBR) TYPE(SRCMBR) MIN(1) MAX(3) PROMPT('Source') SRCMBR: ELEM TYPE(*NAME) LEN(10) PROMPT('Mbr') ELEM TYPE(MBR) PROMPT(' File') MBR: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library') ]]> v5r4 *---------------------------------------------------------------- * JCRINDD - List Indicators used in source code - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN BLINK A ATR0C01 1A P A ATR0C02 1A P A ATR0C03 1A P A ATR0C04 1A P A ATR0C05 1A P A ATR0C06 1A P A ATR0C07 1A P A ATR0C08 1A P A ATR0C09 1A P A ATR0C10 1A P A ATR0C11 1A P A ATR0C12 1A P A ATR0C13 1A P A ATR0C14 1A P A ATR0C15 1A P A ATR0C16 1A P A ATR0C17 1A P A ATR0C18 1A P A ATR1C01 1A P A ATR1C02 1A P A ATR1C03 1A P A ATR1C04 1A P A ATR1C05 1A P A ATR1C06 1A P A ATR1C07 1A P A ATR1C08 1A P A ATR1C09 1A P A ATR1C10 1A P A ATR1C11 1A P A ATR1C12 1A P A ATR1C13 1A P A ATR1C14 1A P A ATR1C15 1A P A ATR1C16 1A P A ATR1C17 1A P A ATR1C18 1A P A ATR2C01 1A P A ATR2C02 1A P A ATR2C03 1A P A ATR2C04 1A P A ATR2C05 1A P A ATR2C06 1A P A ATR2C07 1A P A ATR2C08 1A P A ATR2C09 1A P A ATR2C10 1A P A ATR2C11 1A P A ATR2C12 1A P A ATR2C13 1A P A ATR2C14 1A P A ATR2C15 1A P A ATR2C16 1A P A ATR2C17 1A P A ATR2C18 1A P A ATR3C01 1A P A ATR3C02 1A P A ATR3C03 1A P A ATR3C04 1A P A ATR3C05 1A P A ATR3C06 1A P A ATR3C07 1A P A ATR3C08 1A P A ATR3C09 1A P A ATR3C10 1A P A ATR3C11 1A P A ATR3C12 1A P A ATR3C13 1A P A ATR3C14 1A P A ATR3C15 1A P A ATR3C16 1A P A ATR3C17 1A P A ATR3C18 1A P A ATR4C01 1A P A ATR4C02 1A P A ATR4C03 1A P A ATR4C04 1A P A ATR4C05 1A P A ATR4C06 1A P A ATR4C07 1A P A ATR4C08 1A P A ATR4C09 1A P A ATR4C10 1A P A ATR4C11 1A P A ATR4C12 1A P A ATR4C13 1A P A ATR4C14 1A P A ATR4C15 1A P A ATR4C16 1A P A ATR4C17 1A P A ATR4C18 1A P A ATR5C01 1A P A ATR5C02 1A P A ATR5C03 1A P A ATR5C04 1A P A ATR5C05 1A P A ATR5C06 1A P A ATR5C07 1A P A ATR5C08 1A P A ATR5C09 1A P A ATR5C10 1A P A ATR5C11 1A P A ATR5C12 1A P A ATR5C13 1A P A ATR5C14 1A P A ATR5C15 1A P A ATR5C16 1A P A ATR5C17 1A P A ATR5C18 1A P A ATR6C01 1A P A ATR6C02 1A P A ATR6C03 1A P A ATR6C04 1A P A ATR6C05 1A P A ATR6C06 1A P A ATR6C07 1A P A ATR6C08 1A P A ATR6C09 1A P A ATR6C10 1A P A ATR6C11 1A P A ATR6C12 1A P A ATR6C13 1A P A ATR6C14 1A P A ATR6C15 1A P A ATR6C16 1A P A ATR6C17 1A P A ATR6C18 1A P A ATR7C01 1A P A ATR7C02 1A P A ATR7C03 1A P A ATR7C04 1A P A ATR7C05 1A P A ATR7C06 1A P A ATR7C07 1A P A ATR7C08 1A P A ATR7C09 1A P A ATR7C10 1A P A ATR7C11 1A P A ATR7C12 1A P A ATR7C13 1A P A ATR7C14 1A P A ATR7C15 1A P A ATR7C16 1A P A ATR7C17 1A P A ATR7C18 1A P A ATR8C01 1A P A ATR8C02 1A P A ATR8C03 1A P A ATR8C04 1A P A ATR8C05 1A P A ATR8C06 1A P A ATR8C07 1A P A ATR8C08 1A P A ATR8C09 1A P A ATR8C10 1A P A ATR8C11 1A P A ATR8C12 1A P A ATR8C13 1A P A ATR8C14 1A P A ATR8C15 1A P A ATR8C16 1A P A ATR8C17 1A P A ATR8C18 1A P A ATR9C01 1A P A ATR9C02 1A P A ATR9C03 1A P A ATR9C04 1A P A ATR9C05 1A P A ATR9C06 1A P A ATR9C07 1A P A ATR9C08 1A P A ATR9C09 1A P A ATR9C10 1A P A ATR9C11 1A P A ATR9C12 1A P A ATR9C13 1A P A ATR9C14 1A P A ATR9C15 1A P A ATR9C16 1A P A ATR9C17 1A P A ATR9C18 1A P A ATR10C01 1A P A ATR10C02 1A P A ATR10C03 1A P A ATR10C04 1A P A ATR10C05 1A P A ATR10C06 1A P A ATR10C07 1A P A ATR10C08 1A P A ATR10C09 1A P A ATR10C10 1A P A ATR10C11 1A P A ATR10C12 1A P A ATR10C13 1A P A ATR10C14 1A P A ATR10C15 1A P A ATR10C16 1A P A ATR10C17 1A P A ATR10C18 1A P A ATR11C01 1A P A ATR11C02 1A P A ATR11C03 1A P A ATR11C04 1A P A ATR11C05 1A P A ATR11C06 1A P A ATR11C07 1A P A ATR11C08 1A P A ATR11C09 1A P A ATR11C10 1A P A ATR11C11 1A P A ATR11C12 1A P A ATR11C13 1A P A ATR11C14 1A P A ATR11C15 1A P A ATR11C16 1A P A ATR11C17 1A P A ATR11C18 1A P *---------------------------------------------------------------- A 1 2'JCRIND' COLOR(BLU) A 1 22'List Indicators Used' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A SCOBJHEAD1 68A O 2 2 A 2 72SYSNAME COLOR(BLU) A SCOBJHEAD2 68A O 3 6 A SCOBJHEAD3 68A O 4 6 A 4 74'LR 1P' COLOR(BLU) A 5 5' 01 10 20 30 40 50 60 70 - A 80 90 L0 KA KM OA M1 U1 H1 - A RT ' COLOR(BLU) DSPATR(UL) A 6 2'0' COLOR(PNK) A 6 4'|' COLOR(BLU) A R0C01 2A O 6 7DSPATR(&ATR0C01) A R0C02 2A O 6 11DSPATR(&ATR0C02) A R0C03 2A O 6 15DSPATR(&ATR0C03) A R0C04 2A O 6 19DSPATR(&ATR0C04) A R0C05 2A O 6 23DSPATR(&ATR0C05) A R0C06 2A O 6 27DSPATR(&ATR0C06) A R0C07 2A O 6 31DSPATR(&ATR0C07) A R0C08 2A O 6 35DSPATR(&ATR0C08) A R0C09 2A O 6 39DSPATR(&ATR0C09) A R0C10 2A O 6 43DSPATR(&ATR0C10) A R0C11 2A O 6 47DSPATR(&ATR0C11) A R0C12 2A O 6 51DSPATR(&ATR0C12) A R0C13 2A O 6 55DSPATR(&ATR0C13) A R0C14 2A O 6 59DSPATR(&ATR0C14) A R0C15 2A O 6 63DSPATR(&ATR0C15) A R0C16 2A O 6 67DSPATR(&ATR0C16) A R0C17 2A O 6 71DSPATR(&ATR0C17) A R0C18 2A O 6 75DSPATR(&ATR0C18) A 6 78'|' COLOR(BLU) A 7 2'1' COLOR(PNK) A 7 4'|' COLOR(BLU) A R1C01 2A O 7 7DSPATR(&ATR1C01) A R1C02 2A O 7 11DSPATR(&ATR1C02) A R1C03 2A O 7 15DSPATR(&ATR1C03) A R1C04 2A O 7 19DSPATR(&ATR1C04) A R1C05 2A O 7 23DSPATR(&ATR1C05) A R1C06 2A O 7 27DSPATR(&ATR1C06) A R1C07 2A O 7 31DSPATR(&ATR1C07) A R1C08 2A O 7 35DSPATR(&ATR1C08) A R1C09 2A O 7 39DSPATR(&ATR1C09) A R1C10 2A O 7 43DSPATR(&ATR1C10) A R1C11 2A O 7 47DSPATR(&ATR1C11) A R1C12 2A O 7 51DSPATR(&ATR1C12) A R1C13 2A O 7 55DSPATR(&ATR1C13) A R1C14 2A O 7 59DSPATR(&ATR1C14) A R1C15 2A O 7 63DSPATR(&ATR1C15) A R1C16 2A O 7 67DSPATR(&ATR1C16) A R1C17 2A O 7 71DSPATR(&ATR1C17) A R1C18 2A O 7 75DSPATR(&ATR1C18) A 7 78'|' COLOR(BLU) A 8 2'2' COLOR(PNK) A 8 4'|' COLOR(BLU) A R2C01 2A O 8 7DSPATR(&ATR2C01) A R2C02 2A O 8 11DSPATR(&ATR2C02) A R2C03 2A O 8 15DSPATR(&ATR2C03) A R2C04 2A O 8 19DSPATR(&ATR2C04) A R2C05 2A O 8 23DSPATR(&ATR2C05) A R2C06 2A O 8 27DSPATR(&ATR2C06) A R2C07 2A O 8 31DSPATR(&ATR2C07) A R2C08 2A O 8 35DSPATR(&ATR2C08) A R2C09 2A O 8 39DSPATR(&ATR2C09) A R2C10 2A O 8 43DSPATR(&ATR2C10) A R2C11 2A O 8 47DSPATR(&ATR2C11) A R2C12 2A O 8 51DSPATR(&ATR2C12) A R2C13 2A O 8 55DSPATR(&ATR2C13) A R2C14 2A O 8 59DSPATR(&ATR2C14) A R2C15 2A O 8 63DSPATR(&ATR2C15) A R2C16 2A O 8 67DSPATR(&ATR2C16) A R2C17 2A O 8 71DSPATR(&ATR2C17) A R2C18 2A O 8 75DSPATR(&ATR2C18) A 8 78'|' COLOR(BLU) A 9 2'3' COLOR(PNK) A 9 4'|' COLOR(BLU) A R3C01 2A O 9 7DSPATR(&ATR3C01) A R3C02 2A O 9 11DSPATR(&ATR3C02) A R3C03 2A O 9 15DSPATR(&ATR3C03) A R3C04 2A O 9 19DSPATR(&ATR3C04) A R3C05 2A O 9 23DSPATR(&ATR3C05) A R3C06 2A O 9 27DSPATR(&ATR3C06) A R3C07 2A O 9 31DSPATR(&ATR3C07) A R3C08 2A O 9 35DSPATR(&ATR3C08) A R3C09 2A O 9 39DSPATR(&ATR3C09) A R3C10 2A O 9 43DSPATR(&ATR3C10) A R3C11 2A O 9 47DSPATR(&ATR3C11) A R3C12 2A O 9 51DSPATR(&ATR3C12) A R3C13 2A O 9 55DSPATR(&ATR3C13) A R3C14 2A O 9 59DSPATR(&ATR3C14) A R3C15 2A O 9 63DSPATR(&ATR3C15) A R3C16 2A O 9 67DSPATR(&ATR3C16) A R3C17 2A O 9 71DSPATR(&ATR3C17) A R3C18 2A O 9 75DSPATR(&ATR3C18) A 9 78'|' COLOR(BLU) A 10 2'4' COLOR(PNK) A 10 4'|' COLOR(BLU) A R4C01 2A O 10 7DSPATR(&ATR4C01) A R4C02 2A O 10 11DSPATR(&ATR4C02) A R4C03 2A O 10 15DSPATR(&ATR4C03) A R4C04 2A O 10 19DSPATR(&ATR4C04) A R4C05 2A O 10 23DSPATR(&ATR4C05) A R4C06 2A O 10 27DSPATR(&ATR4C06) A R4C07 2A O 10 31DSPATR(&ATR4C07) A R4C08 2A O 10 35DSPATR(&ATR4C08) A R4C09 2A O 10 39DSPATR(&ATR4C09) A R4C10 2A O 10 43DSPATR(&ATR4C10) A R4C11 2A O 10 47DSPATR(&ATR4C11) A R4C12 2A O 10 51DSPATR(&ATR4C12) A R4C13 2A O 10 55DSPATR(&ATR4C13) A R4C14 2A O 10 59DSPATR(&ATR4C14) A R4C15 2A O 10 63DSPATR(&ATR4C15) A R4C16 2A O 10 67DSPATR(&ATR4C16) A R4C17 2A O 10 71DSPATR(&ATR4C17) A R4C18 2A O 10 75DSPATR(&ATR4C18) A 10 78'|' COLOR(BLU) A 11 2'5' COLOR(PNK) A 11 4'|' COLOR(BLU) A R5C01 2A O 11 7DSPATR(&ATR5C01) A R5C02 2A O 11 11DSPATR(&ATR5C02) A R5C03 2A O 11 15DSPATR(&ATR5C03) A R5C04 2A O 11 19DSPATR(&ATR5C04) A R5C05 2A O 11 23DSPATR(&ATR5C05) A R5C06 2A O 11 27DSPATR(&ATR5C06) A R5C07 2A O 11 31DSPATR(&ATR5C07) A R5C08 2A O 11 35DSPATR(&ATR5C08) A R5C09 2A O 11 39DSPATR(&ATR5C09) A R5C10 2A O 11 43DSPATR(&ATR5C10) A R5C11 2A O 11 47DSPATR(&ATR5C11) A R5C12 2A O 11 51DSPATR(&ATR5C12) A R5C13 2A O 11 55DSPATR(&ATR5C13) A R5C14 2A O 11 59DSPATR(&ATR5C14) A R5C15 2A O 11 63DSPATR(&ATR5C15) A R5C16 2A O 11 67DSPATR(&ATR5C16) A R5C17 2A O 11 71DSPATR(&ATR5C17) A R5C18 2A O 11 75DSPATR(&ATR5C18) A 11 78'|' COLOR(BLU) A 12 2'6' COLOR(PNK) A 12 4'|' COLOR(BLU) A R6C01 2A O 12 7DSPATR(&ATR6C01) A R6C02 2A O 12 11DSPATR(&ATR6C02) A R6C03 2A O 12 15DSPATR(&ATR6C03) A R6C04 2A O 12 19DSPATR(&ATR6C04) A R6C05 2A O 12 23DSPATR(&ATR6C05) A R6C06 2A O 12 27DSPATR(&ATR6C06) A R6C07 2A O 12 31DSPATR(&ATR6C07) A R6C08 2A O 12 35DSPATR(&ATR6C08) A R6C09 2A O 12 39DSPATR(&ATR6C09) A R6C10 2A O 12 43DSPATR(&ATR6C10) A R6C11 2A O 12 47DSPATR(&ATR6C11) A R6C12 2A O 12 51DSPATR(&ATR6C12) A R6C13 2A O 12 55DSPATR(&ATR6C13) A R6C14 2A O 12 59DSPATR(&ATR6C14) A R6C15 2A O 12 63DSPATR(&ATR6C15) A R6C16 2A O 12 67DSPATR(&ATR6C16) A R6C17 2A O 12 71DSPATR(&ATR6C17) A R6C18 2A O 12 75DSPATR(&ATR6C18) A 12 78'|' COLOR(BLU) A 13 2'7' COLOR(PNK) A 13 4'|' COLOR(BLU) A R7C01 2A O 13 7DSPATR(&ATR7C01) A R7C02 2A O 13 11DSPATR(&ATR7C02) A R7C03 2A O 13 15DSPATR(&ATR7C03) A R7C04 2A O 13 19DSPATR(&ATR7C04) A R7C05 2A O 13 23DSPATR(&ATR7C05) A R7C06 2A O 13 27DSPATR(&ATR7C06) A R7C07 2A O 13 31DSPATR(&ATR7C07) A R7C08 2A O 13 35DSPATR(&ATR7C08) A R7C09 2A O 13 39DSPATR(&ATR7C09) A R7C10 2A O 13 43DSPATR(&ATR7C10) A R7C11 2A O 13 47DSPATR(&ATR7C11) A R7C12 2A O 13 51DSPATR(&ATR7C12) A R7C13 2A O 13 55DSPATR(&ATR7C13) A R7C14 2A O 13 59DSPATR(&ATR7C14) A R7C15 2A O 13 63DSPATR(&ATR7C15) A R7C16 2A O 13 67DSPATR(&ATR7C16) A R7C17 2A O 13 71DSPATR(&ATR7C17) A R7C18 2A O 13 75DSPATR(&ATR7C18) A 13 78'|' COLOR(BLU) A 14 2'8' COLOR(PNK) A 14 4'|' COLOR(BLU) A R8C01 2A O 14 7DSPATR(&ATR8C01) A R8C02 2A O 14 11DSPATR(&ATR8C02) A R8C03 2A O 14 15DSPATR(&ATR8C03) A R8C04 2A O 14 19DSPATR(&ATR8C04) A R8C05 2A O 14 23DSPATR(&ATR8C05) A R8C06 2A O 14 27DSPATR(&ATR8C06) A R8C07 2A O 14 31DSPATR(&ATR8C07) A R8C08 2A O 14 35DSPATR(&ATR8C08) A R8C09 2A O 14 39DSPATR(&ATR8C09) A R8C10 2A O 14 43DSPATR(&ATR8C10) A R8C11 2A O 14 47DSPATR(&ATR8C11) A R8C12 2A O 14 51DSPATR(&ATR8C12) A R8C13 2A O 14 55DSPATR(&ATR8C13) A R8C14 2A O 14 59DSPATR(&ATR8C14) A R8C15 2A O 14 63DSPATR(&ATR8C15) A R8C16 2A O 14 67DSPATR(&ATR8C16) A R8C17 2A O 14 71DSPATR(&ATR8C17) A R8C18 2A O 14 75DSPATR(&ATR8C18) A 14 78'|' COLOR(BLU) A 15 2'9' COLOR(PNK) A 15 4'|' COLOR(BLU) A R9C01 2A O 15 7DSPATR(&ATR9C01) A R9C02 2A O 15 11DSPATR(&ATR9C02) A R9C03 2A O 15 15DSPATR(&ATR9C03) A R9C04 2A O 15 19DSPATR(&ATR9C04) A R9C05 2A O 15 23DSPATR(&ATR9C05) A R9C06 2A O 15 27DSPATR(&ATR9C06) A R9C07 2A O 15 31DSPATR(&ATR9C07) A R9C08 2A O 15 35DSPATR(&ATR9C08) A R9C09 2A O 15 39DSPATR(&ATR9C09) A R9C10 2A O 15 43DSPATR(&ATR9C10) A R9C11 2A O 15 47DSPATR(&ATR9C11) A R9C12 2A O 15 51DSPATR(&ATR9C12) A R9C13 2A O 15 55DSPATR(&ATR9C13) A R9C14 2A O 15 59DSPATR(&ATR9C14) A R9C15 2A O 15 63DSPATR(&ATR9C15) A R9C16 2A O 15 67DSPATR(&ATR9C16) A R9C17 2A O 15 71DSPATR(&ATR9C17) A R9C18 2A O 15 75DSPATR(&ATR9C18) A 15 78'|' COLOR(BLU) A 16 4'|' COLOR(BLU) A R10C01 2A O 16 7DSPATR(&ATR10C01) A R10C02 2A O 16 11DSPATR(&ATR10C02) A R10C03 2A O 16 15DSPATR(&ATR10C03) A R10C04 2A O 16 19DSPATR(&ATR10C04) A R10C05 2A O 16 23DSPATR(&ATR10C05) A R10C06 2A O 16 27DSPATR(&ATR10C06) A R10C07 2A O 16 31DSPATR(&ATR10C07) A R10C08 2A O 16 35DSPATR(&ATR10C08) A R10C09 2A O 16 39DSPATR(&ATR10C09) A R10C10 2A O 16 43DSPATR(&ATR10C10) A R10C11 2A O 16 47DSPATR(&ATR10C11) A R10C12 2A O 16 51DSPATR(&ATR10C12) A R10C13 2A O 16 55DSPATR(&ATR10C13) A R10C14 2A O 16 59DSPATR(&ATR10C14) A R10C15 2A O 16 63DSPATR(&ATR10C15) A R10C16 2A O 16 67DSPATR(&ATR10C16) A R10C17 2A O 16 71DSPATR(&ATR10C17) A R10C18 2A O 16 75DSPATR(&ATR10C18) A 16 78'|' COLOR(BLU) A 17 4'|' COLOR(BLU) A R11C01 2A O 17 7DSPATR(&ATR11C01) A R11C02 2A O 17 11DSPATR(&ATR11C02) A R11C03 2A O 17 15DSPATR(&ATR11C03) A R11C04 2A O 17 19DSPATR(&ATR11C04) A R11C05 2A O 17 23DSPATR(&ATR11C05) A R11C06 2A O 17 27DSPATR(&ATR11C06) A R11C07 2A O 17 31DSPATR(&ATR11C07) A R11C08 2A O 17 35DSPATR(&ATR11C08) A R11C09 2A O 17 39DSPATR(&ATR11C09) A R11C10 2A O 17 43DSPATR(&ATR11C10) A R11C11 2A O 17 47DSPATR(&ATR11C11) A R11C12 2A O 17 51DSPATR(&ATR11C12) A R11C13 2A O 17 55DSPATR(&ATR11C13) A R11C14 2A O 17 59DSPATR(&ATR11C14) A R11C15 2A O 17 63DSPATR(&ATR11C15) A R11C16 2A O 17 67DSPATR(&ATR11C16) A R11C17 2A O 17 71DSPATR(&ATR11C17) A R11C18 2A O 17 75DSPATR(&ATR11C18) A 17 78'|' COLOR(BLU) A 18 4'|' COLOR(BLU) A 18 78'|' COLOR(BLU) A 19 4'| - A - A |' COLOR(BLU) DSPATR(UL) A 23 2'F3=Exit' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRIND'.List Indicators Used (JCRIND) - Help .*-------------------------------------------------------------------- :P.This JCR command displays list of indicators used in selected RPG, CL and/or PRTF,DSPF source code. Multiple members can be enter at one time to see cumulative indicator usage.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRIND/SRCMBR'.Source member - Help :XH3.Source member (SRCMBR) :P.Name(s) of up to three members for which indicator usage is to be displayed.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRINDR - List Indicators used in source code //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRINDD cf e workstn FRPGSRC if f 112 disk extfile(extIfile) extmbr(ExtMbr) F usropn Infds(Infds) //--*STAND ALONE------------------------------------------- D MbrCount s 3u 0 D MbrColon s 4a inz('Mbr:') D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(ParmPtr) D Col s 3u 0 D Row s 3u 0 D CompMsgString s 36a varying D ExtMbr s 10a D FileQual s 20a // RPG4 D ExtendedF2 s 45a D IndExtract s 6a D TestByte s 1a D yy s 5u 0 D IsCalcSpec s n D IsFree s n D MaybeIN s 6a // CLLE //--*DATA STRUCTURES--------------------------------------- // Get number of source files and source file/lib/Mbr names D ListOfMbrs ds based(ListOfMbrsPtr) qualified D SrcMbr 10a overlay(ListOfMbrs:3) D SrcFilQual 20a overlay(ListOfMbrs:*next) D FoundOne ds qualified inz D Pos1 1a D Pos2 1a // RPG3 D Rpg3 ds qualified based(Rpg3Ptr) D ArrayBegin 13 15a // CALC D Level0 19 20a D con123 22 29a D condi1 22 23a D condi2 25 26a D condi3 28 29a // factor 1 D f1ain 30 32a D f1coma 33 33a D f1ind 33 34a D f1inx 34 35a D f1in1 34 34a D f1in2 35 35a // factor 2 D f2ain 45 47a D f2coma 48 48a D f2ind 48 49a D f2inx 49 50a D f2in1 49 49a D f2in2 50 50a // result field D rsain 55 57a D rscomma 58 58a D rsind 58 59a D rsinx 59 60a D rsin1 59 59a D rsin2 60 60a // resulting indicators D res123 66 71a D result1 66 67a D result2 68 69a D result3 70 71a // D specs D rec 31 32a D lind 71 72a D match 73 74a D input1 77 78a D input2 79 80a D input3 81 82a // O specs D out123 36 43a D out1 36 37a D out2 39 40a D out3 42 43a // F specs D fsofin 45 46a D fsdevt 52 58a D fsfcon 83 84a //--*COPY DEFINES------------------------------------------ /Define Infds /Define Constants /Define f_BlankCommentsCL /Define Dspatr /Define SrcDS /Define f_GetQual /Define f_GetDayName /Define f_Qusrmbrd /Define f_CenterText /Define f_BuildString /Define f_SndCompMsg /Define f_BringDataBaseRecords /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_GetRow PR 3u 0 D 2a D f_GetColumn PR 3u 0 D 2a //--*DATA STRUCTURES--------------------------------------- D scObjHead s dim(3) based(ptr1) like(scObjHead1) D ptr1 s * inz(%addr(scObjHead1)) D Indicators ds dim(12) qualified based(ptr2) D Col 2a dim(18) D ptr2 s * inz(%addr(R0C01)) D Attr ds dim(12) qualified based(ptr3) D Col 1a dim(18) D ptr3 s * inz(%addr(ATR0C01)) // map screen fields into program array D ScreenDS ds D scObjHead1 D scObjHead2 D scObjHead3 D R0C01 D R0C02 D R0C03 D R0C04 D R0C05 D R0C06 D R0C07 D R0C08 D R0C09 D R0C10 D R0C11 D R0C12 D R0C13 D R0C14 D R0C15 D R0C16 D R0C17 D R0C18 D R1C01 D R1C02 D R1C03 D R1C04 D R1C05 D R1C06 D R1C07 D R1C08 D R1C09 D R1C10 D R1C11 D R1C12 D R1C13 D R1C14 D R1C15 D R1C16 D R1C17 D R1C18 D R2C01 D R2C02 D R2C03 D R2C04 D R2C05 D R2C06 D R2C07 D R2C08 D R2C09 D R2C10 D R2C11 D R2C12 D R2C13 D R2C14 D R2C15 D R2C16 D R2C17 D R2C18 D R3C01 D R3C02 D R3C03 D R3C04 D R3C05 D R3C06 D R3C07 D R3C08 D R3C09 D R3C10 D R3C11 D R3C12 D R3C13 D R3C14 D R3C15 D R3C16 D R3C17 D R3C18 D R4C01 D R4C02 D R4C03 D R4C04 D R4C05 D R4C06 D R4C07 D R4C08 D R4C09 D R4C10 D R4C11 D R4C12 D R4C13 D R4C14 D R4C15 D R4C16 D R4C17 D R4C18 D R5C01 D R5C02 D R5C03 D R5C04 D R5C05 D R5C06 D R5C07 D R5C08 D R5C09 D R5C10 D R5C11 D R5C12 D R5C13 D R5C14 D R5C15 D R5C16 D R5C17 D R5C18 D R6C01 D R6C02 D R6C03 D R6C04 D R6C05 D R6C06 D R6C07 D R6C08 D R6C09 D R6C10 D R6C11 D R6C12 D R6C13 D R6C14 D R6C15 D R6C16 D R6C17 D R6C18 D R7C01 D R7C02 D R7C03 D R7C04 D R7C05 D R7C06 D R7C07 D R7C08 D R7C09 D R7C10 D R7C11 D R7C12 D R7C13 D R7C14 D R7C15 D R7C16 D R7C17 D R7C18 D R8C01 D R8C02 D R8C03 D R8C04 D R8C05 D R8C06 D R8C07 D R8C08 D R8C09 D R8C10 D R8C11 D R8C12 D R8C13 D R8C14 D R8C15 D R8C16 D R8C17 D R8C18 D R9C01 D R9C02 D R9C03 D R9C04 D R9C05 D R9C06 D R9C07 D R9C08 D R9C09 D R9C10 D R9C11 D R9C12 D R9C13 D R9C14 D R9C15 D R9C16 D R9C17 D R9C18 D R10C01 D R10C02 D R10C03 D R10C04 D R10C05 D R10C06 D R10C07 D R10C08 D R10C09 D R10C10 D R10C11 D R10C12 D R10C13 D R10C14 D R10C15 D R10C16 D R10C17 D R10C18 D R11C01 D R11C02 D R11C03 D R11C04 D R11C05 D R11C06 D R11C07 D R11C08 D R11C09 D R11C10 D R11C11 D R11C12 D R11C13 D R11C14 D R11C15 D R11C16 D R11C17 D R11C18 D ATR0C01 D ATR0C02 D ATR0C03 D ATR0C04 D ATR0C05 D ATR0C06 D ATR0C07 D ATR0C08 D ATR0C09 D ATR0C10 D ATR0C11 D ATR0C12 D ATR0C13 D ATR0C14 D ATR0C15 D ATR0C16 D ATR0C17 D ATR0C18 D ATR1C01 D ATR1C02 D ATR1C03 D ATR1C04 D ATR1C05 D ATR1C06 D ATR1C07 D ATR1C08 D ATR1C09 D ATR1C10 D ATR1C11 D ATR1C12 D ATR1C13 D ATR1C14 D ATR1C15 D ATR1C16 D ATR1C17 D ATR1C18 D ATR2C01 D ATR2C02 D ATR2C03 D ATR2C04 D ATR2C05 D ATR2C06 D ATR2C07 D ATR2C08 D ATR2C09 D ATR2C10 D ATR2C11 D ATR2C12 D ATR2C13 D ATR2C14 D ATR2C15 D ATR2C16 D ATR2C17 D ATR2C18 D ATR3C01 D ATR3C02 D ATR3C03 D ATR3C04 D ATR3C05 D ATR3C06 D ATR3C07 D ATR3C08 D ATR3C09 D ATR3C10 D ATR3C11 D ATR3C12 D ATR3C13 D ATR3C14 D ATR3C15 D ATR3C16 D ATR3C17 D ATR3C18 D ATR4C01 D ATR4C02 D ATR4C03 D ATR4C04 D ATR4C05 D ATR4C06 D ATR4C07 D ATR4C08 D ATR4C09 D ATR4C10 D ATR4C11 D ATR4C12 D ATR4C13 D ATR4C14 D ATR4C15 D ATR4C16 D ATR4C17 D ATR4C18 D ATR5C01 D ATR5C02 D ATR5C03 D ATR5C04 D ATR5C05 D ATR5C06 D ATR5C07 D ATR5C08 D ATR5C09 D ATR5C10 D ATR5C11 D ATR5C12 D ATR5C13 D ATR5C14 D ATR5C15 D ATR5C16 D ATR5C17 D ATR5C18 D ATR6C01 D ATR6C02 D ATR6C03 D ATR6C04 D ATR6C05 D ATR6C06 D ATR6C07 D ATR6C08 D ATR6C09 D ATR6C10 D ATR6C11 D ATR6C12 D ATR6C13 D ATR6C14 D ATR6C15 D ATR6C16 D ATR6C17 D ATR6C18 D ATR7C01 D ATR7C02 D ATR7C03 D ATR7C04 D ATR7C05 D ATR7C06 D ATR7C07 D ATR7C08 D ATR7C09 D ATR7C10 D ATR7C11 D ATR7C12 D ATR7C13 D ATR7C14 D ATR7C15 D ATR7C16 D ATR7C17 D ATR7C18 D ATR8C01 D ATR8C02 D ATR8C03 D ATR8C04 D ATR8C05 D ATR8C06 D ATR8C07 D ATR8C08 D ATR8C09 D ATR8C10 D ATR8C11 D ATR8C12 D ATR8C13 D ATR8C14 D ATR8C15 D ATR8C16 D ATR8C17 D ATR8C18 D ATR9C01 D ATR9C02 D ATR9C03 D ATR9C04 D ATR9C05 D ATR9C06 D ATR9C07 D ATR9C08 D ATR9C09 D ATR9C10 D ATR9C11 D ATR9C12 D ATR9C13 D ATR9C14 D ATR9C15 D ATR9C16 D ATR9C17 D ATR9C18 D ATR10C01 D ATR10C02 D ATR10C03 D ATR10C04 D ATR10C05 D ATR10C06 D ATR10C07 D ATR10C08 D ATR10C09 D ATR10C10 D ATR10C11 D ATR10C12 D ATR10C13 D ATR10C14 D ATR10C15 D ATR10C16 D ATR10C17 D ATR10C18 D ATR11C01 D ATR11C02 D ATR11C03 D ATR11C04 D ATR11C05 D ATR11C06 D ATR11C07 D ATR11C08 D ATR11C09 D ATR11C10 D ATR11C11 D ATR11C12 D ATR11C13 D ATR11C14 D ATR11C15 D ATR11C16 D ATR11C17 D ATR11C18 //--*ENTRY PARMS------------------------------------------- D p_JCRINDR PR extpgm('JCRINDR') D 92a D p_JCRINDR PI D p_SrcMbrs 92a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 112 SrcDS //--------------------------------------------------------- /free // process parm list by moving data structure pointer ParmPtr = %addr(p_SrcMbrs); DisplacePtr = ParmPtr; 1b for MbrCount = 1 to NumOfLists; DisplacePtr += 2; ListOfMbrsPtr = ParmPtr + Displacement; FileQual = ListOfMbrs.SrcFilQual; ExtMbr = ListOfMbrs.SrcMbr; // get member type QusrmbrdDS = f_Qusrmbrd(FileQual: ExtMbr: 'MBRD0200'); f_BringDataBaseRecords(QusrmbrdDS.File: QusrmbrdDS.Lib: ExtMbr: QusrmbrdDS.CurrNumberRecs); scObjHead(MbrCount)= f_BuildString('& & & & &': MbrColon: QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); MbrColon = *blanks; 2b if MbrCount = 1; CompMsgString = %trimr(ExtMbr); 2x else; CompMsgString += ', ' + %trimr(ExtMbr); 2e endif; extIfile = f_GetQual(QusrmbrdDS.File + QusrmbrdDS.Lib); evalr scDow = %trimr(f_GetDayName()); open RPGSRC; read RPGSRC; // Execute different source reader based on source type. 2b if QusrmbrdDS.MbrType = 'RPGLE ' or QusrmbrdDS.MbrType = 'SQLRPGLE '; exsr srReadSrcRPGLE; 2x elseif %subst(QusrmbrdDS.MbrType: 1: 4) = 'DSPF' or %subst(QusrmbrdDS.MbrType: 1: 4) = 'PRTF'; exsr srReadSrcDDS; 2x elseif %subst(QusrmbrdDS.MbrType: 1: 2) = 'CL'; exsr srReadSrcCL; 2x elseif %subst(QusrmbrdDS.MbrType: 1: 3) = 'RPG' or %subst(QusrmbrdDS.MbrType: 1: 6) = 'SQLRPG'; Rpg3Ptr = %addr(SrcDS); exsr srReadSrcRPG3; 2e endif; close RPGSRC; //--------------------------------------------------------- 1e endfor; // fill in any unused grid locations 1b for Row = 1 to 10; 2b for Col = 1 to 18; 3b if Indicators(Row).Col(Col) = ' '; Indicators(Row).Col(Col) = '. '; Attr(Row).Col(Col) = BLUE; 3e endif; 2e endfor; 1e endfor; exfmt SCREEN; f_SndCompMsg('JCRIND for ' + %trimr(CompMsgString) + ' - completed'); *inlr = *on; return; //--------------------------------------------------------- // load indicator to proper Row/Col begsr srLoadMatrix; 1b if FoundOne <> 'ZS'; //not *inzsr Row = f_GetRow(FoundOne); 2b if Row > 0; Col = f_GetColumn(FoundOne); 3b if Col > 0; Indicators(Row).Col(Col) = FoundOne; Attr(Row).Col(Col) = WHITE; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Read Rpg4 Source code. // Three types of lines scanned are calc, input, output. // all lines that are comment or have eject character are // ignored, also exit at first compile time table or array. // calculation, all conditioning, used as fields, and resulting // input record id, L indicators, field indicators // output conditioning indicators begsr srReadSrcRPGLE; 1b dow not %eof; // do not process compile time arrays 2b if SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c'; LV leavesr; 2e endif; // O specs will set IsCalcSpec off SrcDS.SpecType = %xlate(lo: up: SrcDS.SpecType); 2b if SrcDS.SpecType = 'O' or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'F'; IsCalcSpec = *off; 2e endif; // if C or c or /free, we are in C specs. 2b if SrcDS.SpecType = 'C'; IsCalcSpec = *on; 2e endif; // see if inside /free section 2b if SrcDS.Asterisk = '/'; SrcDS.FreeForm = %xlate(lo: up: SrcDS.FreeForm); 3b if SrcDS.FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 3x elseif SrcDS.FreeForm = '/END-FREE'; IsFree = *off; 3e endif; 2e endif; // see if /free comment line IsComment = *off; 2b if IsFree; 3b if %len(%triml(SrcDS.Src80)) > 1 and %subst((%triml(SrcDS.Src80)): 1: 2) = '//'; IsComment = *on; 3e endif; 2x else; 3b if SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/' or SrcDS.Asterisk = '+'; IsComment = *on; 3e endif; 2e endif; // check conditioning indicators for calc specs. 2b if not IsComment; 3b if IsCalcSpec; 4b if IsFree; SrcDS.Src80 = %xlate(lo: up: SrcDS.Src80); cc = %scan('//': SrcDS.Src80: 1); yy = 0; 5b dou yy = 0; yy = %scan('*IN': SrcDS.Src80: yy + 1); 6b if yy > 0; // if indicator is past comment markers 7b if cc > 0 and yy > cc; 5v leave; 7e endif; IndExtract = %subst(SrcDS.Src80: yy: 6); exsr srExtract; 6e endif; 5e enddo; 4x else; SrcDS = %xlate(lo: up: SrcDS); 5b if %subst(SrcDS: 22: 2) > *blanks; //CONDITIONING IND FoundOne = %subst(SrcDS: 22: 2); exsr srLoadMatrix; 5e endif; 5b if %subst(SrcDS: 19: 2) = 'L0'; FoundOne = 'L0'; exsr srLoadMatrix; 5e endif; 5b if (%subst(SrcDS: 38: 4) = 'EVAL') or (%subst(SrcDS: 38: 5) = 'WHEN ') or (%subst(SrcDS: 38: 4) = 'DOW ') or (%subst(SrcDS: 38: 4) = 'DOU ') or (%subst(SrcDS: 38: 3) = 'IF ') or (%subst(SrcDS: 38: 5) = *blanks); ExtendedF2 = %subst(SrcDS: 48: 45); //EXTENDED FACTOR2 yy = 0; 6b dou yy = 0; yy = %scan('*IN': ExtendedF2: yy + 1); 7b if yy > 0; IndExtract = %subst(ExtendedF2: yy: 6); exsr srExtract; 7e endif; 6e enddo; 5x else; 6b if (%subst(SrcDS: 24: 3) = '*IN') and (%subst(SrcDS: 27: 1) <> 'Z'); IndExtract = %subst(SrcDS: 24: 6); exsr srExtract; 6e endif; 6b if (%subst(SrcDS: 48: 3) = '*IN'); //FACTOR 2 *IN IndExtract = %subst(SrcDS: 48: 6); exsr srExtract; 6e endif; 6b if (%subst(SrcDS: 62: 3) = '*IN'); //RESULT FIELD *IN IndExtract = %subst(SrcDS: 62: 6); exsr srExtract; 6e endif; // load resulting indicators. 6b if %subst(SrcDS: 38: 4) <> 'CALL'; 7b if %subst(SrcDS: 83: 2) > *blanks; //HIGH IndExtract = ' ' + %subst(SrcDS: 83: 2); exsr srExtract; 7e endif; 7b if %subst(SrcDS: 85: 2) > *blanks; //LO IndExtract = ' ' + %subst(SrcDS: 85: 2); exsr srExtract; 7e endif; 7b if %subst(SrcDS: 87: 2) > *blanks; //EQUAL IndExtract = ' ' + %subst(SrcDS: 87: 2); exsr srExtract; 7e endif; 6e endif; 5e endif; 4e endif; //--------------------------------------------------------- // I spec indicators 3x elseif SrcDS.SpecType = 'I' or SrcDS.SpecType = 'i'; SrcDS = %xlate(lo: up: SrcDS); 4b if (%subst(SrcDS: 19: 10) > *blanks) or //FILE NAME (%subst(SrcDS: 29: 2) > *blanks); //OR SEQ PRESENT? 5b if (%subst(SrcDS: 33: 2) > *blanks) and // RECORD ID (%subst(SrcDS: 33: 2) <> 'DS'); FoundOne = %subst(SrcDS: 33: 2); exsr srLoadMatrix; 5e endif; 4e endif; 4b if %subst(SrcDS: 75: 2) > *blanks; //L INDICATORS FoundOne = %subst(SrcDS: 75: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 77: 2) > *blanks; //MATCHING RECORDS FoundOne = %subst(SrcDS: 77: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 79: 2) > *blanks; //RELATIONAL FoundOne = %subst(SrcDS: 79: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 81: 2) > *blanks; //FIELD + FoundOne = %subst(SrcDS: 81: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 83: 2) > *blanks; //FIELD - FoundOne = %subst(SrcDS: 83: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 85: 2) > *blanks; //FIELD 0/*BLANK FoundOne = %subst(SrcDS: 85: 2); exsr srLoadMatrix; 4e endif; //--------------------------------------------------------- // O spec indicators. 3x elseif SrcDS.SpecType = 'O' or SrcDS.SpecType = 'o'; SrcDS = %xlate(lo: up: SrcDS); 4b if %subst(SrcDS: 34: 2) > *blanks; //O SPEC INDICATOR 1 FoundOne = %subst(SrcDS: 34: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 37: 2) > *blanks; //O SPEC IND 2 FoundOne = %subst(SrcDS: 37: 2); exsr srLoadMatrix; 4e endif; 4b if %subst(SrcDS: 40: 2) > *blanks; //O SPEC IND 3 FoundOne = %subst(SrcDS: 40: 2); exsr srLoadMatrix; 4e endif; //--------------------------------------------------------- // F spec indicators 3x elseif SrcDS.SpecType = 'F' or SrcDS.SpecType = 'f'; SrcDS = %xlate(lo: up: SrcDS); yy = %scan('OFLIND(*IN': SrcDS); 4b if yy > 55 and yy < 93; FoundOne = %subst(SrcDS: yy + 10: 2); exsr srLoadMatrix; 4x else; yy = %scan('OFLIND(': SrcDS); 5b if yy > 55 and yy < 93; FoundOne = %subst(SrcDS: yy + 7: 2); exsr srLoadMatrix; 5e endif; 4e endif; yy = %scan('EXTIND(*IN': SrcDS); 4b if yy > 55 and yy < 93; FoundOne = %subst(SrcDS: yy + 10: 2); exsr srLoadMatrix; 4e endif; 3e endif; 2e endif; read RPGSRC; 1e enddo; endsr; //--------------------------------------------------------- // load indicators that are used as field names. // *inxx or *in(xx) or *in(x) are tested for and loaded. // The index is checked for numeric. begsr srExtract; 1b if (%subst(IndExtract: 4: 1) <> '('); //not array element FoundOne = %subst(IndExtract: 4: 2); //load key 2b if FoundOne = 'OA' or FoundOne = 'OB' or FoundOne = 'OC' or FoundOne = 'OD' or FoundOne = 'OE' or FoundOne = 'OF' or FoundOne = 'OG' or FoundOne = 'OV' or FoundOne = 'L0' or FoundOne = 'RT' or FoundOne = 'LR' OR ((FoundOne >= 'KA' and FoundOne <= 'KN' ) or (FoundOne >= 'KP' and FoundOne <= 'KY' )) OR ((%check('0123456789': FoundOne.Pos1: 1) = 0 OR FoundOne.Pos1 = 'M' or // Matching FoundOne.Pos1 = 'H' or // Halt FoundOne.Pos1 = 'U') // User switch AND %check('0123456789': FoundOne.Pos2: 1) = 0 ); exsr srLoadMatrix; 2e endif; 1x else; //used as index TestByte = %subst(IndExtract: 5: 1); 2b if %check('0123456789': TestByte) = 0; //all numeric 3b if (%subst(IndExtract: 6: 1) = ')') or //*in(9) (%subst(IndExtract: 6: 1) = *blanks); //or *in(9) FoundOne = '0' + %subst(IndExtract: 5: 1); //09 3x else; FoundOne = %subst(IndExtract: 5: 2); //whole number 3e endif; 3b if %check('0123456789': FoundOne) = 0; //all numeric exsr srLoadMatrix; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Display or Print file Indicators begsr srReadSrcDDS; 1b dow not %eof; // ignore all lines that are comment or have eject characters. 2b if SrcDS.SpecType = 'A' and not (SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/'); 3b if SrcDS.ddsCondIn1 >= '01' and SrcDS.ddsCondIn1 <= '99' and %subst(SrcDS.ddsCondIn1: 1: 1) > ' ' and %subst(SrcDS.ddsCondIn1: 2: 1) > ' '; FoundOne = SrcDS.ddsCondIn1; exsr srLoadMatrix; 3e endif; 3b if SrcDS.ddsCondIn2 >= '01' and SrcDS.ddsCondIn2 <= '99' and %subst(SrcDS.ddsCondIn2: 1: 1) > ' ' and %subst(SrcDS.ddsCondIn2: 2: 1) > ' '; FoundOne = SrcDS.ddsCondIn2; exsr srLoadMatrix; 3e endif; 3b if SrcDS.ddsCondIn3 >= '01' and SrcDS.ddsCondIn3 <= '99' and %subst(SrcDS.ddsCondIn3: 1: 1) > ' ' and %subst(SrcDS.ddsCondIn3: 2: 1) > ' '; FoundOne = SrcDS.ddsCondIn3; exsr srLoadMatrix; 3e endif; // extract indicators that are assigned to keywords. 3b if SrcDS.ddsField10 = 'VLDCMDKEY('; FoundOne = %subst(SrcDS.ddsField: 11: 2); exsr srLoadMatrix; 3x elseif SrcDS.ddsField9 = 'PAGEDOWN(' or SrcDS.ddsField9 = 'ROLLDOWN('; FoundOne = %subst(SrcDS.ddsField: 10: 2); exsr srLoadMatrix; 3x elseif SrcDS.ddsField7 = 'BLANKS(' or SrcDS.ddsField7 = 'CHANGE(' or SrcDS.ddsField7 = 'INDTXT(' or SrcDS.ddsField7 = 'PAGEUP(' or SrcDS.ddsField7 = 'ROLLUP('; FoundOne = %subst(SrcDS.ddsField: 8: 2); exsr srLoadMatrix; 3x elseif SrcDS.ddsField6 = 'CLEAR(' or SrcDS.ddsField6 = 'SETOF(' or (SrcDS.ddsField7 >= 'PRINT(0' and SrcDS.ddsField7 <= 'PRINT(9'); FoundOne = %subst(SrcDS.ddsField: 7: 2); exsr srLoadMatrix; 3x elseif SrcDS.ddsField5 = 'HELP(' or SrcDS.ddsField5 = 'HOME(' or SrcDS.ddsField2 = 'CA' and SrcDS.ddsParenthesis = '(' or SrcDS.ddsField2 = 'CF' and SrcDS.ddsParenthesis = '('; FoundOne = %subst(SrcDS.ddsField: 6: 2); exsr srLoadMatrix; 3x elseif SrcDS.ddsField4 = 'DUP('; FoundOne = %subst(SrcDS.ddsField: 5: 2); exsr srLoadMatrix; 3e endif; 2e endif; read RPGSRC; 1e enddo; endsr; //--------------------------------------------------------- // read CL source code begsr srReadSrcCL; 1b dow not %eof; // If 92 record length, blank out any possible garbage from 93 to 112 2b if InfdsRecLen = 92; %subst(SrcDS: 93) = *blanks; 2e endif; SrcDS.Src112 = f_BlankCommentsCL(SrcDS.Src112); SrcDS.Src112 = %xlate(lo: up: SrcDS.Src112); yy = 0; 2b dou yy = 0; yy = %scan('&IN': SrcDS.Src112: yy + 1); 3b if yy > 0; MaybeIN = %subst(SrcDS.Src112: yy: 6); //--------------------------------------------------------- // extract indicator values. &INxx) or &INxx are acceptable // xx must equal numeric and position following must be ' ' or ) 4b if %subst(MaybeIN: 4: 1) >= '0' and %subst(MaybeIN: 4: 1) <= '9' and %subst(MaybeIN: 5: 1) >= '0' and %subst(MaybeIN: 5: 1) <= '9'; 5b if (%subst(MaybeIN: 6: 1) = ')') or (%subst(MaybeIN: 6: 1) = *blanks); FoundOne = %subst(MaybeIN: 4: 2); exsr srLoadMatrix; 5e endif; 4e endif; 3e endif; 2e enddo; read RPGSRC; 1e enddo; endsr; //--------------------------------------------------------- // Read Rpg3 Source code. // Three types of lines scanned are calc, input, output. // all lines that are comment or have eject character are // ignored, also exit at first compile time table or array. // calculation all conditioning, used as fields, and resulting // input record id, L indicators, field indicators // output conditioning indicators begsr srReadSrcRPG3; 1b dow not %eof; // exit subroutine first array definition 2b if Rpg3.ArrayBegin = '** '; LV leavesr; 2x elseif not (SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/' or SrcDS.Asterisk = '+'); // Calc Specs 3b if SrcDS.SpecType = 'C'; 4b if Rpg3.Level0 = 'L0'; FoundOne = 'L0'; exsr srLoadMatrix; 4e endif; 4b if Rpg3.con123 > *blanks; 5b if Rpg3.condi1 > *blanks; FoundOne = Rpg3.condi1; exsr srLoadMatrix; 5e endif; 5b if Rpg3.condi2 > *blanks; FoundOne = Rpg3.condi2; exsr srLoadMatrix; 5e endif; 5b if Rpg3.condi3 > *blanks; FoundOne = Rpg3.condi3; exsr srLoadMatrix; 5e endif; 4e endif; //--------------------------------------------------------- // load indicators that are used as field names in factor 1. // *inxx or *in,xx or in,x are tested for and loaded. if // *in array is used, test is made to make sure index is // numeric. Index must be right justified before test // for numeric is made. 4b if (Rpg3.f1ain = '*IN') and not (Rpg3.f1coma = 'Z'); 5b if Rpg3.f1coma <> ','; //*INxx FoundOne = Rpg3.f1ind; //LOAD ARRAY exsr srLoadMatrix; 5x else; //USED AS INDEX 6b if Rpg3.f1in2 = *blanks; //*IN,9 Rpg3.f1inx = '0' + Rpg3.f1in1; //*IN,09 6e endif; 6b if %check('0123456789': Rpg3.f1inx: 1) = 0; //all numeric FoundOne = Rpg3.f1inx; exsr srLoadMatrix; 6e endif; 5e endif; 4e endif; // load indicators that are used as field names in factor 2. // logic is same as factor 1 section. 4b if Rpg3.f2ain = '*IN'; 5b if Rpg3.f2coma <> ','; FoundOne = Rpg3.f2ind; exsr srLoadMatrix; 5x else; 6b if Rpg3.f2in2 = *blanks; Rpg3.f2inx = '0' + Rpg3.f2in1; 6e endif; 6b if %check('0123456789': Rpg3.f2inx: 1) = 0; //all numeric FoundOne = Rpg3.f2inx; exsr srLoadMatrix; 6e endif; 5e endif; 4e endif; // indicators that are used as field names in result field. 4b if Rpg3.rsain = '*IN'; 5b if Rpg3.rscomma <> ','; FoundOne = Rpg3.rsind; exsr srLoadMatrix; 5x else; 6b if Rpg3.rsin2 = *blanks; Rpg3.rsinx = '0' + Rpg3.rsin1; 6e endif; 6b if %check('0123456789': Rpg3.rsinx: 1) = 0; //all numeric FoundOne = Rpg3.rsinx; exsr srLoadMatrix; 6e endif; 5e endif; 4e endif; // load indicators that are used as field names in result field. 4b if rpg3.Res123 > *blanks; 5b if rpg3.Result1 > *blanks; FoundOne = rpg3.Result1; exsr srLoadMatrix; 5e endif; 5b if rpg3.Result2 > *blanks; FoundOne = rpg3.Result2; exsr srLoadMatrix; 5e endif; 5b if rpg3.Result3 > *blanks; FoundOne = rpg3.Result3; exsr srLoadMatrix; 5e endif; 4e endif; //--------------------------------------------------------- // INPUT SPECS. 3x elseif SrcDS.SpecType = 'I'; 4b if (rpg3.Rec > *blanks) and (rpg3.Rec <> 'DS'); //RECORD ID FoundOne = rpg3.Rec; exsr srLoadMatrix; 4e endif; 4b if rpg3.Lind > *blanks; //Level indicators FoundOne = rpg3.Lind; exsr srLoadMatrix; 4e endif; 4b if rpg3.Match > *blanks; //MATCHING RECORDS FoundOne = rpg3.Match; exsr srLoadMatrix; 4e endif; 4b if rpg3.Input1 > *blanks; FoundOne = rpg3.Input1; exsr srLoadMatrix; 4e endif; 4b if rpg3.Input2 > *blanks; FoundOne = rpg3.Input2; exsr srLoadMatrix; 4e endif; 4b if rpg3.Input3 > *blanks; FoundOne = rpg3.Input3; exsr srLoadMatrix; 4e endif; //--------------------------------------------------------- // same logic as previous section. output 3x elseif SrcDS.SpecType = 'O'; 4b if rpg3.Out123 > *blanks; 5b if rpg3.Out1 > *blanks; FoundOne = rpg3.Out1; exsr srLoadMatrix; 5e endif; 5b if rpg3.Out2 > *blanks; FoundOne = rpg3.Out2; exsr srLoadMatrix; 5e endif; 5b if rpg3.Out3 > *blanks; FoundOne = rpg3.Out3; exsr srLoadMatrix; 5e endif; 4e endif; //--------------------------------------------------------- // F - Specs 3x elseif SrcDS.SpecType = 'F'; 4b if rpg3.Fsdevt > *blanks; 5b if rpg3.Fsofin > *blanks; FoundOne = rpg3.Fsofin; exsr srLoadMatrix; 5e endif; 5b if not (rpg3.fsfcon = *blanks or rpg3.fsfcon = 'UC'); FoundOne = rpg3.fsfcon; exsr srLoadMatrix; 5e endif; 4e endif; 3e endif; 2e endif; read RPGSRC; 1e enddo; endsr; /end-free //--------------------------------------------------------- // Returns screen Row number for passed indicator P f_GetRow B D f_GetRow PI 3u 0 D p_Ind 2a D Row s 3u 0 D SplitIndDS ds qualified D pos1 1a D pos2 1a D pos2num 1s 0 overlay(pos2) /free SplitIndDS = p_Ind; 1b if p_Ind < 'H1' or SplitIndDS.pos1 = ' ' or SplitIndDS.pos2 = ' '; Row = 0; 1x elseif p_Ind = 'LR'; Row = 1; 1x elseif p_Ind = '1P'; Row = 2; 1x elseif p_Ind = 'RT'; Row = 3; // ie *in10 would go into Row 1 ( 0 + 1) // *in11 would go into Row 2 ( 1 + 1) etc. 1x elseif SplitIndDS.pos2 >= '0' and SplitIndDS.pos2 <= '9'; Row = SplitIndDS.pos2num + 1; // process alpha. Note *INKA-*INKG maps same as OA-OG. 1x elseif SplitIndDS.pos2 = 'A'; Row = 1; 1x elseif SplitIndDS.pos2 = 'B'; Row = 2; 1x elseif SplitIndDS.pos2 = 'C'; Row = 3; 1x elseif SplitIndDS.pos2 = 'D'; Row = 4; 1x elseif SplitIndDS.pos2 = 'E'; Row = 5; 1x elseif SplitIndDS.pos2 = 'F'; Row = 6; 1x elseif SplitIndDS.pos2 = 'G'; Row = 7; 1x elseif p_Ind = 'OV'; Row = 8; // process remaining *INKx indicators. 1x elseif SplitIndDS.pos2 = 'H'; Row = 8; 1x elseif SplitIndDS.pos2 = 'I'; Row = 9; 1x elseif SplitIndDS.pos2 = 'J'; Row = 10; 1x elseif SplitIndDS.pos2 = 'K'; Row = 11; 1x elseif SplitIndDS.pos2 = 'L'; Row = 12; 1x elseif SplitIndDS.pos2 = 'M'; Row = 1; 1x elseif SplitIndDS.pos2 = 'N'; Row = 2; 1x elseif SplitIndDS.pos2 = 'P'; Row = 3; 1x elseif SplitIndDS.pos2 = 'Q'; Row = 4; 1x elseif SplitIndDS.pos2 = 'R'; Row = 5; 1x elseif SplitIndDS.pos2 = 'S'; Row = 6; 1x elseif SplitIndDS.pos2 = 'T'; Row = 7; 1x elseif SplitIndDS.pos2 = 'U'; Row = 8; 1x elseif SplitIndDS.pos2 = 'V'; Row = 9; 1x elseif SplitIndDS.pos2 = 'W'; Row = 10; 1x elseif SplitIndDS.pos2 = 'X'; Row = 11; 1x elseif SplitIndDS.pos2 = 'Y'; Row = 12; 1e endif; return Row; /end-free Pf_GetRow E //--------------------------------------------------------- // Returns location in Column for passed indicator P f_GetColumn B D f_GetColumn PI 3u 0 D p_Ind 2a D Col s 3u 0 D pos1 s 1a /free pos1 = %subst(p_Ind: 1: 1); 1b if p_Ind = '1P' or p_Ind = 'RT' or p_Ind = 'LR'; Col = 18; 1x elseif pos1 = '0'; Col = 1; 1x elseif pos1 = '1'; Col = 2; 1x elseif pos1 = '2'; Col = 3; 1x elseif pos1 = '3'; Col = 4; 1x elseif pos1 = '4'; Col = 5; 1x elseif pos1 = '5'; Col = 6; 1x elseif pos1 = '6'; Col = 7; 1x elseif pos1 = '7'; Col = 8; 1x elseif pos1 = '8'; Col = 9; 1x elseif pos1 = '9'; Col = 10; 1x elseif pos1 = 'K'; 2b if p_Ind < 'KM'; Col = 12; 2x else; Col = 13; 2e endif; 1x elseif pos1 = 'L'; Col = 11; 1x elseif pos1 = 'O'; Col = 14; 1x elseif pos1 = 'M'; Col = 15; 1x elseif pos1 = 'U'; Col = 16; 1x elseif pos1 = 'H'; Col = 17; 1e endif; return Col; /end-free Pf_GetColumn E ]]> v5r4 //--------------------------------------------------------- // JCRINDRV - Validity checking program for lib/file/member //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D ForCount s 3u 0 D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(ParmPtr) //--*DATA STRUCTURES--------------------------------------- // Get number of source files and source file/lib/Mbr names D ListOfMbrs ds based(ListOfMbrsPtr) qualified D SrcMbr 10a overlay(ListOfMbrs:3) D SrcFil 10a overlay(ListOfMbrs:*next) D SrcLib 10a overlay(ListOfMbrs:*next) //--*ENTRY PARMS------------------------------------------- D p_JCRINDRV PR extpgm('JCRINDRV') D 92a D p_JCRINDRV PI D p_SrcMbrs 92a //--------------------------------------------------------- // Use pointers to overlay input parm with data structure. // Spin down number of offsets to list entries. // ListOfMbrPtr (start of list + displacement pointer) moves DS through the list. //--------------------------------------------------------- /free ParmPtr = %addr(p_SrcMbrs); DisplacePtr = ParmPtr; 1b for ForCount = 1 to NumOfLists; DisplacePtr += 2; ListOfMbrsPtr = ParmPtr + Displacement; f_CheckMbr(ListOfMbrs.SrcFil + ListOfMbrs.SrcLib: ListOfMbrs.SrcMbr); 1e endfor; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRJOB - Work with selected jobs - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Work With Selected Jobs') PARM KWD(JOB) TYPE(JOB) MIN(0) PROMPT('Job Name:') JOB: QUAL TYPE(*GENERIC) LEN(10) DFT(*ALL) SPCVAL((*ALL)) QUAL TYPE(*GENERIC) LEN(10) DFT(*CURRENT) + SPCVAL((*ALL) (*CURRENT)) PROMPT('User:') QUAL TYPE(*CHAR) LEN(6) DFT(*ALL) PROMPT('Number:') PARM KWD(STATUS) TYPE(*CHAR) LEN(7) RSTD(*YES) + DFT(*ACTIVE) VALUES(*ALL *ACTIVE *JOBQ + *OUTQ) PROMPT('Status of jobs') PARM KWD(THREAD) TYPE(*CHAR) LEN(4) DFT(*ALL) + SPCVAL((*ALL *ALL)) PROMPT('Thread State: + (MSGW)') PARM KWD(JOBQ) TYPE(*GENERIC) LEN(10) DFT(*ALL) + SPCVAL((*ALL *ALL)) PMTCTL(PMTCTL1) PROMPT('Jobq:') PMTCTL1: PMTCTL CTL(STATUS) COND((*EQ '*JOBQ ')) NBRTRUE(*EQ 1) ]]> v5r4 *---------------------------------------------------------------- * JCRJOBD - Work with selected jobs - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA08 CA09 CA10 CA12 INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SCURRUSER 10A H A SBFOPTION 1Y 0B 6 2EDTCDE(4) A SJOBNAME 10A O 6 4 A SUSERNAME 10A O 6 15 A SJOBNUM 6A O 6 26 A SJOBSTATUS 7A O 6 33 A STHREADSTA 4A O 6 41 A SJOBTYPE 10A O 6 46 A SFUNCNAME 10A O 6 57 A SRUNPTY 10A O 6 68 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(16) SFLSIZ(65) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRJOB' COLOR(BLU) A 1 23'Work With Selected Jobs' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Type options, press Enter.' A 2 72SYSNAME COLOR(BLU) A 3 3'2=Chgjob' COLOR(BLU) A 3 14'3=Strsrvjob' COLOR(BLU) A 3 28'4=Endjob' COLOR(BLU) A 3 39'5=Dspjob' COLOR(BLU) A 3 50'8=Wrksplf' COLOR(BLU) A 3 62'9=Job File I/O' COLOR(BLU) A TOGGLE1 7A O 4 15DSPATR(HI) A 4 41'Thr-' DSPATR(HI) A 4 46'Jobq' DSPATR(HI) A 4 57'JobqLib' DSPATR(HI) A 4 68'Subsystem' DSPATR(HI) A 5 2'Opt' DSPATR(HI) A 5 6'Job Name' DSPATR(HI) A 5 15'User' DSPATR(HI) A 5 26'Number' DSPATR(HI) A 5 33'Status' DSPATR(HI) A 5 41'ead' DSPATR(HI) A 5 46'Or Type' DSPATR(HI) A 5 57'or Func' DSPATR(HI) A 5 68'Or RunPty' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 10'F5=Refresh' COLOR(BLU) A 23 22'F8=Toggle CurrUser' COLOR(BLU) A 23 42'F9=Sort Job' COLOR(BLU) A 23 55'F10=Sort User' COLOR(BLU) A 23 70'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRJOB'.Work With Selected Jobs (JCRJOB) - Help .*-------------------------------------------------------------------- :P.This JCR command loads subfile with list of jobs that meet your selection criteria. From subfile, you can select various options to perform. :P. Option 9 is slick file I/O monitor that will let you sort display by IO count or file name. Monitor also has F09=View PFs. This interesting option has been useful to me when analyzing where data is coming from in commercial software, (like Implementer) This option sorts list of open files (PF and LF) down to subset of distinct physicals and executes DBU so you can see contents of each file.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRJOB/JOB'.Job Name - Help :XH3.Job Name (JOB) :P.Specify name of job(s) to load. :PARML.:PT.:PK def.*ALL:EPK.:PD.Select all jobs, regardless of name. :PT.job-name :PD.Enter name of job to select. :PT.:PK def.*CURRENT:EPK.:PD.Select current user profile. :PT.:PK.*ALL:EPK.:PD.Select all users. :PT.user-name :PD.Enter user profile name. :PT.:PK.*ALL:EPK.:PD.Select all job numbers. :PT.job-number :PD.Enter selected job number.:EPARML.:EHELP. :HELP name='JCRJOB/STATUS'.Status of Jobs - Help :XH3.Status of Jobs (STATUS) :P.Status of jobs to select. :PARML.:PT.:PK def.*ACTIVE:EPK.:PD.Load only active jobs. :PT.:PK.*ALL:EPK.:PD.Load jobs, regardless of status. :PT.:PK.*JOBQ:EPK.:PD.Load jobs that are on jobq. :PT.:PK.*OUTQ:EPK.:PD.Load jobs that have generated spooled file.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRJOBIOD - Work with selected jobs - I/O display - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA07 CA08 CA09 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SBFOPTION 1Y 0B 5 2EDTCDE(4) A FILEACTUAL 10A O 5 4 A LIBACTUAL 10A O 5 15 A FILETYPE 4A O 5 26 A TOTALIO 9Y 0O 5 31EDTCDE(4) A RELATIVERN 9Y 0O 5 41EDTCDE(4) A FILETEXT 28A O 5 51 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(17) SFLSIZ(85) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRJOBIOR' COLOR(BLU) A 1 23'Job File I/O' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Job Name:' COLOR(BLU) A PJOBNAM 10A O 2 12 A 2 25'User:' COLOR(BLU) A PJOBUSR 10A O 2 31 A 2 45'Number:' COLOR(BLU) A PJOBNBR 6A O 2 53 A 2 72SYSNAME COLOR(BLU) A SCHEADOPT 65A O 3 2COLOR(BLU) A 4 4'File' DSPATR(HI) A 4 15'Library' DSPATR(HI) A 4 26'Type' DSPATR(HI) A 4 37'I/O' DSPATR(HI) A 4 43'Record#' DSPATR(HI) A 4 51'Text' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A 23 2'F3=Exit' COLOR(BLU) A 23 14'F5=Refresh' COLOR(BLU) A 23 26'F7=I/O seq' COLOR(BLU) A 23 39'F8=File Seq' COLOR(BLU) A FOOTF09 15 23 53COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRJOBIOR - Work with selected jobs - I/O display // call QDMLOPNF API to load receiver variable of open files. // call QLGSORT API to sort file entries. // Initial presentation is in File name sequence. // Execute Obj API to get file text. //--------------------------------------------------------- // Option F09=View PFs is useful to analyze where data is coming from in commercial // software, (like Implementer). // This option sorts list of open files (PF and LF) down to subset of distinct physicals // and executes DBU so you can see contents of each file. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRJOBIOD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D KeyFld s 10a D Quick s 200a based(opPtr) D LengthOfBuffer s 10i 0 D Count s 5u 0 D PfNamesArry s 20a dim(400) D FileLib s 20a D dbUtility s 8a //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define Sds /Define FunctionKeys /Define f_GetFileUtil /Define f_RunOptionFile /Define Ind /Define Qlgsort /Define f_AddSortKey /Define f_Qusrobjd /Define Qdbrtvfd /Define Fild0100DS /Define GetAllocSizeDS /Define f_System /Define f_GetQual /Define f_GetDayName /Define p_JCRJOBIOR /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D qdmlopnf PR extpgm('QDMLOPNF') List Open Files Db 8a options(*varsize) Receiver D 10i 0 const Length D 8a const Api Format Db like(jidf0100DS) Job ID D 8a const Job ID Format Db like(ApiErrDS) Error Parm //--*DATA STRUCTURES--------------------------------------- // define constant part of QDMLOPNF receiver variable D opnf0100DS ds qualified based(opnf0100ptr) D BytesReturned 10i 0 D BytesAvail 10i 0 D NumFilesOpen 10i 0 D OffsetToList 10i 0 D NumFilesRtrned 10i 0 D LenOpenEntry 10i 0 // define Repeated part of QDMLOPNF receiver variable D opRepeatDS ds based(opPtr) qualified D FileName 10a D LibName 10a D Mbr 10a D FileType 10a D RcdFmt 10a D ActivatGroup 10a D ThreadID 8a D OpenOption 1a D Reserved 3a D TotalIO 20i 0 D WriteCount 20i 0 D ReadCount 20i 0 D Write_Read 20i 0 D OtherIO 20i 0 D RRN 20i 0 D SharedOpens 20i 0 // define Job identification information for QDMLOPNF D jidf0100DS ds inz qualified D JobName 10a D UserName 10a D JobNumber 6a D IntJobID 16a inz D Alpha2Resv 2a inz(*allx'00') D ThreadInd 10i 0 inz(3) D ThreadID 8a inz(*allx'00') //--*ENTRY PARMS------------------------------------------- D p_JCRJOBIOR PI D pJobnam 10a D pJobUsr 10a D pJobNbr 6a //--------------------------------------------------------- /free sflrcdnbr = 1; DbUtility = '2=' + f_GetFileUtil(); scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 3=Record Formats'; FootF09 = 'F9=' + %trimr(%subst(DbUtility:3)) + ' PFs'; rrn = 0; OPNF0100ptr = %alloc(1); // so realloc will work KeyFld = 'IO '; jidf0100DS.JobName = pJobnam; jidf0100DS.UserName = pJobUsr; jidf0100DS.JobNumber = pJobNbr; evalr scDow = %trimr(f_GetDayName()); //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; dealloc OPNF0100ptr; *inlr = *on; return; //--------------------------------------------------------- // Clear subfile begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; // call API to get open Files callp QDMLOPNF( GetAllocSizeDS: %len(GetAllocSizeDS): 'OPNF0100': jidf0100DS: 'JIDF0100': ApiErrDS); OPNF0100ptr = %realloc(OPNF0100ptr: GetAllocSizeDS.SizeReturned); callp QDMLOPNF( opnf0100DS: GetAllocSizeDS.SizeReturned: 'OPNF0100': jidf0100DS: 'JIDF0100': ApiErrDS); //--------------------------------------------------------- // Problem is I need to sort by I/O, but // total IO is sum of several fields. I am going // to do Quick spin though offsets and total // IO into single field for sorting. opPtr = opnf0100ptr + opnf0100DS.OffsetToList; 1b for Count = 1 to opnf0100DS.NumFilesRtrned; opRepeatDS.TotalIO = ( opRepeatDS.WriteCount + opRepeatDS.ReadCount + opRepeatDS.Write_Read + opRepeatDS.OtherIO); 2b if opRepeatDS.TotalIO > 999999999; opRepeatDS.TotalIO = 999999999; 2e endif; 2b if opRepeatDS.RRN > 999999999; opRepeatDS.RRN = 999999999; 2e endif; opPtr += opnf0100DS.LenOpenEntry; 1e endfor; // Sort ascending by name or descending by IO. opPtr = opnf0100ptr + opnf0100DS.OffsetToList; qlgSortDS = %subst(qlgSortDS: 1: 80); qlgsortDS.RecordLength = opnf0100DS.LenOpenEntry; qlgsortDS.RecordCount = opnf0100DS.NumFilesRtrned; qlgsortDS.NumOfKeys = 1; 1b if KeyFld = 'FILENAME'; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1: 10); 1x elseif KeyFld = 'IO '; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(73: 8: 0: 2); 1e endif; qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); LengthOfBuffer = opnf0100DS.NumFilesRtrned * opnf0100DS.LenOpenEntry; callp QLGSORT( qlgsortDS: Quick: Quick: LengthOfBuffer: LengthOfBuffer: ApiErrDS); 1b for cc = 1 to opnf0100DS.NumFilesRtrned; FileActual = opRepeatDS.FileName; LibActual = opRepeatDS.LibName; // call API to get file text. QusrObjDS = f_QUSROBJD(FileActual + LibActual: '*FILE '); 2b if ApiErrDS.BytesReturned = 0; FileText = QusrObjDS.Text; TotalIO = opRepeatDS.TotalIO; RelativeRN = opRepeatDS.RRN; FileType = %xlate(UP:LO:opRepeatDS.FileType); 2x else; FileText = 'Not authorized '; TotalIO = 0; RelativeRN = 0; FileType = *blanks; 2e endif; rrn = cc; write SBFDTA1; opPtr += opnf0100DS.LenOpenEntry; 1e endfor; 1b if rrn < SflRcdNbr; SflRcdNbr = rrn; 1e endif; //--------------------------------------------------------- // Allow user to make selection from subfile. 1b if SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; 1b dow not (InfdsFkey = f03); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write SFOOTER1; exfmt SBFCTL1; 2b if SflRecNbr > 0; SflRcdNbr = SflRecNbr; 2x else; SflRcdNbr = 1; 2e endif; 2b if (not Ind.sfldsp) or InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2x elseif InfdsFkey = f05; //resort by whatever sequence is active LV leavesr; // refresh and sort by io 2x elseif InfdsFkey = f07; KeyFld = 'IO '; LV leavesr; // refresh and sort by file name 2x elseif InfdsFkey = f08; KeyFld = 'FILENAME '; LV leavesr; // refresh and sort by file name 2x elseif InfdsFkey = f09; exsr srViewPfData; LV leavesr; 2x else; //--------------------------------------------------------- // as a precaution, limit options to those visible on screen readc SBFDTA1; 3b dow not %eof; 4b if sbfOption = 1 or sbfOption = 2 or sbfOption = 3; f_RunOptionFile( sbfOption: FileActual: LibActual: '*FIRST ': '*FIRST ': ProgId); 4e endif; sbfOption = 0; update SBFDTA1; SflRcdNbr = rrn; readc SBFDTA1; 3e enddo; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // load array with distinct PF names begsr srViewPfData; bb = 0; 1b for cc = 1 to opnf0100DS.NumFilesRtrned; chain cc SBFDTA1; 2b if FileType = 'pf ' or FileType = 'lf '; FileLib = FileActual + LibActual; // if file type is LF, then go find first PF 3b if FileType = 'lf '; AllocateSize = f_GetAllocSize01(FileLib: '*FIRST '); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : FileLib : '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS ); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; FileLib = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 3e endif; 3b if bb = 0 or %lookup(FileLib: PfNamesArry: 1: bb) = 0; bb += 1; PfNamesArry(bb) = FileLib; 3e endif; 2e endif; 1e endfor; 1b for aa = 1 to bb; f_RunOptionFile( 2: %subst(PfNamesArry(aa):1:10) : %subst(PfNamesArry(aa):11:10) : '*FIRST ': '*FIRST ': ProgId); 1e endfor; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRJOBR - Work with selected jobs // call Qusljob API to list selected active jobs on local system. // call Qsprjobq API to get status of jobs on jobqs. // call Qlgsort to allow sorts of display. // process option selections from subfile. // Added F8 Toggle support for to show current user //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRJOBD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D FunctionType s 1a D Status s 10a D SJOBQ s 10a D SJOBQLIB s 10a D SSUBSYSTEM s 10a D SJOBQSTAT s like(sThreadSta) D UserID s 10a inz(*user) D LenofDataBuff s 10i 0 D NumberOfKeys s 10i 0 inz(7) D aa s 3u 0 D rrn s 5u 0 D rrnsave s 5u 0 D ScanValue s 10a D ScanValueLen s 3u 0 D IsGeneric s n D IsSelected s n D QuickSort s 200a based(QusljobPtr) D SwapName s 10a D savrcdnbr s like(sflrcdnbr) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define UserSpaceHeaderDS /Define f_RunOptionJob /Define f_Quscrtus /Define f_RmvSflMsg /Define f_SndSflMsg /Define f_GetDayName /Define Qlgsort /Define f_AddSortKey /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // load request key values D KeyValues ds qualified D key1 10i 0 inz(0101) active job status D key2 10i 0 inz(0305) active job status D key3 10i 0 inz(0601) function name D key4 10i 0 inz(0602) function type D key5 10i 0 inz(1004) job queue D key6 10i 0 inz(1802) runpty D key7 10i 0 inz(1903) status on queue D RunDS ds qualified D RunPriority 10i 0 1802 D keyds ds qualified based(uKeyPtr) D LengthReturn 10i 0 overlay(keyds:1) D KeyField 10i 0 overlay(keyds:5) D LengthOfData 10i 0 overlay(keyds:13) D Data 20a overlay(keyds:17) D QSPRJOBQDS ds 145 qualified D SubSys 10a overlay(QSPRJOBQDS:63) //--*CALL PROTOTYPES--------------------------------------- D Qsprjobq PR extpgm('QSPRJOBQ') Retrieve Jobq Info Db 145a Receiver D 10i 0 const Receiver Length D 8a const Api Format D 20a const Qualified JobQ Name Db like(ApiErrDS) Error Parm D Qusljob PR extpgm('QUSLJOB ') list jobs D 20a user space D 8a const api format D 26a qualified job name D 10a status Db like(ApiErrDS) D 1a const type jobs D 10i 0 number of keys D 16a integer key array // data structure to retrieve job list entries D QusljobDS DS qualified based(QusljobPtr) D JobName 10a overlay(QusljobDS:1) D UserName 10a overlay(QusljobDS:11) D JobNumber 6a overlay(QusljobDS:21) D IntJobID 16a overlay(QusljobDS:27) D JobStatus 8a overlay(QusljobDS:43) D JobType 1a overlay(QusljobDS:53) D KeyReturnCtn 10i 0 overlay(QusljobDS:61) D CurrUser 10a overlay(QusljobDS:101) //--*ENTRY PARMS------------------------------------------- D p_JCRJOBR PR extpgm('JCRJOBR') D 26a Qualified Job ID D 7a Job Status D 4a Thread D 10a selected jobq D p_JCRJOBR PI D pJobNameQual 26a D pJobStatus 7a D pThreadStat 4a D pSelectJobq 10a //--------------------------------------------------------- /free Status = pJobStatus; IsGeneric = *off; Toggle1 = *blanks; evalr scDow = %trimr(f_GetDayName()); // Extract jobq scan value and length of scan value 1b if pSelectJobq <> '*ALL '; 2b if %subst(pSelectJobq: 10: 1) <> ' ' and %subst(pSelectJobq: 10: 1) <> '*'; ScanValue = pSelectJobq; ScanValueLen = 10; 2x else; aa = %scan('*': pSelectJobq: 1); 3b if aa > 0; IsGeneric = *on; 3x else; aa = %scan(' ': pSelectJobq: 1); 3e endif; ScanValue = %subst(pSelectJobq: 1: aa - 1); ScanValueLen = aa-1; 2e endif; 1e endif; //--------------------------------------------------------- // Call API to load user space with job information. GenericHeaderPtr = f_Quscrtus(UserSpaceName); 1b dou not (InfdsFkey = f05); //refresh Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; callp QUSLJOB( UserSpaceName: 'JOBL0200': pJobNameQual: Status: ApiErrDS: '*': NumberOfKeys: KeyValues); exsr srLoadFromUserSpace; // allow user to make selection from subfile. Ind.sfldsp = (rrn > 0); 2b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No Jobs were found.'); 2e endif; Ind.sfldspctl = *on; SflRcdNbr = 1; 2b dow not (InfdsFkey = f03); write MSGCTL; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); savrcdnbr = SFLRECNBR; // from infds // sort list entries in user space. 3b if InfdsFkey = f09 // sort by job name or InfdsFkey = f10; // sort by user name Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; qlgSortDS = %subst(qlgSortDS: 1: 80); //drop off keys QusljobPtr = GenericHeaderPtr + GenericHeader.OffSetToList; qlgsortDS.RecordLength = GenericHeader.ListEntrySize; qlgsortDS.RecordCount = GenericHeader.ListEntryCount; qlgsortDS.NumOfKeys = 1; 4b if InfdsFkey = f09; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1: 10); 4x else; 5b if Toggle1 = 'Current'; // current user qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(101: 10); 5x else; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(11: 10); 5e endif; 4e endif; qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); LenofDataBuff = GenericHeader.ListEntryCount * GenericHeader.ListEntrySize; callp QLGSORT( qlgsortDS: QuickSort: QuickSort: LenofDataBuff: LenofDataBuff: ApiErrDS); exsr srLoadFromUserSpace; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; SflRcdNbr = 1; 2i iter; 3x elseif InfdsFkey = f05 or InfdsFkey = f03 or InfdsFkey = f12; 2v leave; 3x elseif InfdsFkey = f08; 4b if Toggle1 = *blanks; // swap column headings Toggle1 = 'Current'; 4x else; Toggle1 = *blanks; 4e endif; 4b for rrn = 1 to rrnsave; chain rrn SBFDTA1; SwapName = sUserName; sUserName = sCurrUser; sCurrUser = SwapName; update SBFDTA1 %fields(sCurrUser: sUserName); 4e endfor; sflrcdnbr = savrcdnbr; 2i iter; 3x elseif not Ind.sfldsp; 2i iter; 3e endif; //--------------------------------------------------------- // find record in subfile user has selected. // values from changed record are sent to a function. // If user has pressed enter but made no selection, exit. readc SBFDTA1; 3b if %eof; 2v leave; 3e endif; 3b dow not %eof; 4b if sbfOption > 0; 5b if Toggle1 = 'Current'; // current user SwapName = sCurrUser; 5x else; SwapName = sUserName; 5e endif; f_RunOptionJob( sbfOption: sJobName: SwapName: sJobNum: ProgId); SflRcdNbr = rrn; //STAY ON SCREEN sbfOption = 0; update SBFDTA1; 4e endif; readc SBFDTA1; 3e enddo; 2e enddo; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // Process list entries in user space. begsr srLoadFromUserSpace; QusljobPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; IsSelected = *on; 2b if not(QusljobDS.JobStatus = '*ACTIVE ' or QusljobDS.JobStatus = '*JOBQ '); clear sFuncName; clear sRunPty; clear QusljobDS.JobType; clear sThreadSta; sJobType = *blanks; 2x else; //--------------------------------------------------------- // Unload key values ukeyPtr = QusljobPtr + 64; 3b for aa = 1 to QusljobDS.KeyReturnCtn; 4b if keyds.KeyField = 0101; sThreadSta = keyds.Data; 4x elseif keyds.KeyField = 0305; sCurrUser = keyds.Data; 4x elseif keyds.KeyField = 0601; sFuncName = keyds.Data; 4x elseif keyds.KeyField = 0602; FunctionType = keyds.Data; 4x elseif keyds.KeyField = 1802; RunDS = keyds.data; 4e endif; 4b if QusljobDS.JobStatus = '*JOBQ '; 5b if keyds.KeyField = 1004; sJobQ = %subst(keyds.Data: 1: 10); // validate jobq selection; 6b if pSelectJobq = '*ALL ' or (IsGeneric and %subst(sJobq:1 :ScanValueLen) = %subst(ScanValue: 1 : ScanValueLen)) or (not IsGeneric and sJobq = ScanValue); 6x else; IsSelected = *off; 3v leave; 6e endif; sJobqLib = %subst(keyds.Data: 11: 10); // get jobq attached subsystem name callp QSPRJOBQ( QSPRJOBQDS: 145: 'JOBQ0100': sJobq + sJobqLib: ApiErrDS); sSubSystem = QSPRJOBQDS.SubSys; 5x elseif keyds.KeyField = 1903; sJobqStat = keyds.Data; 5e endif; 4e endif; ukeyPtr += keyds.LengthReturn; 3e endfor; 3b if FunctionType = 'D'; sFuncName = 'DLYW-' + sFuncName; 3e endif; sRunPty = %char(RunDS.RunPriority); 3b if QusljobDS.JobType = ' '; sJobType = 'Invalid'; 3x elseif QusljobDS.JobType = 'A'; sJobType = 'Auto Start'; 3x elseif QusljobDS.JobType = 'B'; sJobType = 'Batch '; 3x elseif QusljobDS.JobType = 'I'; sJobType = 'Interactive'; 3x elseif QusljobDS.JobType = 'M'; sJobType = 'Sbs Monitor'; 3x elseif QusljobDS.JobType = 'R'; sJobType = 'Spooled Rdr'; 3x elseif QusljobDS.JobType = 'S'; sJobType = 'System Job'; 3x elseif QusljobDS.JobType = 'W'; sJobType = 'Spooled Wtr'; 3x elseif QusljobDS.JobType = 'X'; sJobType = 'SCPF Job'; 3x else; sJobType = ' '; 3e endif; 2e endif; 2b if IsSelected; 3b if QusljobDS.JobStatus = '*JOBQ '; sJobType = sJobQ; sFuncName = sJobqLib; sRunPty = sSubSystem; sThreadSta = sJobqStat; 3e endif; sJobName = QusljobDS.JobName; sUserName = QusljobDS.UserName; 3b if Toggle1 = 'Current'; // current user SwapName = sUserName; sUserName = sCurrUser; sCurrUser = SwapName; 3e endif; sJobNum = QusljobDS.JobNumber; sJobStatus = QusljobDS.JobStatus; 3b if (pThreadStat = '*ALL' or pThreadStat = sThreadSta); rrn += 1; write SBFDTA1; 3e endif; 2e endif; QusljobPtr += GenericHeader.ListEntrySize; 1e endfor; rrnsave = rrn; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRJRNA - Display journaled physical files - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Display Journaled PF Files') PARM KWD(JOURNAL) TYPE(JOURNAL) MIN(1) PROMPT('Journal Name:') JOURNAL: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*JRN ') ]]> v5r4 *---------------------------------------------------------------- * JCRJRNAD- Display journaled physical files -DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA11 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SBFOBJNAM 10A O 6 3 A SBFOBJLIB 10A O 6 15 A SBFOBJTYP 10A O 6 27 A SBFOBJTXT 30A O 6 38 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(16) SFLSIZ(1488) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A 1 2'JCRJRNAR' COLOR(BLU) A 1 23'Display Journaled PF Files' A DSPATR(HI) A 1 53SYSNAME COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Journal:' A SCRJRNNAME 10A O 2 11DSPATR(UL) A 2 22'Lib:' A SCRJRNLIB 10A O 2 27DSPATR(UL) A 2 41'Receiver:' A SCRATTRCVN 10A O 2 51DSPATR(UL) A 2 62'Lib:' A SCRATTRCVL 10A O 2 67DSPATR(UL) A 3 5'Text:' A SCRJRNTEXT 50A O 3 11 A 4 2'Files:' A SCRTOTFILE 7Y 0O 4 9EDTCDE(4) DSPATR(UL) A 4 18'Mbrs:' A SCRTOTMBR 7Y 0O 4 24EDTCDE(4) DSPATR(UL) A 4 33'Dtaara:' A SCRTOTDTAA 7Y 0O 4 41EDTCDE(4) DSPATR(UL) A 4 50'Dtaq:' A SCRTOTDTAQ 7Y 0O 4 56EDTCDE(4) DSPATR(UL) A 4 65'IFS:' A SCRTOTIFS 7Y 0O 4 70EDTCDE(4) DSPATR(UL) A 5 3'Object' DSPATR(HI) A 5 15'Lib' DSPATR(HI) A 5 27'Type' DSPATR(HI) A 5 38'Text' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R SBFDTA2 SFL A SBF2RCVNAM 10A O 6 3 A SBF2RCVLIB 10A O 6 15 A SBF2ATTDAT L O 6 29DATFMT(*ISO) A SBF2ATTTIM T O 6 41TIMFMT(*HMS) A SBF2STATUS 1A O 6 53 *---------------------------------------------------------------- A R SBFCTL2 SFLCTL(SBFDTA2) OVERLAY A SFLPAG(13) SFLSIZ(560) A 41 SFLDSP A 42 SFLDSPCTL A N42 SFLCLR A N44 SFLEND(*MORE) A 1 2'JCRJRNAR' COLOR(BLU) A 1 23'List Journal Receivers' DSPATR(HI) A 1 62'jcr' COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Journal:' A SCRJRNNAME 10A O 2 11DSPATR(UL) A 2 22'Lib:' A SCRJRNLIB 10A O 2 27DSPATR(UL) A 2 72SYSNAME COLOR(BLU) A 3 5'Text:' A SCRJRNTEXT 50A O 3 11 A 5 3'Receiver' DSPATR(HI) A 5 15'Lib' DSPATR(HI) A 5 28'Attached Date/Time' DSPATR(HI) A 5 51'Status' DSPATR(HI) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRJRNA'.Display Journaled PF Files (JCRJRNA) - Help .*-------------------------------------------------------------------- :P.This JCR command accepts journal name then shows list of all physical files being journaled by that journal name.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRJRNA/JOURNAL'.Journal Name - Help :XH3.Journal Name (JOURNAL) :P.Name and library of journal to be selected.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRJRNAR - Display journaled physical files // Loads subfile with list of journal receivers then call QjoRetrieveJournalInformation // API to load another subfile with list of journaled files. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRJRNAD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F sfile(SBFDTA2: rrn2) indds(Ind) //--*STAND ALONE------------------------------------------- D TotObjs s 10u 0 D ForCount s 10i 0 D ApiFormatName s 8a D Count s 7p 0 D rrn2 s like(rrn) D RepeatKeyPtrSv s * D NumberOfKeys s 10i 0 based(KeyInfoPtr) //--*DATA STRUCTURES--------------------------------------- D GetAllocSizeDS ds 800 qualified D SizeJrnInfo 10i 0 overlay(GetAllocSizeDS:1) // Map Journal Info to Retrieve parameter. // InfoCount = 2 means I want Journal Receiver AND journaled file info. D InfoToRtv ds D InfoCount 10i 0 inz(2) D InfoVarDS 100a D InfoVar ds align D InfoVLlen 10i 0 inz length of VL record D InfoKey 10i 0 inz key of info to retur D InfoLOD 10i 0 inz length of data D InfoData 38a actual data D RJRN0100ds DS based(RJRN0100dsptr) qualified D OffsetToKey 10i 0 overlay(RJRN0100ds:9) D JrnName 10a overlay(RJRN0100ds:13) D JrnLib 10a overlay(RJRN0100ds:23) D JrnText 50a overlay(RJRN0100ds:136) D AttRcvName 10a overlay(RJRN0100ds:201) D AttRcvLib 10a overlay(RJRN0100ds:211) // repeat for each key specified. rjrn0100 format. Offsets to key data D RepeatKeyDS ds align based(RepeatKeyPtr) qualified D Key 10i 0 D StartOfKey 10i 0 D LenHeader 10i 0 D NumEntries 10i 0 D LenEntry 10i 0 // Type Definition for Key 1 Output Section D Key1OutputDS ds based(Key1OutputDSPtr) qualified D NumberOfRcv 10i 0 // Type Definition for Repeating Key 1 Output D Key1RepeatDS DS based(Key1RepeatDSptr) qualified D RcvNam 10a overlay(Key1RepeatDS:1) D RcvLib 10a overlay(Key1RepeatDS:11) D ADateTime 13a overlay(Key1RepeatDS:26) D Status 1a overlay(Key1RepeatDS:39) // Type Definition for Key 2 Output Section D Key2OutputDS DS based(Key2OutputDSPtr) qualified D NumberOfFiles 10i 0 D NumberOfMbrs 10i 0 D NumberOfDtaara 10i 0 D NumberOfDtaq 10i 0 D NumberOfIFS 10i 0 // Type Definition for Repeating Key 2 Output D Key2RepeatDS DS based(Key2RepeatDSptr) qualified D ObjType 10a D FileNam 10a D FileLib 10a //--*CALL PROTOTYPES--------------------------------------- D p_RtvJrnInfo PR extproc D ('QjoRetrieveJournalInformation') D 800a options(*varsize) D 10i 0 const D 20a D 8a D 104a Db like(ApiErrDS) //--*FUNCTION PROTOTYPES----------------------------------- D f_RestrictNum PR 7p 0 D 10i 0 //--*COPY DEFINES------------------------------------------ /Define Ind /Define Sds /Define Constants /Define Infds /Define ApiErrDS /Define FunctionKeys /Define f_SndSflMsg /Define f_Qusrobjd /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRJRNAR PR extpgm('JCRJRNAR') D 20a D p_JCRJRNAR PI D p_JrnLib 20a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); //--------------------------------------------------------- // Load DS with values to return journaled object info. // 1 = key value for journal receivers // 0 = length of object type selector (N/A for receivers) // *blanks = (N/A for receivers) //--------------------------------------------------------- InfoKey = 1; //journal receivers InfoLOD = 0; InfoVLlen = 12; //length of VL record InfoData = *blanks; InfoVarDS = InfoVar; // 2 = key value for objects // 10 = length of object type selector *all // *ALL = return all object types being journaled InfoKey = 2; //files journaled InfoLOD = 10; InfoVLlen = 22; InfoData = '*FILE '; InfoVarDS = %trimr(InFoVarDS) + InfoVar; ApiFormatName = 'RJRN0100'; callp p_RtvJrnInfo( GetAllocSizeDS: %len(GetAllocSizeDS): p_JrnLib: ApiFormatName: InfoToRtv: ApiErrDS); RJRN0100dsptr = %alloc(GetAllocSizeDS.SizeJrnInfo); callp p_RtvJrnInfo( RJRN0100ds: GetAllocSizeDS.SizeJrnInfo: p_JrnLib: ApiFormatName: InfoToRtv: ApiErrDS); KeyInfoPtr = RJRN0100dsptr + RJRN0100ds.OffsetToKey; // load jrn and 1st receiver info for display scrJrnName = RJRN0100ds.JrnName; scrJrnLib = RJRN0100ds.JrnLib; scrJrnText = RJRN0100ds.JrnText; scrAttRcvN = RJRN0100ds.AttRcvName; scrAttRcvL = RJRN0100ds.AttRcvLib; //--------------------------------------------------------- // First I want to get number of Keys that are returned. In this case it should be 2 // as that is all I asked for. Then spin down key offsets until I find key number 2. // That will be journaled files. RepeatKeyPtr = KeyInfoPtr + %size(RJRN0100ds.OffsetToKey); RepeatKeyPtrSv = RepeatKeyPtr; 1b for ForCount = 1 to NumberOfKeys; 2b if RepeatKeyDS.Key = 1; //Journal Receivers // exsr srGetReceiverNames; // exsr srShowSubfile2; 2x elseif RepeatKeyDS.Key = 2; //Journaled files exsr srGetFileNames; exsr srShowSubfile1; 2x elseif RepeatKeyDS.Key = 3; //Remote Journal Info // not coded 2e endif; RepeatKeyPtr += 20; 1e endfor; dealloc RJRN0100dsptr; *inlr = *on; return; //--------------------------------------------------------- // Load subfile of all receivers attached to this journal begsr srGetReceiverNames; Key1OutputDSptr = RepeatKeyPtrSv + RepeatKeyDS.StartOfKey; Key1RepeatDSptr = Key1OutputDSptr + 20; 1b for Count = 1 to Key1OutputDS.NumberOfRcv; sbf2RcvNam = Key1RepeatDS.RcvNam; sbf2RcvLib = Key1RepeatDS.RcvLib; sbf2Status = Key1RepeatDS.Status; sbf2AttDat = %date('20' + %subst(Key1RepeatDS.ADateTime: 2: 6): *ISO0); sbf2AttTim = %time(%subst(Key1RepeatDS.ADateTime: 8: 6): *HMS0); rrn2 += 1; write SBFDTA2; Key1RepeatDSptr += 128; 1e endfor; endsr; //--------------------------------------------------------- // Process journaled file names. use offsets to spin through file names. begsr srGetFileNames; sbfObjNam = *blanks; sbfObjLib = *blanks; Key2OutputDSptr = RepeatKeyPtrSv + RepeatKeyDS.StartOfKey; Key2RepeatDSptr = Key2OutputDSptr + 36; TotObjs = Key2OutputDS.NumberOfFiles + Key2OutputDS.NumberOfMbrs + Key2OutputDS.NumberOfDtaara + Key2OutputDS.NumberOfDtaq + Key2OutputDS.NumberOfIFS; scrTotFile = Key2OutputDS.NumberOfFiles; scrTotFile = f_RestrictNum(Key2OutputDS.NumberOfFiles); scrTotMbr = f_RestrictNum(Key2OutputDS.NumberOfMbrs); scrTotDtaa = f_RestrictNum(Key2OutputDS.NumberOfDtaara); scrTotDtaq = f_RestrictNum(Key2OutputDS.NumberOfDtaq); scrTotIfs = f_RestrictNum(Key2OutputDS.NumberOfIFS); 1b for Count = 1 to TotObjs; 2b if Key2RepeatDS.ObjType = '*FILE '; sbfObjNam = Key2RepeatDS.FileNam; sbfObjTyp = Key2RepeatDS.ObjType; sbfObjLib = Key2RepeatDS.FileLib; QusrObjDS = f_QUSROBJD(sbfObjNam + sbfObjLib: sbfObjTyp); sbfObjTxt = QusrObjDS.Text; rrn += 1; write SBFDTA1; 2e endif; Key2RepeatDSptr += 48; 1e endfor; endsr; //--------------------------------------------------------- // allow user to make selection from subfile. begsr srShowSubfile2; Ind.sfldsp2 = (rrn2 > 0); Ind.sfldspctl2 = *on; 1b dow not (InfdsFkey = f03); write MSGCTL; write SFOOTER1; // display subfile exfmt SBFCTL2; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // allow user to make selection from subfile. begsr srShowSubfile1; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No Files are being journaled.'); 1e endif; InfdsFkey = *blanks; 1b dow not (InfdsFkey = f03); write MSGCTL; write SFOOTER1; // display subfile exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2e endif; 2b if not Ind.sfldsp; 1i iter; 2e endif; 1e enddo; endsr; /end-free //--*FUNCTIONS START HERE---------------------------------- // Make sure values are not too large to fit in screen fields P f_RestrictNum b D f_RestrictNum PI 7p 0 D p_TenIn 10i 0 D packed7 s 7p 0 /free 1b if p_TenIn > 9999999; packed7 = 9999999; 1x else; packed7 = p_TenIn; 1e endif; return packed7; /end-free P f_RestrictNum e ]]> v5r4 *---------------------------------------------------------------- * JCRLCMD - Least common multiple/greatest common divisor - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A 1 2'JCRLCM' COLOR(BLU) A 1 22'Least Common Multiple' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 21'Greatest Common Divisor' DSPATR(HI) A 2 72SYSNAME COLOR(BLU) A 4 7'Enter up to 4 values. Press Enter - A to find LCM/GCD' A 6 41'LCM' A 6 61'GCD' A N1 3Y 0B 7 7EDTCDE(4) A CHECK(FE RB) A N2 3Y 0B 7 12EDTCDE(4) A CHECK(FE RB) A N3 3Y 0B 7 17EDTCDE(4) A CHECK(FE RB) A N4 3Y 0B 7 22EDTCDE(4) A CHECK(FE RB) A SCLCM 11Y 0O 7 33EDTCDE(4) DSPATR(UL) A SCGCD 11Y 0O 7 53EDTCDE(4) DSPATR(UL) A SCX1 3Y 0O 10 4EDTCDE(4) A SCX2 3Y 0O 10 9EDTCDE(4) A SCX3 3Y 0O 10 14EDTCDE(4) A SCX4 3Y 0O 10 19EDTCDE(4) A SCX5 3Y 0O 10 24EDTCDE(4) A SCX6 3Y 0O 10 29EDTCDE(4) A SCX7 3Y 0O 10 34EDTCDE(4) A SCX8 3Y 0O 10 39EDTCDE(4) A SCX9 3Y 0O 10 44EDTCDE(4) A SCX10 3Y 0O 10 49EDTCDE(4) A SCX11 3Y 0O 10 54EDTCDE(4) A SCX12 3Y 0O 10 59EDTCDE(4) A SCX13 3Y 0O 10 64EDTCDE(4) A SCX14 3Y 0O 10 69EDTCDE(4) A SCX15 3Y 0O 10 74EDTCDE(4) A SCF1 3Y 0O 11 3EDTCDE(4) A SCF2 3Y 0O 11 8EDTCDE(4) A SCF3 3Y 0O 11 13EDTCDE(4) A SCF4 3Y 0O 11 18EDTCDE(4) A SCF5 3Y 0O 11 23EDTCDE(4) A SCF6 3Y 0O 11 28EDTCDE(4) A SCF7 3Y 0O 11 33EDTCDE(4) A SCF8 3Y 0O 11 38EDTCDE(4) A SCF9 3Y 0O 11 43EDTCDE(4) A SCF10 3Y 0O 11 48EDTCDE(4) A SCF11 3Y 0O 11 53EDTCDE(4) A SCF12 3Y 0O 11 58EDTCDE(4) A SCF13 3Y 0O 11 63EDTCDE(4) A SCF14 3Y 0O 11 68EDTCDE(4) A SCF15 3Y 0O 11 73EDTCDE(4) A SCX16 3Y 0O 13 4EDTCDE(4) A SCX17 3Y 0O 13 9EDTCDE(4) A SCX18 3Y 0O 13 14EDTCDE(4) A SCX19 3Y 0O 13 19EDTCDE(4) A SCX20 3Y 0O 13 24EDTCDE(4) A SCF16 3Y 0O 14 3EDTCDE(4) A SCF17 3Y 0O 14 8EDTCDE(4) A SCF18 3Y 0O 14 13EDTCDE(4) A SCF19 3Y 0O 14 18EDTCDE(4) A SCF20 3Y 0O 14 23EDTCDE(4) A 24 3'Cmd3 - EXIT' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRLCMR - find least common multiple or greatest common divisor //--------------------------------------------------------- // N1=8 N2=6 // N1FactorsArry = 2 2 2 N2FactorsArry = 2 3 // PrimesArry = 2 2 2 3 for LCM of 24. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRLCMD cf e workstn infds(Infds) //--*DATA STRUCTURES--------------------------------------- D Infds ds D fkey 1a overlay(Infds:369) D f03 c const(X'33') //--*STAND ALONE------------------------------------------- D WorkArry s 20u 0 inz dim(20) descend D N1FactorsArry s 20u 0 inz dim(20) D N2FactorsArry s 20u 0 inz dim(20) D N3FactorsArry s 20u 0 inz dim(20) D N4FactorsArry s 20u 0 inz dim(20) D HiPrimesArry s 20u 0 dim(20) prime numbers D LargeExpArry s 20u 0 dim(20) largest exponents D Primefactor s 20u 0 prime numbers D PrimeExponent s 20u 0 largest exponents D SmallestNone0 s 5u 0 D cc s 5u 0 D aa s 20u 0 D bb s 20u 0 D nn s 3u 0 D xx s 3u 0 D yy s 3u 0 D zz s 3u 0 D Quotient s 20u 0 D IsAllFactored s n //--------------------------------------------------------- /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY /free evalr scDow = %trimr(f_GetDayName()); 1b dou fkey = f03; exfmt SCREEN; 2b if not (fkey = f03); exsr Load_Arrays_With_Prime_Factors_For_Each_Denominator; exsr Load_Array_With_Highest_Exponent_Prime_Factors; exsr Calculate_LCM_From_Highest_Exponent_Prime_Factors; exsr Load_Data_To_Screen_Fields; scgcd = 1; 3b if N1 > 0 or N2 > 0 or N3 > 0 or N4 > 0; exsr Calc_Greatest_Common_Divisor; 3e endif; 2e endif; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- begsr Calc_Greatest_Common_Divisor; scgcd = 1; SmallestNone0 = *hival; // get smallest number entered. 1b if N1 > 0 and N1 < SmallestNone0; SmallestNone0 = N1; 1e endif; 1b if N2 > 0 and N2 < SmallestNone0; SmallestNone0 = N2; 1e endif; 1b if N3 > 0 and N3 < SmallestNone0; SmallestNone0 = N3; 1e endif; 1b if N4 > 0 and N4 < SmallestNone0; SmallestNone0 = N4; 1e endif; 1b for cc = 1 to SmallestNone0; 2b if %rem(N1:cc) = 0 and %rem(N2:cc) = 0 and %rem(N3:cc) = 0 and %rem(N4:cc) = 0; scgcd = cc; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr Load_Arrays_With_Prime_Factors_For_Each_Denominator; N1FactorsArry(*) = 0; N2FactorsArry(*) = 0; N3FactorsArry(*) = 0; N4FactorsArry(*) = 0; 1b for NN = 1 to 4; // LOAD EACH OF 4 INPUT FIELDS INTO WORK FIELD 2b if nn = 1; Quotient = N1; 2x elseif nn = 2; Quotient = N2; 2x elseif nn = 3; Quotient = N3; 2x elseif nn = 4; Quotient = N4; 2e endif; 2b if Quotient > 0; // LOAD ARRAYS WITH PRIME FACTORS FOR EACH DENOMINATOR reset IsAllFactored; reset bb; 3b dou IsAllFactored; 4b for aa = 1 to Quotient; // ALLOW FOR 1 AS DENOMINATOR 5b if Quotient = 1 or (aa > 1 and Quotient > 1); 6b if %rem(Quotient:aa) = 0; bb += 1; Quotient = Quotient/aa; 7b if nn = 1; N1FactorsArry(bb) = aa; 7x elseif nn = 2; N2FactorsArry(bb) = aa; 7x elseif nn = 3; N3FactorsArry(bb) = aa; 7x elseif nn = 4; N4FactorsArry(bb) = aa; 7e endif; 4v leave; 6e endif; 5e endif; 4e endfor; 4b if Quotient = 1; 3v leave; 4e endif; 3e enddo; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr Load_Array_With_Highest_Exponent_Prime_Factors; HiPrimesArry(*) = 0; LargeExpArry(*) = 0; WorkArry(*) = 0; yy = 0; 1b for NN = 1 to 4; 2b if nn = 1; WorkArry = N1FactorsArry; 2x elseif nn = 2; WorkArry = N2FactorsArry; 2x elseif nn = 3; WorkArry = N3FactorsArry; 2x elseif nn = 4; WorkArry = N4FactorsArry; 2e endif; sorta WorkArry; PrimeFactor = 0; PrimeExponent = 0; //--------------------------------------------------------- // Idea is spin down each array and count number // of same factor. then use that value to check // array of hi primes. If current value of exponents // is higher than previous value. replace exponent // count with higher value. // If factor is not in array of high primes, // then add element. //--------------------------------------------------------- 2b for xx = 1 to 20; 3b if WorkArry(1) = 0; 2v leave; 3e endif; 3b if xx = 1; Primefactor = WorkArry(xx); PrimeExponent = 1; 3x else; 4b if Primefactor = WorkArry(xx); PrimeExponent = PrimeExponent + 1; 4x else; //--------------------------------------------------------- // At this point, I have counted all same // number factors. lookup into hi prime array // and see if this count is higher than any // previous count, if so update array of largest exponents. //--------------------------------------------------------- zz = %lookup(PrimeFactor:HiPrimesArry:1:20); 5b if zz = 0; yy = yy + 1; HiPrimesArry(yy) = PrimeFactor; LargeExpArry(yy) = PrimeExponent; 5x else; 6b if PrimeExponent > LargeExpArry(zz); LargeExpArry(zz) = PrimeExponent; 6e endif; 5e endif; 5b if WorkArry(xx) = 0; 2v leave; 5x else; Primefactor = WorkArry(xx); PrimeExponent = 1; 5e endif; 4e endif; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- begsr Calculate_LCM_From_Highest_Exponent_Prime_Factors; sclcm = 1; 1b for xx = 1 to 20; 2b if HiPrimesArry(xx) = 0; 1v leave; 2e endif; SCLCM = SCLCM * (HiPrimesArry(xx)**LargeExpArry(xx)); 1e endfor; endsr; //--------------------------------------------------------- begsr Load_Data_To_Screen_Fields; scf1 = HiPrimesArry(1); scf2 = HiPrimesArry(2); scf3 = HiPrimesArry(3); scf4 = HiPrimesArry(4); scf5 = HiPrimesArry(5); scf6 = HiPrimesArry(6); scf7 = HiPrimesArry(7); scf8 = HiPrimesArry(8); scf9 = HiPrimesArry(9); scf10 = HiPrimesArry(10); scf11 = HiPrimesArry(11); scf12 = HiPrimesArry(12); scf13 = HiPrimesArry(13); scf14 = HiPrimesArry(14); scf15 = HiPrimesArry(15); scf16 = HiPrimesArry(16); scf17 = HiPrimesArry(17); scf18 = HiPrimesArry(18); scf19 = HiPrimesArry(19); scf20 = HiPrimesArry(20); scx1 = LargeExpArry(1); scx2 = LargeExpArry(2); scx3 = LargeExpArry(3); scx4 = LargeExpArry(4); scx5 = LargeExpArry(5); scx6 = LargeExpArry(6); scx7 = LargeExpArry(7); scx8 = LargeExpArry(8); scx9 = LargeExpArry(9); scx10 = LargeExpArry(10); scx11 = LargeExpArry(11); scx12 = LargeExpArry(12); scx13 = LargeExpArry(13); scx14 = LargeExpArry(14); scx15 = LargeExpArry(15); scx16 = LargeExpArry(16); scx17 = LargeExpArry(17); scx18 = LargeExpArry(18); scx19 = LargeExpArry(19); scx20 = LargeExpArry(20); endsr; ]]> v5r4 //--------------------------------------------------------- // JCRLICUSE - List users holding lock on license // Call QLZARTV API to return of users with locks on licensed products. // Call long text API QUILNGTX as quick method to display results // Note: You will need to change product id and feature subfield to whatever product // you wish to monitor. Currently set to monitor license usage for ASC Sequel //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs //--*STAND ALONE------------------------------------------- D TextString s 6800a D TextStringLen s 10i 0 inz(6800) D LineOfText s 68a dim(100) based(ptr) D ptr s * inz(%addr(TextString)) D MessageID s 7a D MessageFile s 20a D OutputFormat s 8a inz('LICR0200') D ReceiverLen s 10i 0 inz(%len(ReceiverDS)) D ProductFormat s 8a inz('LICP0100') D xx s 3u 0 D yy s 3u 0 D TotLicAlpha s 13a //--*DATA STRUCTURES--------------------------------------- D JobDS ds 26 qualified D JobName 10a overlay(JobDS:1) D UserName 10a overlay(JobDS:11) D Number 6a overlay(JobDS:21) // note these values for your product can be found executing WRKLICINF command D ProductIDDS ds qualified D ProductID 7a inz('0ASCSEQ') D ReleaseLevel 6a inz('*ONLY ') D Feature 4a inz('5001') D ReceiverDS ds 2065 qualified inz D UsageLimit 10i 0 overlay(ReceiverDS:9) D UsageCount 10i 0 overlay(ReceiverDS:13) D UsersOffset 10i 0 overlay(ReceiverDS:97) D UsersCount 10i 0 overlay(ReceiverDS:101) D UserLength 10i 0 overlay(ReceiverDS:105) // Error return code parm for APIs. D ApiErrDS ds qualified D BytesProvided 10i 0 inz(%len(ApiErrDS)) D BytesReturned 10i 0 D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a //--*CALL PROTOTYPES--------------------------------------- D QUILNGTX PR extpgm('QUILNGTX') Long Text D 6800a options(*varsize) Text D 10i 0 Text Length D 7a Message ID D 20a Message File Name Db like(ApiErrDS) Error Parm D QLZARTV PR extpgm('QLZARTV') Retrieve License Inf D 2065a Receiver D 10i 0 Length of Receiver D 8a Structure Format Db 8a Product ID D 8a Product ID Format Db like(ApiErrDS) Error Parm //--------------------------------------------------------- /free // retrieve license information QLZARTV( ReceiverDS: ReceiverLen: OutputFormat: ProductIDds: ProductFormat: ApiErrDS); //--------------------------------------------------------- // Load number of licenses available 1b if ReceiverDS.UsageLimit = -1; TotLicAlpha = '*NOMAX'; 1x else; TotLicAlpha = %editc(ReceiverDS.UsageLimit:'1'); 1e endif; LineOfText(1) = 'Licenses Available: ' + %trim(TotLicAlpha) + ' Licenses in Use: ' + %triml(%editc(ReceiverDS.UsageCount:'1')); //--------------------------------------------------------- // spacer JobDS.JobName = '________'; JobDS.UserName = '_________'; JobDS.Number = '______'; LineOfText(2) = JobDS.UserName + ' ' + JobDS.JobName + ' ' + JobDS.Number; //--------------------------------------------------------- // generate headings JobDS.JobName = 'Job Name'; JobDS.UserName = 'User Name'; JobDS.Number = 'Number'; LineOfText(3) = JobDS.UserName + ' ' + JobDS.JobName + ' ' + JobDS.Number; //--------------------------------------------------------- // load list of license users yy = 3; ReceiverDS.UsersOffset += 1; 1b for xx = 1 to ReceiverDS.UsersCount; jobDS = %subst(ReceiverDs: ReceiverDS.UsersOffset: ReceiverDS.UserLength); ReceiverDS.UsersOffset += ReceiverDS.UserLength; yy += 1; LineOfText(yy) = JobDS.UserName + ' ' + JobDS.JobName + ' ' + JobDS.Number; 1e endfor; //--------------------------------------------------------- // execute long text API QUILNGTX( TextString: TextStringLen: MessageID: MessageFile: ApiErrDS); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRLJOBD - Find jobd using selected library - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find Library on Jobd Libl') PARM KWD(LIBLE) TYPE(*CHAR) LEN(10) MIN(1) PROMPT('Library on JOBD libl:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRLJOBD'.Find Library on JOBD libl (JCRLJOBD) - Help .*-------------------------------------------------------------------- :P.This JCR command determines if a library is on library list of any jobd. Run before deleting a library as you check to see if there will be any problems after deletion. :P.End result is spooled file listing all JOBDs that use selected library.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRLJOBD/LIBLE'.LIBLE (JCRLJOBD) - Help :XH3.Library on JOBD libl (LIBLE) :P.Library to check for in JOBDs. :PARML.:PT.library-name :PD.Enter name of Library for which to search through JOBDs. associated library name's relative position in library list.:EPARML.:EHELP. :HELP name='JCRLJOBD/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRLJOBDP - Find jobd using selected library - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRLJOBD ' A 20'Find JOBD Using Selected Library' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 1'Search For LIBL:' A P_LIBNAM 10A O 20SPACEA(2) *--- A 1'Jobd' A 13'Library' A +8'Text' A +2'----------------------------------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A OBJNAM 10A O 1 A OBJLIB 10A O 13 A OBJTEXT 40A O +5 ]]> v5r4 //--------------------------------------------------------- // JCRLJOBDR - Find jobd using selected library // call Quslobj API to load jobd Objects. // call Qwdrjobd API to load libraries in list of jobd. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRLJOBDP o e printer oflind(*in99) F usropn //--*STAND ALONE------------------------------------------- D ForCount2 s 5u 0 D JobdLibl s 10a based(JobdLiblPtr) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Quslobj /Define Qwdrjobd /Define UserSpaceHeaderDS /Define f_Qusrobjd /Define f_Quscrtus /Define f_GetDayName /Define f_SndStatMsg /Define f_OvrPrtf /Define f_Dltovr /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // extract library list info. D Jobd0100DS ds 3000 qualified D LibraryOffset 10i 0 overlay(Jobd0100DS:361) D LibraryCount 10i 0 overlay(Jobd0100DS:365) //--*ENTRY PARMS------------------------------------------- D p_JCRLJOBDR PR extpgm('JCRLJOBDR') D 10a D 8a D p_JCRLJOBDR PI D p_LibNam 10a D p_Output 8a //--------------------------------------------------------- /free f_SndStatMsg('Scan for job descriptions using ' + %trimr(p_LibNam) + ' - in progress'); f_OvrPrtf('JCRLJOBDP': *OMIT: p_LibNam); open JCRLJOBDP; evalr scDow = %trimr(f_GetDayName()); write PrtHead; // call API to load object names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0100': '*ALL *ALL ': '*JOBD': ApiErrDS); // Spin through user space. call API then extract libraries // call API then extract libraries QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; callp QWDRJOBD( Jobd0100DS: %size(Jobd0100DS): 'JOBD0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); JobdLiblPtr = %addr(Jobd0100DS) + Jobd0100DS.LibraryOffset; 2b for ForCount2 = 1 to Jobd0100DS.LibraryCount; 3b if JobdLibl = p_LibNam; ObjNam = QuslobjDS.ObjNam; ObjLib = QuslobjDS.ObjLib; QusrObjDS = f_QUSROBJD(QuslobjDS.ObjNam + QuslobjDS.ObjLib: '*JOBD '); ObjText = QusrObjDS.Text; write PrtDetail; 2v leave; 3e endif; JobdLiblPtr += 11; 2e endfor; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; close JCRLJOBDP; f_Dltovr('JCRLJOBDP'); f_DspLastSplf('JCRLJOBDR ': p_Output); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRLKEY - Find desired access path - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find Desired Access Path') PARM KWD(MBR) TYPE(*CHAR) CONSTANT('*FIRST ') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(INCLUDESO) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Include logicals with S/O:') ]]> v5r4 *---------------------------------------------------------------- * JCRLKEYD - Find desired access path - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A INDARA A CA03 A CF07 A CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SCPOS1A 1A P A SCPOS2A 1A P A SCPOS3A 1A P A SCPOS4A 1A P A SCPOS5A 1A P A SCSELECT 1A B 5 2 A SCKEYNAM 10A O 5 4 A SCPOS1 1A O 5 15DSPATR(&SCPOS1A) A SCPOS2 1A O 5 17DSPATR(&SCPOS2A) A SCPOS3 1A O 5 19DSPATR(&SCPOS3A) A SCPOS4 1A O 5 21DSPATR(&SCPOS4A) A SCPOS5 1A O 5 23DSPATR(&SCPOS5A) A SCKEYTXT 38A O 5 28 A SCKEYTYP 1A O 5 68 A SCKEYLEN 5Y 0O 5 71EDTCDE(4) A SCKEYDEC 1A O 5 77 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0036) A *DS4 SFLSIZ(0036) A *DS3 SFLPAG(0018) A *DS4 SFLPAG(0018) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR A 1 3'JCRLKEY' A COLOR(BLU) A 1 23'Find Desired Access Path' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'File:' A COLOR(WHT) A SCOBJHEAD 63A O 2 8 A 2 72SYSNAME COLOR(BLU) A 3 2'X select key in any position or 1,- A 2,3,4,5 to select key field positi- A on(s).' A COLOR(BLU) A 4 2' ' A DSPATR(UL) A DSPATR(HI) A 4 4'Key Field ' A DSPATR(UL) A DSPATR(HI) A 4 15'Key Position' A DSPATR(UL) A DSPATR(HI) A 4 28'Text - A ' A DSPATR(UL) A DSPATR(HI) A 4 67'Type' A DSPATR(UL) A DSPATR(HI) A 4 73'Len' A DSPATR(UL) A DSPATR(HI) A 4 77'Dec' A DSPATR(UL) A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A AFOOTERMSG 1A P A 24 2'F3=Exit' COLOR(BLU) A FOOTERMSG 41 O 24 15DSPATR(&AFOOTERMSG) A 24 69'F12=Cancel' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRLKEY'.Find Desired Access Path (JCRLKEY) - Help .*-------------------------------------------------------------------- :P.This JCR command helps you find a logical file or access path with selected fields as primary/any key. The command prompts for the name of the file (logical or physical) then shows the key field names and what ordinal key position they are available in any logical file built over the physical. You can select to include/exclude files with select/omit keys from your search. :P.Select an X by the field name to list logicals with that key field in any position. If you need the key in a certain position or sequnce of keys, select 1 beside first field, then 2 beside next field, up to 5 key fields. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRLKEY/FILE'.File - Help :XH3.File (FILE) :P.Name and library of file to be selected.:EHELP. :HELP name='JCRLKEY/INCLUDESO'.Include logicals with S/O - Help :XH3.Include logicals with S/O (INCLUDESO) :P.Include or not include key fields from logicals with Select/Omit statements.:EHELP.:EPNLGRP. ]]> v5r4 ‚ //--------------------------------------------------------- ‚ // JCRLKEYR - Find desired access path ‚ // Build subfile of all key fields in file and DBR. ‚ // Allow user to select/sequence up to 5 key fields. ‚ // Call JCRFDR (data base relations display) to show access paths meeting selection criteria ‚ //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRLKEYD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) ‚ //--*STAND ALONE------------------------------------------- D KeyField s 10a D WorkFileQual s 20a D ForCount2 s like(FileScopeArry.NumOfKeys) D ForCount3 s 5u 0 D IsKeysLoaded s n D SaveMessage s like(FooterMsg) ‚ //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define f_BuildString /Define FunctionKeys /Define Ind /Define Qdbldbr /Define Qdbrtvfd /Define Fild0100ds /Define Quslfld /Define Dspatr /Define Tstbts /Define UserSpaceHeaderDS /Define f_GetQual /Define f_GetDayName /Define f_Quscrtus /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY ‚ //--*CALL PROTOTYPES--------------------------------------- D p_JCRFDR PR extpgm('JCRFDR ') D 10a const D 20a D 10a const D 10a const D 4a const D 58a ‚ //--*DATA STRUCTURES--------------------------------------- D ds D KeysArry 15a dim(1000) inz D FldsArry 10a overlay(KeysArry:1) D Pos1Arry 1a overlay(KeysArry:11) D Pos2Arry 1a overlay(KeysArry:12) D Pos3Arry 1a overlay(KeysArry:13) D Pos4Arry 1a overlay(KeysArry:14) D Pos5Arry 1a overlay(KeysArry:15) D ScreenDs ds D scPos1 D scPos2 D scPos3 D scPos4 D scPos5 D scPos1A D scPos2A D scPos3A D scPos4A D scPos5a D scPosArry s 1a dim(5) based(ptr1) key positions D ptr1 s * inz(%addr(scPos1)) D scPosArryA s 1a dim(5) based(ptr2) position attributes D ptr2 s * inz(%addr(scPos1a)) ‚ //--------------------------------------------------------- ‚ // Load keys selected from subfile into single field so it can be passed as parameter ‚ // to data base relations display program p_JCRFDR. ‚ //--------------------------------------------------------- D ParmDS ds 58 qualified D KeyFields 10a dim(5) overlay(ParmDS:1) D KeyPosition 1s 0 dim(5) overlay(ParmDS:51) D SelectOmit n overlay(ParmDS:57) D IsFoundKey n overlay(ParmDS:58) ‚ //--*ENTRY PARMS------------------------------------------- D p_JCRLKEYR PR extpgm('JCRLKEYR') D 10a const D 20a D 4a D p_JCRLKEYR PI D p_Mbr 10a const D p_FileQual 20a D p_IncludeSO 4a ‚ //--------------------------------------------------------- /free aFooterMsg = Blue; 1b if p_IncludeSO = '*YES'; ParmDS.SelectOmit = '1'; FooterMsg = 'F7=Exclude Keys from Select/Omit logicals'; 1x else; ParmDS.SelectOmit = '0'; FooterMsg = 'F7=Include Keys from Select/Omit logicals'; 1e endif; SaveMessage = FooterMsg; evalr scDow = %trimr(f_GetDayName()); ‚ //--------------------------------------------------------- ‚ // if selected file is a logical, the based-on-physical name ‚ // is extracted and processing continues as if physical had ‚ // been selected. GenericHeaderPtr = f_Quscrtus(UserSpaceName); AllocateSize = f_GetAllocSize01(p_FileQual: '*FIRST '); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : p_FileQual: '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 1b if tstbts(Fild0100ds.TypeBits: 2) = 1; p_FileQual = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 1e endif; scObjHead = f_BuildString('& & &': %subst(p_FileQual: 1: 10): %subst(ReturnFileQual: 11: 10): Fild0100ds.FileText); exsr srGetDataBaseRelations; exsr srKeyFieldAttributes; ‚ //--------------------------------------------------------- ‚ // process subfile requests. SflRcdNbr = 1; 1b dow not (InfdsFkey = f03); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; 2b if not Ind.sfldsp; //no records 1i iter; 2e endif; ‚ //--------------------------------------------------------- ‚ // find record in subfile user has selected. ‚ // Load keys selected from subfile into arrays so it can be ‚ // passed as parm to data base relations display program p_JCRFDR. ParmDS.KeyFields(*) = *blanks; ParmDS.KeyPosition(*) = 0; ‚ // Toggle Include/Exclude select/omit logicals aFooterMsg = Blue; 2b if InfdsFkey = f07; ParmDS.SelectOmit = not(ParmDS.SelectOmit); 3b if ParmDS.SelectOmit; FooterMsg = 'F7=Exclude Keys from Select/Omit logicals'; 3x else; FooterMsg = 'F7=Include Keys from Select/Omit logicals'; 3e endif; SaveMessage = FooterMsg; exsr srGetDataBaseRelations; exsr srKeyFieldAttributes; 2e endif; aa = 0; IsKeysLoaded = *off; readc SBFDTA1; 2b dow not %eof; 3b if scSelect > *blanks; IsKeysLoaded = *on; aa += 1; 4b if aa > 5; 2v leave; 4e endif; ParmDS.KeyFields(aa) = scKeyNam; ‚ // load zero if don't care position 4b if scSelect >= '1' and scSelect <= '5'; ParmDS.KeyPosition(aa) = %uns(scSelect); 4x else; ParmDS.KeyPosition(aa) = 0; 4e endif; clear scSelect; update SBFDTA1; 3e endif; SflRcdNbr = rrn; readc SBFDTA1; 2e enddo; ‚ // call data base relations display program 2b if IsKeysLoaded; callp p_JCRFDR( '*FIRST ': p_FileQual: '*FILE ': 'JCRLKEY ': '*DBR': ParmDS); 3b if not ParmDS.IsFoundKey; aFooterMsg = White; FooterMsg = 'No Logicals found with selected key'; 3x else; FooterMsg = SaveMessage; aFooterMsg = Blue; 3e endif; 2e endif; 1e enddo; ‚ //--------------------------------------------------------- dealloc Fild0100ptr; f_SndCompMsg('JCRLKEY for ' + %trimr(f_GetQual(p_FileQual)) + ' - completed'); *inlr = *on; return; ‚ //--------------------------------------------------------- begsr srGetDataBaseRelations; FldsArry(*) = *blanks; KeysArry(*) = *blanks; aa = 0; bb = 0; rrn = 0; SflRcdNbr = 1; Ind.sfldspctl = *off; write SBFCTL1; ‚ // call API to retrieve data base relation names. callp QDBLDBR( UserSpaceName: 'DBRL0100': p_FileQual: '*ALL ': '*ALL ': ApiErrDS); ‚ // Process list entries in user space. QdbldbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 0 to GenericHeader.ListEntryCount; ‚ // put PF first in output. 2b if ForCount > 0; WorkFileQual = QdbldbrDS.DependentFile; 2x else; WorkFileQual = p_FileQual; 2e endif; 2b if WorkFileQual > *blanks and WorkFileQual <> '*NONE '; AllocateSize = f_GetAllocSize01(WorkFileQual: '*FIRST '); 3b if ApiErrDS.BytesReturned = 0; Fild0100ptr = %realloc(Fild0100ptr: AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual: 'FILD0100' : WorkFileQual: '*ALL ': '0' : '*LCL ': '*EXT ': ApiErrDS); ‚ // get offset to Keys fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; ‚ // include select/omits or only files with no select/omits 4b if ParmDS.SelectOmit or (not ParmDS.SelectOmit and FileScopeArry.NumSelectOmit = 0); ‚ // Load array of field names and ‚ // numeric position of field in the ‚ // key, I only care about 5 levels down list. 5b if tstbts(Fild0100ds.TypeBits: 6) = 1; // keyed access path KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 6b for ForCount2 = 1 to FileScopeArry.NumOfKeys; KeyField = KeySpecsDS.KeyFieldName; 7b if aa > 0; bb = %lookup(KeyField: FldsArry: 1: aa); 7e endif; 7b if bb = 0; aa += 1; bb = aa; FldsArry(aa) = KeyField; 7e endif; 7b if ForCount2 = 1; Pos1Arry(bb) = '1'; 7x elseif ForCount2 = 2; Pos2Arry(bb) = '2'; 7x elseif ForCount2 = 3; Pos3Arry(bb) = '3'; 7x elseif ForCount2 = 4; Pos4Arry(bb) = '4'; 7x elseif ForCount2 = 5; Pos5Arry(bb) = '5'; 7e endif; KeySpecsPtr += 32; 6e endfor; 5e endif; 4e endif; 3e endif; 2e endif; 2b if ForCount > 0; QdbldbrPtr += GenericHeader.ListEntrySize; 2e endif; 1e endfor; 1b if aa > 1; sorta %subarr(KeysArry:1:aa); 1e endif; endsr; ‚ //--------------------------------------------------------- ‚ // Now load text and attributes of file fields. ‚ // call API to load field descriptions to user space. begsr srKeyFieldAttributes; callp QUSLFLD( UserSpaceName: 'FLDL0100': p_FileQual: '*FIRST ': '0': ApiErrDS); ‚ //--------------------------------------------------------- ‚ // Process from array so subfile will be sorted. ‚ // Spin through user space comparing field names, ‚ // when one is found, write subfile record. 1b for ForCount3 = 1 to aa; QuslfldPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 2b for ForCount = 1 to GenericHeader.ListEntryCount; KeyField = QuslfldDS.FieldName; 3b if KeyField = FldsArry(ForCount3); scSelect = *blanks; scKeyNam = KeyField; scKeyTyp = QuslfldDS.FieldType; scKeyTxt = QuslfldDS.FieldText; scPos1 = Pos1Arry(ForCount3); scPos2 = Pos2Arry(ForCount3); scPos3 = Pos3Arry(ForCount3); scPos4 = Pos4Arry(ForCount3); scPos5 = Pos5Arry(ForCount3); 4b for cc = 1 to 5; 5b if scPosArry(cc) = ' '; scPosArryA(cc) = Blue; scPosArry(cc) = '.'; 5x else; scPosArryA(cc) = Green; 5e endif; 4e endfor; ‚ //--------------------------------------------------------- ‚ // Calculate ending position of each field. ‚ // If field is alpha, field length is loaded from ‚ // QuslfldDS.FieldLengthA field. if field is numeric, number of ‚ // digits and number of decimals are loaded. if data type ‚ // is packed, the type field is blanked for printing. 4b if scKeyTyp = 'A' or scKeyTyp = 'Z' or scKeyTyp = 'T' or scKeyTyp = 'L'; scKeyLen = QuslfldDS.FieldLengthA; scKeyDec = *blanks; 4x else; scKeyLen = QuslfldDS.FieldLengthN; scKeyDec = %triml(%editc(QuslfldDS.DecimalPos:'3')); 5b if scKeyTyp = 'P'; scKeyTyp = *blanks; 5e endif; 4e endif; rrn += 1; write SBFDTA1; 2v leave; 3e endif; QuslfldPtr += GenericHeader.ListEntrySize; 2e endfor; 1e endfor; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRLOG - List previously executed commands - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Previously Executed Commands') ]]> v5r4 *---------------------------------------------------------------- * JCRLOGD - List previously executed commands - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA12 CA21 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A ACMDMSG 1A P A FULLCMD 500A H A SBFOPTION 1A B 4 2 A CMDMSG73 73A O 4 4DSPATR(&ACMDMSG) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(18) SFLSIZ(72) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A S1RECNUM 4S 0H SFLRCDNBR(CURSOR) A 1 3'JCRLOG' COLOR(BLU) A 1 23'Previously Executed Commands' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Type options, press Enter.' A COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 4'1=Run' COLOR(BLU) A 3 14'2=Prompt' COLOR(BLU) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 20'F5=Refresh' COLOR(BLU) A 23 46'F21=Command Line' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRLOG'.Previously Executed Commands (JCRLOG) - Help .*-------------------------------------------------------------------- :P.This JCR command executes API to retrieve all commands executed from command line. (Never press F9 Again!). A distinct subfile list is presented to execute or prompt each command. :EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRLOGR - List previously executed commands // loop through Qmhrtvrq API call to get all previous executed commands // load and display subfile of distinct commands. // allow selection and execution of commands //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRLOGD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D CmdList s 500a dim(500) D CmdCounter s 5u 0 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define Dspatr /Define FunctionKeys /Define Ind /Define Qcmdchk /Define Quscmdln /Define Sds /Define f_RtvMsgApi /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndSflMsg /Define f_System /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D Qmhrtvrq PR extpgm('QMHRTVRQ') retrieve request msg Db like(rtvq0100DS) message information D 10i 0 const message length D 8a const format name Db 10a const message type D 4a message key Db like(ApiErrDS) D rtvq0100DS ds qualified D BytesReturned 10i 0 overlay(rtvq0100DS:1) D BytesAvail 10i 0 overlay(rtvq0100DS:5) D MsgKey 4a overlay(rtvq0100DS:9) D Reserved 20a overlay(rtvq0100DS:13) D MsgLenReturn 10i 0 overlay(rtvq0100DS:33) D MsgLenAvail 10i 0 overlay(rtvq0100DS:37) D MsgText 500a overlay(rtvq0100DS:41) D MsgText2 2a overlay(MsgText:1) D MsgText6 6a overlay(Msgtext:1) D MsgKey s 4a D MsgType s 10a //--*ENTRY PARMS *NONE* ----------------------------------- /free evalr scDow = %trimr(f_GetDayName()); // Set looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; f_SndCompMsg('JCRLOG - completed'); *inlr = *on; return; //--------------------------------------------------------- begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; aCmdMsg = Green; rrn = 0; write SBFCTL1; CmdCounter = 0; IsExitPgm = *off; MsgKey = *blanks; MsgType = '*LAST'; 1b dou rtvq0100DS.BytesAvail = 0; callp Qmhrtvrq( rtvq0100DS: %len(rtvq0100DS): 'RTVQ0100': MsgType: MsgKey: ApiErrDS); 2b if rtvq0100DS.BytesAvail > 0; MsgType = '*PRV '; MsgKey = rtvq0100DS.MsgKey; 3b if rtvq0100DS.MsgText2 <> '/*' and rtvq0100DS.MsgText6 <> 'jcrlog' and rtvq0100DS.MsgText6 <> 'JCRLOG' and rtvq0100DS.MsgText6 <> 'ENDRQS'; FullCmd = %subst(rtvq0100DS.MsgText: 1: rtvq0100DS.MsgLenReturn); 4b If %subst(FullCmd:1:1) = '?'; FullCmd = %subst(FullCmd:3); 4e endif; //--------------------- //--------------------- 4b if %subst(FullCmd:1:1) = '?'; FullCmd = %subst(FullCmd:3:%len(FullCmd)-2); 4e endif; //--------------------- //--------------------- // show distinct commands 4b if CmdCounter = 0 or %lookup(FullCmd: CmdList: 1: CmdCounter) = 0; CmdCounter += 1; CmdList(CmdCounter) = FullCmd; callp(e) QCMDCHK(FullCmd: %len(%trimr(FullCmd))); 5b if not %error; cmdmsg73 = FullCmd; rrn += 1; write SBFDTA1; 5e endif; 4e endif; 3e endif; 2e endif; 1e enddo; // allow user to make selection from subfile. f_RmvSflMsg(ProgId); s1recnum = 1; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b dow not (InfdsFkey = f03); write MSGCTL; write SBFCTL1; exfmt SFOOTER1; 2b if InfdsFkey = f05; //refresh LV leavesr; 2x elseif InfdsFkey = f21; //command line callp(e) QUSCMDLN(); 2x elseif (not Ind.sfldsp) or InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2x else; // Find record in subfile user has selected. f_RmvSflMsg(ProgId); readc SBFDTA1; 3b dow not %eof; aCmdMsg = Green; 4b if sbfOption = '1'; f_System(%trimr(FullCMD)); 4x elseif sbfOption = '2'; f_System('?' + fullCMD); 4e endif; 4b if ApiErrDS.BytesReturned > 0; //error occurred aCmdMsg = %bitor(White: RI); f_SndSflMsg(ProgId: ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); 4x else; f_SndSflMsg(ProgId: %trimr( %subst( fullcmd: 1: 60)) + ' - Completed.'); 4e endif; // Update subfile to reflect selected change. clear sbfOption; s1recnum = rrn; update SBFDTA1; readc SBFDTA1; 3e enddo; 2e endif; 1e enddo; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRLSRC - List program source/module information - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Program Source/Modules') PARM KWD(PGM) TYPE(PGM) MIN(1) PROMPT('Programs:') PGM: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) MIN(1) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *OUTFILE *) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) NBRTRUE(*EQ 1) PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) PROMPT('Output member options:') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or add records') ]]> v5r4 *---------------------------------------------------------------- * JCRLSRCF- List program source/module information - PF *---------------------------------------------------------------- A R JCRLSRCFR TEXT('List program source info') A OBJNAM 10A COLHDG('Pgm Object') A ATTRIBUTE 10A COLHDG('Attribute') A SRCLIB 10A COLHDG('Source Lib') A SRCFIL 10A COLHDG('Source File') A SRCMBR 10A COLHDG('Source Mbr') A CREATEDATE 10A COLHDG('Create Date') A LASTUSED 10A COLHDG('Last Used') A DAYSUSED 4 0 COLHDG('Days Used') A OBJTEXT 41A COLHDG('Text') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRLSRC'.List Program Source/Modules (JCRLSRC) .*-------------------------------------------------------------------- :P.This JCR command prints listing or optionally generates outfile of source lib, file, and source mbr for each selected program types in selected program object library. If program consists of modules, all modules associated with program are printed.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRLSRC/PGM'.Programs - Help :XH3.Programs (PGM) :P.Name/*All/Generic* and library of programs to be evaluated.:EHELP. :HELP name='JCRLSRC/PGMTYPE'.Program Type - Help :XH3.Program Type (PGMTYPE) :P.Type of program objects to be evaulated.:EHELP. :HELP name='JCRLSRC/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print results or load into outfile or * display the spooled file.:EHELP. :HELP name='JCRLSRC/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.Name and library of file where source information is to be written:EHELP. :HELP name='JCRLSRC/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.Database file member that receives output of command. :P.The possible name values are: :P.:PARML.:PT.:PK def.*FIRST:EPK.:PD.The first member in file receives output. If it does not exist, the system creates member with name of file specified in :HP2.File to receive output:EHP2. prompt (OUTFILE parameter). :PT.member-name :PD.Specify name of file member that receives output. If it does not exist, the system creates it.:EPARML. :P.The possible values for how information is stored are: :P.:PARML.:PT.:PK def.*REPLACE:EPK. :PD.The system clears existing member and adds new records. :PT.*ADD :PD.The system adds new records to end of existing records.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRLSRCP - List program source/module information - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A INDARA A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRLSRC' A 20'List Program Source/Module Informa- A tion' A SCDOW 9A O 90 A 100DATE EDTWRD(' / / ') A 110TIME EDTWRD(' : : ') A 120'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'Library:' A HEADLIB 10A 11 A 24'Program Select:' A HEADPGM 10A 41 A 56'Attribute:' A P_PGMTYPE 10A 67SPACEA(1) *--- A 64'Object' A 86'Days' SPACEA(1) *--- A 2'Pgm Object' A 14'Attribute' A 26'SourceLib' A 38'SourceFile' A 50'Mbr/Module' A 64'Created' A 75'LastUsed' A 86'Used' A 92'Text' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A OBJNAM 10A 2 A ATTRIBUTE 10A 14 A SRCLIB 10A 26 A SRCFIL 10A 38 A SRCMBR 10A 50 A CREATEDATE 10A 62 A 30 LASTUSED 10A 74 A DAYSUSED 4 0 86EDTCDE(4) A OBJTEXT 41A 92 *---------------------------------------------------------------- A R PRTMESSAGE SPACEB(2) A VMESSAGE 100A 3 ]]> v5r4 //--------------------------------------------------------- // JCRLSRCR - List program source/module information // call Quslobj API to load object names to user space. // use pointers to get offset information. // call Qclrpgmi API to extract program type. // call Qbnlpgmi API to retrieve program source. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRLSRCP o e printer oflind(IsOverFlow) indds(Ind) F usropn FJCRLSRCF o e disk extfile(extOfile) extmbr(ExtOmbr) F usropn //--*STAND ALONE------------------------------------------- D extOmbr s 10a D IsFound s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define FunctionKeys /Define Qbnlpgmi /Define Qbnrmodi /Define Qclrpgmi /Define Quslobj /Define f_Qusrobjd /Define UserSpaceHeaderDS /Define UserSpaceHeaderDS2 /Define f_GetDayName /Define f_BuildString /Define f_GetQual /Define f_Quscrtus /Define f_RtvMsgAPI /Define f_SndCompMsg /Define f_SndStatMsg /Define f_GetApiISO /Define f_OvrPrtf /Define f_Dltovr /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D rcv528 ds 528 D SrcFil overlay(rcv528:62) D SrcLib overlay(rcv528:72) D SrcMbr overlay(rcv528:82) D rcv200 ds 200 D SrcFilSrv 10a overlay(rcv200:52) D SrcLibSrv 10a overlay(rcv200:62) D SrcMbrSrv 10a overlay(rcv200:72) D ListEntry2 ds based(ListEntryPtr2) D SrcFil2 10a overlay(ListEntry2:41) D SrcLib2 10a overlay(ListEntry2:51) D SrcMbr2 10a overlay(ListEntry2:61) D ind ds qualified D IsLastUsed n overlay(ind:30) //--*ENTRY PARMS------------------------------------------- D p_JCRLSRCR PR extpgm('JCRLSRCR') D 20a D 8a D 20a D 22a D p_JCRLSRCR PI D p_PgmQual 20a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free headLib = %subst(p_PgmQual: 11: 10); headpgm = %subst(p_PgmQual: 1: 10); f_SndStatMsg(f_BuildString('List source for & - in progress': f_GetQual(headpgm + headLib))); evalr scDow = %trimr(f_GetDayName()); //--------------------------------------------------------- // depending on output selection 1b if p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRLSRCF; 1x else; f_OvrPrtf('JCRLSRCP ': *OMIT: HeadPgm); open JCRLSRCP; write PrtHead; 1e endif; // Load program object names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0100': p_PgmQual: '*ALL ': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; // load print file field, print error message vMessage = ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi( ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); 2b if p_Output = '*OUTFILE'; close JCRLSRCF; f_SndCompMsg(vMessage); *inlr = *on; return; 2x else; exsr srWriteAsterick; write PrtMessage; exsr srSendCompletMsg; 2e endif; 1e endif; // if no matching objects found, print error message. 1b if GenericHeader.ListEntryCount = 0; vmessage = 'No matching program objects found.'; 2b if p_Output = '*OUTFILE'; f_SndCompMsg(vMessage); *inlr = *on; return; 2x else; exsr srWriteAsterick; write PrtMessage; exsr srSendCompletMsg; 2e endif; 1e endif; // if no error, create / get pointer ILE user space GenericHeaderPtr2 = f_Quscrtus(UserSpaceName2); // Process entries in user space by moving pointer. QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if QuslobjDS.ObjTyp = '*PGM ' or QuslobjDS.ObjTyp = '*MODULE '; IsFound = *on; QusrObjDS = f_QUSROBJD( QuslobjDS.ObjNam + QuslobjDS.ObjLib: QuslobjDS.ObjTyp: 'OBJD0400'); CreateDate = f_GetApiISO(QusrobjDS.CreateDateTime ); 3b if QusrobjDS.NumDaysUsed > 9999; DaysUsed = 9999; 3x else; DaysUsed = QusrobjDS.NumDaysUsed; 3e endif; 3b if QusrobjDS.NumDaysUsed > 0; LastUsed = f_GetApiISO(QusrobjDS.LastUsedDate + ' '); Ind.IsLastUsed = *on; 3x else; Ind.IsLastUsed = *off; 3e endif; 3b if QuslobjDS.ObjTyp = '*PGM '; // if ILE, call API to get Source 4b if QusrObjDS.ExtendedAttr = 'RPGLE ' or QusrObjDS.ExtendedAttr = 'SQLRPGLE ' or QusrObjDS.ExtendedAttr = 'CLLE '; callp QBNLPGMI( UserSpaceName2: 'PGML0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); 5b if ApiErrDS.BytesReturned > 0; //Source not available SrcFil = '**********'; SrcLib = '**********'; SrcMbr = '**********'; exsr srPrintLine; 5x else; ListEntryPtr2 = GenericHeaderPtr2 + GenericHeader2.OffSetToList; 6b for ForCount2 = 1 to GenericHeader2.ListEntryCount; SrcFil = SrcFil2; SrcLib = SrcLib2; SrcMbr = SrcMbr2; exsr srPrintLine; ListEntryPtr2 += GenericHeader2.ListEntrySize; 6e endfor; 5e endif; 4x else; // if not ILE, call API to get Source callp QCLRPGMI( rcv528: 528: 'PGMI0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); 5b if ApiErrDS.BytesReturned > 0; //Source not available SrcFil = '**********'; SrcLib = '**********'; SrcMbr = '**********'; 5e endif; exsr srPrintLine; 4e endif; 3x else; //service program callp QBNRMODI( rcv200: 200: 'MODI0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); SrcFil = SrcFilSrv; SrcLib = SrcLibSrv; SrcMbr = SrcMbrSrv; exsr srPrintLine; 3e endif; 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; // if no matching objects found, print message and exit. 1b if p_Output = '*PRINT ' or p_Output = '* '; 2b if not IsFound; exsr srWriteAsterick; vmessage = 'No matching program objects found.'; write PrtMessage; 2x else; // end of report vmessage = ' ** End Of Report'; write PrtMessage; 2e endif; 1e endif; exsr srSendCompletMsg; //--------------------------------------------------------- begsr srPrintLine; ObjNam = QuslobjDS.ObjNam; Attribute = QusrObjDS.ExtendedAttr; ObjText = QusrObjDS.Text; 1b if p_Output = '*OUTFILE'; 2b if not Ind.IsLastUsed; LastUsed = *blanks; DaysUsed = 0; 2e endif; write JCRLSRCFR; 1x else; write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srWriteAsterick; QuslobjPtr = GenericHeaderPtr; ObjNam = *all'*'; Attribute = *all'*'; SrcLib = *all'*'; SrcFil = *all'*'; SrcMbr = *all'*'; CreateDate = *blanks; DaysUsed = 0; Ind.IsLastUsed = *on; LastUsed = *blanks; ObjText = *all'*'; write PrtDetail; endsr; //--------------------------------------------------------- begsr srSendCompletMsg; 1b if p_Output = '*OUTFILE'; close JCRLSRCF; f_SndCompMsg('File ' + %trimr(extOfile) + ' member ' + %trimr(ExtOmbr) + ' generated by JCRLSRC'); 1x else; close JCRLSRCP; f_Dltovr('JCRLSRCP '); f_DspLastSplf('JCRLSRCR ': p_Output); 1e endif; *inlr = *on; return; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRLSRCRV - Validity checking program for library name //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /Define f_OutFileCrtDupObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRLSRCRV PR extpgm('JCRLSRCRV') D 20a D 8a D 20a D 22a D p_JCRLSRCRV PI D p_ObjQual 20a D p_Output 8a D p_OutFileQual 20a D p_MbrOpt 22a //--------------------------------------------------------- /free 1b if %subst(p_ObjQual: 11: 10) <> '*LIBL '; f_CheckObj(%subst(p_ObjQual: 11: 10) + 'QSYS ': '*LIB '); 1e endif; 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_MbrOpt: 'JCRLSRCF '); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRLSTCNN - List all network connections // call QtocLstNetCnn API to load network connection names to user space //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FQSYSPRT o f 132 printer oflind(IsOverFlow) usropn D scDow s 9a //--*DATA STRUCTURES--------------------------------------- D uListEntry ds Based(uListPtr ) D RemoteAddress 15a overlay(uListEntry:1) D LocalAddress 15a overlay(uListEntry:21) D RemotePort 10i 0 overlay(uListEntry:41) D LocalPort 10i 0 overlay(uListEntry:45) D NetConectType 10a overlay(uListEntry:77) // Connection List Qualifier D ListQualifier ds D NetConnectTyp 10a overlay(ListQualifier:1) inz('*TCP') D ListRequesTyp 10a overlay(ListQualifier:11) inz('*ALL') D Reserved 12a overlay(ListQualifier:21) inz(' ') D LocInternetLO 10i 0 overlay(ListQualifier:33) inz(0) D LocInternetUP 10i 0 overlay(ListQualifier:37) inz(65535) D LocalPortLO 10i 0 overlay(ListQualifier:41) inz(0) D LocalPortUP 10i 0 overlay(ListQualifier:45) inz(65535) D RmtInternetLO 10i 0 overlay(ListQualifier:49) inz(0) D RmtInternetUP 10i 0 overlay(ListQualifier:53) inz(65535) D RemotePortLO 10i 0 overlay(ListQualifier:57) inz(0) D RemotePortUP 10i 0 overlay(ListQualifier:61) inz(65535) //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetDayName /Define f_DspLastSplf /Define Qusdltus /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D QtocLstNetCnn PR extproc('QtocLstNetCnn') list network connect D 20a Space Name D 8a const Format name Db like(ListQualifier) D 10i 0 const size of list Qual D 8a const list Qual format Db like(ApiErrDS) error parm //--------------------------------------------------------- /free open qsysprt; evalr scDow = %trimr(f_GetDayName()); except PrtHeader; GenericHeaderPtr = f_Quscrtus(UserSpaceName); // call API to load network connections into user space. callp QtocLstNetCnn( UserSpaceName: 'NCNN0100': ListQualifier: %size(ListQualifier): 'NCLQ0100': ApiErrDS); // Process elements in user space by moving pointer. uListPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; except PrtDetail; uListPtr += GenericHeader.ListEntrySize; 1e endfor; close qsysprt; callp QUSDLTUS(UserSpaceName: ApiErrDS); f_DspLastSplf('JCRLSTCNN ': '* '); *inlr = *on; /end-free Oqsysprt e PrtHeader 1 1 O 10 'JCRLSTCNN' O 42 'List Network Connections' O scDow 85 O udate y 95 O 111 'Page' O PAGE1 117 O e PrtHeader 1 O 1 '.' O e PrtHeader 1 O 14 'RemoteAddress' O 30 'LocalAddress' O 45 'RemotePort' O 56 'LocalPort' O 72 'NetConectType' O e PrtDetail 1 O RemoteAddress 16 O LocalAddress +2 O RemotePort +2 O LocalPort +2 O NetConectType +2 ]]> v5r4 //--------------------------------------------------------- // JCRLSTIFC - List all logical TCP/IP interfaces //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FQSYSPRT o f 132 printer oflind(IsOverFlow) usropn D scDow s 9a //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetDayName /Define f_DspLastSplf /Define Qusdltus /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D uListEntry ds Based(uListPtr ) D InternetAddr 15a overlay(uListEntry:1) D NetworkAddr 15a overlay(uListEntry:21) D NetworkName 10a overlay(uListEntry:41) D LineDescript 10a overlay(uListEntry:51) //--*CALL PROTOTYPES--------------------------------------- D QtocLstNetIfc PR extproc('QtocLstNetIfc') list tcp/ip D 20a Space Name D 8a const format name Db like(ApiErrDS) error parm //--------------------------------------------------------- /free open qsysprt; evalr scDow = %trimr(f_GetDayName()); except PrtHeader; GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QtocLstNetIfc(UserSpaceName: 'NIFC0100': ApiErrDs); // Process elements in user space by moving pointer. uListPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; except PrtDetail; uListPtr += GenericHeader.ListEntrySize; 1e endfor; close qsysprt; callp QUSDLTUS(UserSpaceName: ApiErrDS); f_DspLastSplf('JCRLSTIFC ': '* '); *inlr = *on; return; /end-free Oqsysprt e PrtHeader 1 1 O 10 'JCRLSTIFC' O 42 'List Tcp/Ip Connections' O scDow 85 O udate y 95 O 111 'Page' O PAGE1 117 O e PrtHeader 1 O 1 '.' O e PrtHeader 1 O 14 'InternetAddrs' O 29 'NetworkAddr' O 46 'NetworkName' O 61 'LineDescript' O e PrtDetail 1 O InternetAddr 16 O NetworkAddr +2 O NetworkName +2 O LineDescript +4 ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRMRBIG - Print big 12 line tall characters - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print 12 line tall characters') PARM KWD(CHARACTERS) TYPE(*CHAR) LEN(10) MIN(1) + ALWUNPRT(*NO) PGM(*NO) PROMPT('String of Characters:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRMRBIG'.Print 12 line tall characters (JCRMRBIG) - Help .*-------------------------------------------------------------------- :P.This JCR command generates twelve lines high by thirteen spaces wide print characters from your selected input.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRMRBIG/CHARACTERS'.String of Characters - Help :XH3.String of Characters (CHARACTERS) :P.Character string to be printed. :PARML.:PT.characters :PD.Any keyboard character.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRMRBIGR - Print big 12 lines tall character // It will make it easier to first load 2d array with // column.row for each letter, then generate print. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FQSYSPRT o f 132 printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D xx s 3u 0 D PrintRow s 3u 0 D Char1to10 s 3u 0 D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') D lo c const('abcdefghijklmnopqrstuvwxyz') //--*DATA STRUCTURES--------------------------------------- D PrintLine ds D PrintLineArray 13a dim(10) D BigChar ds dim(10) qualified D Row 13a dim(12) //--*FUNCTION PROTOTYTPES---------------------------------- D f_GetChar PR 156a D 1a const D System PR 10i 0 extproc('system') cl command processor D * value options(*string) //--*ENTRY------------------------------------------------- D p_JCRMRBIGR PR Extpgm('JCRMRBIGR ') D 10a D p_JCRMRBIGR PI D p_InString 10a //--------------------------------------------------------- /free open qsysprt; p_InString = %xlate(lo:up:p_InString); // Load 2d array with characters 1b for xx = 1 to 10; BigChar(xx) = f_GetChar(%subst(p_InString: xx: 1)); 1e endfor; //--------------------------------------------------------- // Each PrintRow is 'slice' of large characters for printing // at 1 only top row of all 10 big characters will print. // at 2 second row of all 10 big characters will print // until all lines are printed //--------------------------------------------------------- 1b for PrintRow = 1 to 12; 2b for Char1to10 = 1 to 10; PrintLineArray(Char1to10) = BigChar(Char1to10).Row(PrintRow); 2e endfor; except PrtDetail; 1e endfor; close qsysprt; xx = System('DSPSPLF FILE(QSYSPRT) SPLNBR(*LAST)'); *inlr = *on; return; /end-free Oqsysprt e PrtDetail 1 O PrintLine 131 //--------------------------------------------------------- // Load string with lines composing character. P f_GetChar b D f_GetChar PI 156a D p_BaseChar 1a const D SingleQuote c const('''') single Quote D DoubleQuote c const('"') double Quote D BigDS ds D Big 13a dim(12) /free Big(*) = *blanks; 1b if p_BaseChar = ' '; 1x elseif p_BaseChar = 'A'; Big(*) = 'AA AA'; Big(1) = ' AAAAAAAAAA '; Big(2) = 'AAAAAAAAAAAA'; Big(6) = 'AAAAAAAAAAAA'; Big(7) = 'AAAAAAAAAAAA'; 1x elseif p_BaseChar = 'B'; Big(1) = 'BBBBBBBBBB '; Big(2) = 'BBBBBBBBBBB '; Big(3) = 'BB BB'; Big(4) = 'BB BB'; Big(5) = 'BB BB '; Big(6) = 'BBBBBBBBBB '; Big(7) = 'BBBBBBBBBB '; Big(8) = 'BB BB '; Big(9) = 'BB BB'; Big(10)= 'BB BB'; Big(11)= 'BBBBBBBBBBB '; Big(12)= 'BBBBBBBBBB '; 1x elseif p_BaseChar = 'C'; Big(*) = 'CC '; Big(1) = ' CCCCCCCCCC '; Big(2) = 'CCCCCCCCCCCC'; Big(3) = 'CC CC'; Big(10)= 'CC CC'; Big(11)= 'CCCCCCCCCCCC'; Big(12)= ' CCCCCCCCCC '; 1x elseif p_BaseChar = 'D'; Big(*) = 'DD DD'; Big(1) = 'DDDDDDDDD '; Big(2) = 'DDDDDDDDDD '; Big(3) = 'DD DD '; Big(10)= 'DD DD '; Big(11)= 'DDDDDDDDDD '; Big(12)= 'DDDDDDDDD '; 1x elseif p_BaseChar = 'E'; Big(*) = 'EE '; Big(1) = ' EEEEEEEEEEE'; Big(2) = 'EEEEEEEEEEEE'; Big(6) = 'EEEEEEEE '; Big(7) = 'EEEEEEEE '; Big(11)= 'EEEEEEEEEEEE'; Big(12)= ' EEEEEEEEEEE'; 1x elseif p_BaseChar = 'F'; Big(*) = 'FF '; Big(1) = ' FFFFFFFFFFF'; Big(2) = 'FFFFFFFFFFFF'; Big(6) = 'FFFFFFFF '; Big(7) = 'FFFFFFFF '; 1x elseif p_BaseChar = 'G'; Big(1) = ' GGGGGGGGGG '; Big(2) = 'GGGGGGGGGGGG'; Big(3) = 'GG GG'; Big(4) = 'GG '; Big(5) = 'GG '; Big(6) = 'GG '; Big(7) = 'GG GGGGGG'; Big(8) = 'GG GGGGGG'; Big(9) = 'GG GG'; Big(10)= 'GG GG'; Big(11)= 'GGGGGGGGGGGG'; Big(12)= ' GGGGGGGGGG '; 1x elseif p_BaseChar = 'H'; Big(*) = 'HH HH'; Big(6) = 'HHHHHHHHHHHH'; Big(7) = 'HHHHHHHHHHHH'; 1x elseif p_BaseChar = 'I'; Big(*) = ' II '; Big(1) = 'IIIIIIIIIIII'; Big(2) = 'IIIIIIIIIIII'; Big(11)= 'IIIIIIIIIIII'; Big(12)= 'IIIIIIIIIIII'; 1x elseif p_BaseChar = 'J'; Big(*) = ' JJ '; Big(1) = ' JJJJJJJJJJ'; Big(2) = ' JJJJJJJJJJ'; Big(9) = 'JJ JJ '; Big(10)= 'JJ JJ '; Big(11)= 'JJJJJJJJ '; Big(12)= ' JJJJJJ '; 1x elseif p_BaseChar = 'K'; Big(1) = 'KK KK'; Big(2) = 'KK KK '; Big(3) = 'KK KK '; Big(4) = 'KK KK '; Big(5) = 'KK KK '; Big(6) = 'KKKKKKK '; Big(7) = 'KKKKKKK '; Big(8) = 'KK KK '; Big(9) = 'KK KK '; Big(10)= 'KK KK '; Big(11)= 'KK KK '; Big(12)= 'KK KK'; 1x elseif p_BaseChar = 'L'; Big(*) = 'LL '; Big(11)= 'LLLLLLLLLLLL'; Big(12)= 'LLLLLLLLLLLL'; 1x elseif p_BaseChar = 'M'; Big(*) = 'MM MM'; Big(2) = 'MMM MMM'; Big(3) = 'MMMM MMMM'; Big(4) = 'MM MM MM MM'; Big(5) = 'MM MMMM MM'; Big(6) = 'MM MM MM'; 1x elseif p_BaseChar = 'N'; Big(1) = 'NN NN'; Big(2) = 'NNN NN'; Big(3) = 'NNNN NN'; Big(4) = 'NN NN NN'; Big(5) = 'NN NN NN'; Big(6) = 'NN NN NN'; Big(7) = 'NN NN NN'; Big(8) = 'NN NN NN'; Big(9) = 'NN NNNN'; Big(10)= 'NN NNN'; Big(11)= 'NN NN'; Big(12)= 'NN NN'; 1x elseif p_BaseChar = 'O'; Big(*) = 'OO OO'; Big(1) = ' OOOOOOOOOO '; Big(2) = 'OOOOOOOOOOOO'; Big(11)= 'OOOOOOOOOOOO'; Big(12)= ' OOOOOOOOOO '; 1x elseif p_BaseChar = 'P'; Big(1) = 'PPPPPPPPPPP '; Big(2) = 'PPPPPPPPPPPP'; Big(3) = 'PP PP'; Big(4) = 'PP PP'; Big(5) = 'PP PP'; Big(6) = 'PPPPPPPPPPPP'; Big(7) = 'PPPPPPPPPPP '; Big(8) = 'PP '; Big(9) = 'PP '; Big(10)= 'PP '; Big(11)= 'PP '; Big(12)= 'PP '; 1x elseif p_BaseChar = 'Q'; Big(*) = 'QQ QQ'; Big(1) = ' QQQQQQQQQQ '; Big(2) = 'QQQQQQQQQQQQ'; Big(9) = 'QQ QQ QQ'; Big(10)= 'QQ QQ QQ'; Big(11)= 'QQ QQQQ'; Big(12)= ' QQQQQQQQ QQ'; 1x elseif p_BaseChar = 'R'; Big(1) = 'RRRRRRRRRRR '; Big(2) = 'RRRRRRRRRRRR'; Big(3) = 'RR RR'; Big(4) = 'RR RR'; Big(5) = 'RR RR'; Big(6) = 'RRRRRRRRRRRR'; Big(7) = 'RRRRRRRRRRR '; Big(8) = 'RR RR '; Big(9) = 'RR RR '; Big(10)= 'RR RR '; Big(11)= 'RR RR '; Big(12)= 'RR RR'; 1x elseif p_BaseChar = 'S'; Big(1) = ' SSSSSSSSSS '; Big(2) = 'SSSSSSSSSSSS'; Big(3) = 'SS SS'; Big(4) = 'SS '; Big(5) = 'SSS '; Big(6) = ' SSSSSSSSS '; Big(7) = ' SSSSSSSSS '; Big(8) = ' SSS'; Big(9) = ' SS'; Big(10)= 'SS SS'; Big(11)= 'SSSSSSSSSSSS'; Big(12)= ' SSSSSSSSSS '; 1x elseif p_BaseChar = 'T'; Big(*) = ' TT '; Big(1) = 'TTTTTTTTTTTT'; Big(2) = 'TTTTTTTTTTTT'; 1x elseif p_BaseChar = 'U'; Big(*) = 'UU UU'; Big(11)= 'UUUUUUUUUUUU'; Big(12)= ' UUUUUUUUUU '; 1x elseif p_BaseChar = 'V'; Big(*) = 'VV VV'; Big(8) = ' VV VV '; Big(9) = ' VV VV '; Big(10)= ' VV VV '; Big(11)= ' VVVV '; Big(12)= ' VV '; 1x elseif p_BaseChar = 'W'; Big(*) = 'WW WW'; Big(7) = 'WW WW WW'; Big(8) = 'WW WWWW WW'; Big(9) = 'WW WW WW WW'; Big(10)= 'WWWW WWWW'; Big(11)= 'WWW WWW'; Big(12)= 'WW WW'; 1x elseif p_BaseChar = 'X'; Big(1) = 'XX XX'; Big(2) = 'XX XX'; Big(3) = ' XX XX '; Big(4) = ' XX XX '; Big(5) = ' XX XX '; Big(6) = ' XXXX '; Big(7) = ' XXXX '; Big(8) = ' XX XX '; Big(9) = ' XX XX '; Big(10)= ' XX XX '; Big(11)= 'XX XX'; Big(12)= 'XX XX'; 1x elseif p_BaseChar = 'Y'; Big(*) = ' YY '; Big(1) = 'YY YY'; Big(2) = 'YY YY'; Big(3) = ' YY YY '; Big(4) = ' YY YY '; Big(5) = ' YY YY '; Big(6) = ' YYYY '; 1x elseif p_BaseChar = 'Z'; Big(1) = 'ZZZZZZZZZZZZ'; Big(2) = 'ZZZZZZZZZZZZ'; Big(3) = ' ZZ '; Big(4) = ' ZZ '; Big(5) = ' ZZ '; Big(6) = ' ZZZZZZZ '; Big(7) = ' ZZZZZZZ '; Big(8) = ' ZZ '; Big(9) = ' ZZ '; Big(10)= ' ZZ '; Big(11)= 'ZZZZZZZZZZZZ'; Big(12)= 'ZZZZZZZZZZZZ'; 1x elseif p_BaseChar = '0'; Big(1) = ' 0000000000 '; Big(2) = ' 0000000000 '; Big(3) = '00 0000'; Big(4) = '00 00 00'; Big(5) = '00 00 00'; Big(6) = '00 00 00'; Big(7) = '00 00 00'; Big(8) = '00 00 00'; Big(9) = '0000 00'; Big(10)= '000 00'; Big(11)= ' 0000000000 '; Big(12)= ' 00000000 '; 1x elseif p_BaseChar = '1'; Big(*) = ' 11 '; Big(2) = ' 111 '; Big(3) = ' 1111 '; Big(11)= '111111111111'; Big(12)= '111111111111'; 1x elseif p_BaseChar = '2'; Big(1) = ' 22222222 '; Big(2) = '22222222222 '; Big(3) = '22 22'; Big(4) = ' 22'; Big(5) = ' 22'; Big(6) = ' 22 '; Big(7) = ' 22 '; Big(8) = ' 22 '; Big(9) = ' 22 '; Big(10)= ' 22 '; Big(11)= '222222222222'; Big(12)= '222222222222'; 1x elseif p_BaseChar = '3'; Big(1) = ' 3333333333 '; Big(2) = '333333333333'; Big(3) = '33 33'; Big(4) = ' 33'; Big(5) = ' 33'; Big(6) = ' 3333 '; Big(7) = ' 3333 '; Big(8) = ' 33'; Big(9) = ' 33'; Big(10)= '33 33'; Big(11)= '333333333333'; Big(12)= ' 3333333333 '; 1x elseif p_BaseChar = '4'; Big(*) = ' 44 '; Big(1) = ' 444 '; Big(2) = ' 4444 '; Big(3) = ' 44 44 '; Big(4) = ' 44 44 '; Big(5) = ' 44 44 '; Big(6) = ' 44444444444'; Big(7) = '444444444444'; 1x elseif p_BaseChar = '5'; Big(1) = '555555555555'; Big(2) = '555555555555'; Big(3) = '55 '; Big(4) = '55 '; Big(5) = '55 '; Big(6) = '555555555 '; Big(7) = '5555555555 '; Big(8) = ' 55 '; Big(9) = ' 55'; Big(10)= ' 55'; Big(11)= '555555555555'; Big(12)= '55555555555 '; 1x elseif p_BaseChar = '6'; Big(1) = ' 6666666666 '; Big(2) = '666666666666'; Big(3) = '66 66'; Big(4) = '66 '; Big(5) = '66 '; Big(6) = '66666666666 '; Big(7) = '666666666666'; Big(8) = '66 66'; Big(9) = '66 66'; Big(10)= '66 66'; Big(11)= '666666666666'; Big(12)= ' 6666666666 '; 1x elseif p_BaseChar = '7'; Big(*) = ' 77 '; Big(1) = '777777777777'; Big(2) = '777777777777'; Big(3) = '77 77 '; Big(4) = ' 77 '; Big(5) = ' 77 '; 1x elseif p_BaseChar = '8'; Big(1) = ' 8888888888 '; Big(2) = '888888888888'; Big(3) = '88 88'; Big(4) = '88 88'; Big(5) = ' 88 88 '; Big(6) = ' 88888888 '; Big(7) = ' 88888888 '; Big(8) = ' 88 88 '; Big(9) = '88 88'; Big(10)= '88 88'; Big(11)= '888888888888'; Big(12)= ' 8888888888 '; 1x elseif p_BaseChar = '9'; Big(1) = ' 9999999999 '; Big(2) = '999999999999'; Big(3) = '99 99'; Big(4) = '99 99'; Big(5) = '99 99'; Big(6) = '999999999999'; Big(7) = '999999999999'; Big(8) = ' 99'; Big(9) = ' 99'; Big(10)= '99 99'; Big(11)= '999999999999'; Big(12)= ' 9999999999 '; 1x elseif p_BaseChar = '@'; Big(1) = ' @@@@@@@@@@ '; Big(2) = '@@@@@@@@@@@@'; Big(3) = '@@ @@@@ @@'; Big(4) = '@@ @@ @@'; Big(5) = '@@ @@ @@'; Big(6) = '@@ @@@@@@@ '; Big(7) = '@@ '; Big(8) = '@@ '; Big(9) = '@@ '; Big(10)= '@@ '; Big(11)= ' @@@@@@@@@@@'; Big(12)= ' @@@@@@@@@@'; 1x elseif p_BaseChar = '#'; Big(*) = ' ## ## '; Big(4) = ' ###########'; Big(5) = ' ###########'; Big(8) = ' ###########'; Big(9) = ' ###########'; 1x elseif p_BaseChar = '$'; Big(1) = ' $$ '; Big(2) = ' $$$$$$$$$$ '; Big(3) = '$$$$$$$$$$$$'; Big(4) = '$$ $$ '; Big(5) = '$$ $$ '; Big(6) = ' $$$$$$$$$$ '; Big(7) = '$$$$$$$$$$$$'; Big(8) = ' $$ $$'; Big(9) = ' $$ $$'; Big(10)= '$$$$$$$$$$$$'; Big(11)= ' $$$$$$$$$$ '; Big(12)= ' $$ '; 1x elseif p_BaseChar = '*'; Big(1) = '** ** **'; Big(2) = '** ** **'; Big(3) = ' ** ** ** '; Big(4) = ' ** ** ** '; Big(5) = ' ****** '; Big(6) = '************'; Big(7) = '************'; Big(8) = ' ****** '; Big(9) = ' ** ** ** '; Big(10)= ' ** ** ** '; Big(11)= '** ** **'; Big(12)= '** ** **'; 1x elseif p_BaseChar = '!'; Big(1) = ' !! '; Big(2) = ' !!!! '; Big(3) = ' !!!!!! '; Big(4) = ' !!!!!! '; Big(5) = ' !!!!!! '; Big(6) = ' !!!! '; Big(7) = ' !!!! '; Big(8) = ' !!!! '; Big(9) = ' !! '; Big(10)= ' '; Big(11)= ' !! '; Big(12)= ' !! '; 1x elseif p_BaseChar = SingleQuote; %subst(Big(1): 5: 3) = *all''''; %subst(Big(2): 5: 4) = *all''''; %subst(Big(3): 5: 3) = *all''''; %subst(Big(4): 5: 2) = *all''''; 1x elseif p_BaseChar = DoubleQuote; %subst(Big(1): 2: 3) = *all'"'; %subst(Big(2): 2: 4) = *all'"'; %subst(Big(3): 2: 3) = *all'"'; %subst(Big(4): 2: 2) = *all'"'; %subst(Big(1): 9: 3) = *all'"'; %subst(Big(2): 9: 4) = *all'"'; %subst(Big(3): 9: 3) = *all'"'; %subst(Big(4): 9: 2) = *all'"'; 1x elseif p_BaseChar = ')'; Big(*) = ' )) '; Big(1) = ' )))) '; Big(2) = ' ))) '; Big(11)= ' ))) '; Big(12)= ' )))) '; 1x elseif p_BaseChar = '('; Big(*) = ' (( '; Big(1) = ' (((( '; Big(2) = ' ((( '; Big(11)= ' ((( '; Big(12)= ' (((( '; 1x elseif p_BaseChar = '%'; Big(1) = ' %%%% //'; Big(2) = ' % % // '; Big(3) = ' %%%% // '; Big(4) = ' // '; Big(5) = ' // '; Big(6) = ' // '; Big(7) = ' // %%%% '; Big(8) = ' // % % '; Big(9) = ' // %%%% '; 1x elseif p_BaseChar = '&'; Big(1) = ' &&& '; Big(2) = ' && && '; Big(3) = ' && && '; Big(4) = ' && && '; Big(5) = ' &&&&&& '; Big(6) = ' &&&& '; Big(7) = ' && && '; Big(8) = '&& && '; Big(9) = '&& && &'; Big(10)= '&& && &&'; Big(11)= ' && &&&& '; Big(12)= ' &&&&&&&& '; 1x elseif p_BaseChar = '_'; Big(11)= *all'_'; Big(12)= Big(11); 1x elseif p_BaseChar = '-'; Big(6)= *all'-'; Big(7)= Big(6); 1x elseif p_BaseChar = '+'; Big(4) = ' +++ '; Big(5) = ' +++ '; Big(6) = ' ++ +++ +++ '; Big(7) = ' ++ +++ +++ '; Big(8) = ' +++ '; Big(9) = ' +++ '; 1x elseif p_BaseChar = '='; Big(6) = ' ======== '; Big(7) = ' ======== '; 1x elseif p_BaseChar = '^'; Big(1) = ' ^^ '; Big(2) = ' ^^ ^^ '; Big(3) = ' ^^ ^^ '; 1x elseif p_BaseChar = '/'; Big(2) = ' //'; Big(3) = ' // '; Big(4) = ' // '; Big(5) = ' // '; Big(6) = ' // '; Big(7) = ' // '; Big(8) = ' // '; Big(9) = ' // '; Big(10)= ' // '; Big(11)= ' // '; Big(12)= '// '; 1x elseif p_BaseChar = '\'; Big(2) = '\\ '; Big(3) = ' \\ '; Big(4) = ' \\ '; Big(5) = ' \\ '; Big(6) = ' \\ '; Big(7) = ' \\ '; Big(8) = ' \\ '; Big(9) = ' \\ '; Big(10)= ' \\ '; Big(11)= ' \\ '; Big(12)= ' \\'; 1x elseif p_BaseChar = '.'; Big(11) = ' .... '; Big(12) = ' .... '; 1x elseif p_BaseChar = ','; Big(10) = ' ,,,, '; Big(11) = ' ,,,, '; Big(12) = ' ,, '; 1x elseif p_BaseChar = '>'; Big(3) = ' >> '; Big(4) = ' >> '; Big(5) = ' >> '; Big(6) = ' >> '; Big(7) = ' >> '; Big(8) = ' >> '; Big(9) = ' >> '; Big(10)= ' >> '; Big(11)= ' >> '; 1x elseif p_BaseChar = '<'; Big(3) = ' << '; Big(4) = ' << '; Big(5) = ' << '; Big(6) = ' << '; Big(7) = ' << '; Big(8) = ' << '; Big(9) = ' << '; Big(10)= ' << '; Big(11)= ' << '; 1x elseif p_BaseChar = '?'; Big(1) = ' ???????? '; Big(2) = ' ?????????? '; Big(3) = '?? ??'; Big(4) = ' ??'; Big(5) = ' ??? '; Big(6) = ' ?? '; Big(7) = ' ?? '; Big(8) = ' ?? '; Big(9) = ' ?? '; Big(10)= ' '; Big(11)= ' ?? '; Big(12)= ' ?? '; 1e endif; return BigDS; /end-free P f_GetChar e ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNETFF - Send multiple network files to multiple users - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Send Multiple Network Files') PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(FILES) TYPE(*CHAR) LEN(10) + SPCVAL((' ')) MIN(1) MAX(10) + CHOICE('NAME,GENERIC*') PROMPT('File names:') PARM KWD(TOUSRID) TYPE(USRLIST) MAX(5) PROMPT('User ID') USRLIST: ELEM TYPE(*CHAR) LEN(8) MIN(1) PROMPT('User ID') ELEM TYPE(*CHAR) LEN(8) PROMPT('Address') ]]> v5r4 * .*-------------------------------------------------------------------- .* JCRNETFFH - Send multiple network files to multiple users * .*-------------------------------------------------------------------- :PNLGRP.:IMPORT PNLGRP='QHNFCMD' NAME='SNDNETF/TOUSRID'. :HELP NAME='JCRNETFF'.Send Multiple Network Files (JCRNETFF) - Help :P.This JCR command sends up to ten save files or physical database files to other users on either the local system or on remote system through SNADS network. :P.This command, while being functionally identical to SNDNETF, allows you to send more than one file at a time.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRNETFF/FILES'.File names - Help :XH3.File names (FILES) :P.Files to be sent. Files sent can be physical file or save file; logical and device files are not allowed. Overrides to specified file are ignored. :IMHELP name='plus_sign'.:EHELP. :HELP name='JCRNETFF/LIBRARY'.Library - Help :XH3.Library (LIBRARY) :P.Library containing files to be sent.:EHELP. :HELP NAME='JCRNETFF/TOUSRID'.User id - Help :IMHELP name='SNDNETF/TOUSRID'.:EHELP. :HELP name='plus_sign'. :P.You can enter multiple values for this parameter. If you are on entry display and you need additional entry fields to enter these multiple values, type plus sign (+) in entry field beside phrase :HP2."+ for more":EHP2., and press Enter key.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRNETFFR - Send multiple network files to multiple users // Spin through number of files to send and number user/systems. // build/execute command string to send files. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_Quscrtus /Define Quslobj /Define UserSpaceHeaderDS /Define f_GetQual /Define f_ParmListCount /Define f_System /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D BldSpace s 1a D BldToUsr s 100a varying D Displacement s 5i 0 based(DisplacePtr) D NumOfSndTo s 5i 0 based(p_UsrListPtr) D NumOfFiles s 3u 0 D xx s 3u 0 D sc s 3u 0 //--*DATA STRUCTURES--------------------------------------- // Get number of user/system IDs and build DS to move though command list D InnerList ds based(InnerListPtr) qualified D ToUser 8a overlay(InnerList:3) D ToSys 8a overlay(InnerList:11) //--*ENTRY PARMS------------------------------------------- D p_JCRNETFFR PR extpgm('JCRNETFFR') D 10a D 102a D 120a D p_JCRNETFFR PI D p_Lib 10a D p_FileList 102a D p_UsrList 120a //--------------------------------------------------------- /free //* overlay entry parms with DS definitions p_UsrListPtr = %addr(p_UsrList); // Load all selected users into single string (touser tosys) (touser tosys) DisplacePtr = p_UsrListPtr; 1b for ForCount = 1 to NumOfSndTo; DisplacePtr += 2; InnerListPtr = p_UsrListPtr + Displacement; BldToUsr = BldToUsr + BldSpace + '(' + %trimr(InnerList.ToUser) + ' ' + %trimr(InnerList.ToSys) + ')'; BldSpace = ' '; 1e endfor; // get number of files in list NumOfFiles = f_ParmListCount(p_FileList); sc = 3; 1b for xx = 1 to NumOfFiles; 2b if %scan('*':%subst(p_FileList:sc:10)) > 0; // Create user space/retrieve pointer to user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0200': %subst(p_FileList:sc:10) + p_Lib: '*FILE ': ApiErrDS); QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 3b for ForCount = 1 to GenericHeader.ListEntryCount; 4b if QuslobjDS.ExtendedAttr = 'PF '; f_System('SNDNETF FILE(' + %trimr(f_GetQual(QuslobjDS.ObjNam + QuslobjDS.ObjLib)) + ') TOUSRID(' + BldToUsr + ')'); 4e endif; QuslobjPtr += GenericHeader.ListEntrySize; 3e endfor; 2x else; f_System('SNDNETF FILE(' + %trimr(f_GetQual(%subst(p_FileList:sc:10) + p_Lib)) + ') TOUSRID(' + BldToUsr + ')'); 2e endif; sc += 10; 1e endfor; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRNETFFRV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_ParmListCount /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D ForCount s 3u 0 D xx s 3u 0 //--*ENTRY PARMS------------------------------------------- D p_JCRNETFFRV PR extpgm('JCRNETFFRV') D 10a D 102a D 120a D p_JCRNETFFRV PI D p_Lib 10a D p_FileList 102a D p_UsrList 120a //--------------------------------------------------------- /free // make sure file was entered 1b if f_ParmListCount(p_FileList) = 0; f_SndEscapeMsg('Must select at least one FILE NAME.'); 1e endif; // make sure user was entered 1b if f_ParmListCount(p_UsrList) = 0; f_SndEscapeMsg('Must select at least one TOUSRID.'); 1e endif; // if not *LIBL, make sure exists 1b if p_Lib <> '*LIBL '; f_CheckObj(p_Lib + '*LIBL ': '*LIB '); 1e endif; xx = 3; 1b for ForCount = 1 to f_ParmListCount(p_FileList); 2b if %scan('*':%subst(p_FileList:xx:10)) = 0; // skip generics f_CheckMbr(%subst(p_FileList:xx:10) + p_Lib : '*FIRST'); 2e endif; xx += 10; 1e endfor; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNETFM - Send network file multiple members - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Send Network File Members') PARM KWD(FILE) TYPE(FILE) PROMPT('File') FILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(TOUSRID) TYPE(TOUSRID) MAX(5) PROMPT('To User ID(s)') TOUSRID: ELEM TYPE(*CHAR) LEN(8) MIN(1) PROMPT('User ID') ELEM TYPE(*CHAR) LEN(8) PROMPT('Address') PARM KWD(MBRS) TYPE(MBRS) MIN(1) MAX(10) PROMPT('Member(s)') MBRS: ELEM TYPE(*CHAR) LEN(10) SPCVAL((*FIRST)) + CHOICE('*First,*All,Generic*,Name') PROMPT(' Member Name:') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL,RPGLE,RPG,CLP,DSPF,etc.') PROMPT(' Member Type:') ]]> v5r4 * .*-------------------------------------------------------------------- .* JCRNETFMH - Send network file multiple members * .*-------------------------------------------------------------------- :PNLGRP.:IMPORT PNLGRP='QHNFCMD' NAME='SNDNETF/TOUSRID'. :HELP NAME='JCRNETFM'.Send Network File Members (JCRNETFM) - Help :P.This JCR command allows you to select either *First, *All, Generic* or up to 10 named members of a selected file. You may also filter member selections by member type. You can select up to 5 send-to users. :P.This command, while being functionally identical to SNDNETF, is much more powerful and versatile.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRNETFM/FILE'.File name (FILE) - Help :XH3.File name (FILE) :P.File whose members to be sent. File can be a physical file or save file; logical and device files are not allowed. Overrides to specified file are ignored. :XH3.Library (LIBRARY) :P.Library containing file to be sent.:EHELP. :HELP NAME='JCRNETFM/TOUSRID'.User id - Help :IMHELP name='SNDNETF/TOUSRID'.:EHELP. :HELP NAME='JCRNETFM/MBRS'.Member names - Help :XH3.Member names (MBRS) :P.Members to be sent. You may also select *FIRST, *ALL, or any generic* name. You may also filter by specific member types.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRNETFMR - send multiple network file members - command processing program // Spin through number of files to send and number user/systems. // build/execute command string to send file members(s). //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define Quslmbr /Define UserSpaceHeaderDS /Define f_BuildString /Define f_GetQual /Define f_Quscrtus /Define f_System /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D BldToUsr s 100a varying D Displacement s 5i 0 based(DisplacePtr) D Displacement2 s 5i 0 based(DisplacePtr2) D ForCount2 s like(NumOfMbrs) D NumofMbrs s 5i 0 based(p_MbrListPtr) D NumOfSndTo s 5i 0 based(p_UsrListPtr) D SendCount s 10u 0 //--*DATA STRUCTURES--------------------------------------- // Get number of user/system IDs and build DS to move though command list D InnerList ds based(InnerListPtr) qualified D ToUser 8a overlay(InnerList:3) D ToSys 8a overlay(InnerList:11) // Get number of members selected and DS to move through command list D InnerList2 ds based(InnerListPtr2) qualified D MbrName 10a overlay(InnerList2:3) D MbrType 10a overlay(InnerList2:13) //--*ENTRY PARMS------------------------------------------- D p_JCRNETFMR PR extpgm('JCRNETFMR') D 20a From Lib D 120a To user Ids D 242a From files D p_JCRNETFMR PI D p_FileQual 20a D p_UsrList 120a D p_MbrList 242a //--------------------------------------------------------- /free // overlay entry parms with DS definitions p_UsrListPtr = %addr(p_UsrList); p_MbrListPtr = %addr(p_MbrList); // Load all selected users into single string // (touser tosys) (touser tosys) DisplacePtr = p_UsrListPtr + 2; 1b for ForCount2 = 1 to NumOfSndTo; InnerListPtr = p_UsrListPtr + Displacement; BldToUsr += %trimr(f_BuildString(' (& &)': InnerList.ToUser: InnerList.ToSys)); DisplacePtr += 2; 1e endfor; // Spin though all members selected, if any are generic* // create user space and retrieve pointer to user space. DisplacePtr2 = p_MbrListPtr + 2; 1b for ForCount2 = 1 to NumofMbrs; InnerListPtr2 = p_MbrListPtr + Displacement2; 2b if %scan('*': InnerList2.MbrName) > 0 and InnerList2.MbrName <> '*FIRST '; GenericHeaderPtr = f_Quscrtus(UserSpaceName); 1v leave; 2e endif; DisplacePtr2 += 2; 1e endfor; //--------------------------------------------------------- // If single member or *first DisplacePtr2 = p_MbrListPtr + 2; 1b for ForCount2 = 1 to NumofMbrs; InnerListPtr2 = p_MbrListPtr + Displacement2; 2b if %scan('*': InnerList2.MbrName) = 0 or InnerList2.MbrName = '*FIRST '; SendCount += 1; f_System(f_BuildString('SNDNETF FILE(&) TOUSRID(&) MBR(&)': f_GetQual(p_FileQual): BldToUsr: InnerList2.MbrName)); //--------------------------------------------------------- // If generic, retrieve list of members from API list. 2x else; callp QUSLMBR( UserSpaceName: 'MBRL0200': p_FileQual: InnerList2.MbrName: '0': ApiErrDS); QuslmbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 3b for ForCount = 1 to GenericHeader.ListEntryCount; // member type filter 4b if InnerList2.MbrType = '*ALL ' or InnerList2.MbrType = QuslmbrDS.MbrType; SendCount += 1; f_System( f_BuildString('SNDNETF FILE(&) TOUSRID(&) MBR(&)': f_GetQual(p_FileQual): BldToUsr: QuslmbrDS.MbrName)); 4e endif; QuslmbrPtr += GenericHeader.ListEntrySize; 3e endfor; 2e endif; DisplacePtr2 += 2; 1e endfor; f_SndCompMsg('JCRNETFMR sent ' + %char(SendCount) + ' members.'); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRNETFMRV - Validity checking program for objects //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_Qusrobjd /Define f_RtvMsgAPI /Define f_CheckMbr /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D NumofMbrs s 5i 0 based(p_MbrListPtr) D NumOfUsrs s 5i 0 based(p_UsrListPtr) //--*ENTRY PARMS------------------------------------------- D p_JCRNETFMRV PR extpgm('JCRNETFMRV') D 20a D 120a D 242a D p_JCRNETFMRV PI D p_FileQual 20a D p_UsrList 120a D p_MbrList 242a //--------------------------------------------------------- /free // overlay entry parms with other definitions p_UsrListPtr = %addr(p_UsrList); p_MbrListPtr = %addr(p_MbrList); // Make sure selected file exists. QusrObjDS = f_QUSROBJD(p_FileQual: '*FILE'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; // Make sure PF or SAVF object type. 1b if not (%subst(QusrObjDS.ExtendedAttr: 1: 2) = 'PF' or %subst(QusrObjDS.ExtendedAttr: 1: 4) = 'SAVF'); ApiErrDS.ErrMsgId = 'CPF8057'; ApiErrDS.MsgReplaceVal = p_FileQual; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; // make sure user was entered 1b if NumOfUsrs = 0; f_SndEscapeMsg('Must select at least one TOUSRID.'); 1e endif; // make sure file was entered 1b if NumofMbrs = 0; f_SndEscapeMsg('Must select at least one MBR NAME.'); 1e endif; // make sure at least one member exists f_CheckMbr(p_FileQual: '*FIRST'); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNETQ - Send network file entire outq - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Send Network Outq') PARM KWD(OUTQ) TYPE(OUTQ) MIN(1) PROMPT('Outq:') OUTQ: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) CONSTANT('*OUTQ ') PARM KWD(TOUSRID) TYPE(*CHAR) LEN(8) MIN(1) PROMPT('User ID') PARM KWD(SYSTEM) TYPE(*CHAR) LEN(8) MIN(0) PROMPT('Address:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRNETQ'.Send Network Outq (JCRNETQ) - Help .*-------------------------------------------------------------------- :P.This JCR sends network file all spooled files in selected outq to selected userid.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRNETQ/OUTQ'.Outq - Help :XH3.Outq (OUTQ) :P.Specify name of outq where spooled files are located.:EHELP. :HELP name='JCRNETQ/TOUSRID'.To User Id - Help :XH3.User id (TOUSRID) :P.User name to receive spooled files.:EHELP. :HELP name='JCRNETQ/SYSTEM'.Address - Help :XH3.Address (SYSTEMD) :P.Remote system name.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRNETQR - Send network file entire outq // call API to load selected spooled files to user space. //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define Quslspl /Define UserSpaceHeaderDS /Define f_BuildString /Define f_GetQual /Define f_Quscrtus /Define f_SndCompMsg /Define f_SndStatMsg /Define f_System /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D AlphaSplno s 6a //--*ENTRY PARMS------------------------------------------- D p_JCRNETQR PR extpgm('JCRNETQR') D 20a D 10a D 8a D 8a D p_JCRNETQR PI D p_OutqQual 20a D p_ObjType 10a D p_ToUserid 8a D p_ToAddress 8a //--------------------------------------------------------- /free f_SndStatMsg(f_BuildString('Sending from outq & to & - in progress': f_GetQual(p_OutqQual): p_ToAddress)); // call api to load user space with spooled file info GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLSPL( UserSpaceName: 'SPLF0300': '*ALL ': p_OutqQual: '*ALL ': '*ALL ': ApiErrDS); // Process list entries in user space. splf0300Ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; evalr AlphaSplno = '000000' + %char(splf0300DS.SplfNum); f_System(f_BuildString('SNDNETSPLF FILE(&) TOUSRID((& &)) + JOB(&/&/&) SPLNBR(&)': splf0300DS.SplfName: p_ToUserid: p_ToAddress: splf0300DS.JobNo: splf0300DS.UserID: splf0300DS.JobName: AlphaSplno)); splf0300Ptr += GenericHeader.ListEntrySize; 1e endfor; f_SndCompMsg(f_BuildString('& files were sent from & to &.': %char(GenericHeader.ListEntryCount): f_GetQual(p_OutqQual): p_ToAddress)); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNOTPOP - List Fields not populated in data file - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Fields Not Populated') PARM KWD(MBR) TYPE(*CHAR) CONSTANT('*FIRST ') PARM KWD(FILE) TYPE(FILE) MIN(1) PROMPT('File:') FILE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNOTPOPC- List Fields not populated in data file */ /* REQUIRED TO BREAK IMPLICIT BINDINGS ON CALL */ /* When one RPG program calls another, the system generates a */ /* dynamic binding to that object. That feature works against me in */ /* this application as I am generating a new RPG program obj for each */ /* file selected. This is only an issue if user scans 2 or more */ /* files in the same interactive session. If there is a CL program */ /* between the two rpg programs, no binding will take place. */ /*--------------------------------------------------------------------------*/ PGM CALL PGM(QTEMP/JCRNOTR) ENDPGM ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRNOTPOP'.List Fields Not Populated (JCRNOTPOP) - Help .*-------------------------------------------------------------------- :P.This JCR command prints list of field names from selected data file that have no data in that field in any record. :P.A program is generated (that can be found after interactive execution in source QTEMP/FLDSRC member JCRNOTR). This generated program reads data file and prints report. :P.For data files with large number of records, it is recommended that you submit this job.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRNOTPOP/FILE'.File - Help :XH3.File (FILE) :P.Name and library of file to be selected.:EHELP. :HELP name='JCRNOTPOP/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRNOTPOPP - List Fields not populated in data file - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRNOTPOP' A 20'Fields Not Populated' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) *--- A 3'File . :' A FILEACTUAL 10A O 14 A FILETEXT 42A O 26SPACEA(1) *--- A 3'Library:' A LIBACTUAL 10A O 14SPACEA(2) *--- A 3'Text' A 55'Field Name' A 67'Type' A 73'Length' A 82'Dec' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A FILETEXT 42A O 3 A FLDNAME 10A O 55 A FLDTYPE 1A O 69 A LENGTH 5S 0O 73EDTCDE(4) A DECIMALPOS 1A O 83 ]]> v5r4 //--------------------------------------------------------- // JCRNOTPOPR- List Fields not populated in data file // call Quslfld API to retrieve file field descriptions. // use entries to generate RPG code to read PF and print report. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC o f 112 disk extfile('QTEMP/FLDSRC') generated rpg F extmbr('JCRNOTR') usropn //--*STAND ALONE------------------------------------------- D Alpha14 s 14a D ConstSrc s 100a dim(31) ctdata perrcd(1) Rpg Source Code D DecimalPos s 1a D FldType s 1a D Mbrtxt s 42a D SrcCmt s 20a D SrcCod s 74a D SrcTyp s 1a D x13 s 13a inz(*all'x') rename fill D Length s 5s 0 D SeqNum s 6s 2 D IsGenRcdFmt s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Qdbrtvfd /Define Fild0100ds /Define Quslfld /Define UserSpaceHeaderDS /Define f_GetQual /Define f_Quscrtus /Define f_SndStatMsg /Define f_System /Define f_OvrPrtf /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D p_JCRNOTPOPC PR extpgm('JCRNOTPOPC') break implicit //--*ENTRY PARMS------------------------------------------- D p_JCRNOTPOPR PR extpgm('JCRNOTPOPR') D 10a D 20a D 8a D p_JCRNOTPOPR PI D p_Mbr 10a D p_FileQual 20a D p_Output 8a //--------------------------------------------------------- /free // create source file/member for generated SQL program f_System('DLTF FILE(QTEMP/FLDSRC)'); f_System('DLTPGM QTEMP/JCRNOTR'); f_System('CRTSRCPF FILE(QTEMP/FLDSRC) RCDLEN(112)'); f_System('ADDPFM FILE(QTEMP/FLDSRC) MBR(JCRNOTR) SRCTYPE(RPGLE)'); f_System('CLRPFM QTEMP/FLDSRC JCRNOTR'); open RPGSRC; // Write file specs. SrcTyp = 'F'; SrcCod = %subst(p_FileQual: 1: 10) + 'if e'; %subst(SrcCod: 30: 4) = 'disk'; SrcCmt = 'Input AS/400 data '; exsr srWriteCode; 1b for aa = 1 to 12; SeqNum += .01; except wrtcodArry; 1e endfor; // Load file information AllocateSize = f_GetAllocSize01(p_FileQual: '*FIRST '); Fild0100ptr = %alloc(AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize: ReturnFileQual : 'FILD0100' : p_FileQual: '*FIRST ': '0' : '*FILETYPE ': '*EXT ': ApiErrDS); // access to record format name fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; // top file read clear SrcTyp; clear SrcCmt; clear SrcCod; exsr srWriteCode; SrcCod = ' read ' + %subst(ReturnFileQual: 1: 10) + ';'; exsr srWriteCode; SrcCod = ' dow not %eof;'; exsr srWriteCode; clear SrcCod; exsr srWriteCode; // override print file for later. f_OvrPrtf('JCRNOTPOPP ': *OMIT: %subst(p_FileQual: 1: 10)); // call API to load field descriptions to user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLFLD( UserSpaceName: 'FLDL0100': p_FileQual: '*FIRST ': '0': ApiErrDS); //--------------------------------------------------------- // Some files have field names that are reserved words in RPG. // This would cause generated code to blow on compile. // Note: if your file has NOT as a fieldname, that file cannot // be processed ever by RPG program. // spin through and generate renames for reserved words. QuslfldPTR = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if QuslfldDS.FieldName = 'UDATE ' or QuslfldDS.FieldName = 'UDAY ' or QuslfldDS.FieldName = 'UMONTH ' or QuslfldDS.FieldName = 'UYEAR ' or QuslfldDS.FieldName = 'PAGE ' or QuslfldDS.FieldName = 'PAGE1 ' or QuslfldDS.FieldName = 'PAGE2 ' or QuslfldDS.FieldName = 'PAGE3 ' or QuslfldDS.FieldName = 'PAGE4 ' or QuslfldDS.FieldName = 'PAGE5 ' or QuslfldDS.FieldName = 'PAGE6 ' or QuslfldDS.FieldName = 'PAGE7 '; // 1st time generate rec fmt I spec 3b if not IsGenRcdFmt; SrcTyp = 'I'; SrcCod = FileScopeArry.RcdFmt; SrcCmt = 'Record Format'; exsr srWriteCode; IsGenRcdFmt = *on; 3e endif; // generate rename specs // it is important to rename to something 14 long to avoid // potential conflicts with existing field names SrcTyp = 'I'; clear SrcCod; %subst(SrcCod: 15: 10) = QuslfldDS.FieldName; %subst(SrcCod: 43: 14) = %trimr(QuslfldDS.FieldName) + x13; SrcCmt = 'Rename ' + QuslfldDS.FieldName; exsr srWriteCode; 2e endif; QuslfldPTR += GenericHeader.ListEntrySize; 1e endfor; //--------------------------------------------------------- // generate calc specs SrcTyp = ' '; SrcCmt = *blanks; QuslfldPTR = GenericHeaderPtr + GenericHeader.OffSetToList; bb = 0; 1b for ForCount = 1 to GenericHeader.ListEntryCount; FldType = QuslfldDS.FieldType; 2b if FldType = 'A' or FldType = 'S' or FldType = 'P' or FldType = 'U' or FldType = 'I' or FldType = 'B'; bb += 1; //--------------------------------------------------------- // I have to use renamed fields here also Alpha14 = QuslfldDS.FieldName; 3b if QuslfldDS.FieldName = 'UDATE ' or QuslfldDS.FieldName = 'UDAY ' or QuslfldDS.FieldName = 'UMONTH ' or QuslfldDS.FieldName = 'UYEAR ' or QuslfldDS.FieldName = 'PAGE ' or QuslfldDS.FieldName = 'PAGE1 ' or QuslfldDS.FieldName = 'PAGE2 ' or QuslfldDS.FieldName = 'PAGE3 ' or QuslfldDS.FieldName = 'PAGE4 ' or QuslfldDS.FieldName = 'PAGE5 ' or QuslfldDS.FieldName = 'PAGE6 ' or QuslfldDS.FieldName = 'PAGE7 '; Alpha14 = %trimr(QuslfldDS.FieldName) + x13; 3e endif; //--------------------------------------------------------- 3b if FldType = 'A'; SrcCod = ' if ' + %trimr(Alpha14) + '> *blanks;'; 3x else; SrcCod = ' if ' + %trimr(Alpha14) + ' > *zeros;'; 3e endif; exsr srWriteCode; //--------------------------------------------------------- SrcCod = ' jxxxxxxxxxflg(' + %char(bb) + ') = *on;'; exsr srWriteCode; SrcCod = ' endif;'; exsr srWriteCode; clear SrcCod; exsr srWriteCode; 2e endif; QuslfldPTR += GenericHeader.ListEntrySize; 1e endfor; // bottom file read SrcTyp = ' '; SrcCod = ' read ' + %subst(ReturnFileQual: 1: 10) + ';'; exsr srWriteCode; SrcCod = ' enddo;'; exsr srWriteCode; clear SrcCod; exsr srWriteCode; //--------------------------------------------------------- // Load heading fields and heading print line SrcTyp = ' '; SrcCod = ' // Print report ---------------------------------'; exsr srWriteCode; SrcCod = ' FileActual =' + qs + %subst(ReturnFileQual: 1: 10) + qs + ';'; exsr srWriteCode; SrcCod = ' LibActual =' + qs + %subst(ReturnFileQual: 11: 10) + qs + ';'; exsr srWriteCode; SrcCod = ' FileText ='; exsr srWriteCode; SrcCod = ' ' + qs + %subst(Fild0100ds.FileText: 1: 42) + qs + ';'; exsr srWriteCode; SrcCod = ' write PrtHead;'; exsr srWriteCode; clear SrcCod; exsr srWriteCode; SrcCod = ' for jxxxxxxxxxcnt = 1 to ' + %char(bb) + ';'; exsr srWriteCode; 1b for aa = 13 to 31; SeqNum += .01; except wrtcodArry; 1e endfor; //--------------------------------------------------------- bb = 0; QuslfldPTR = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; FldType = QuslfldDS.FieldType; 2b if FldType = 'A' or FldType = 'S' or FldType = 'P' or FldType = 'U' or FldType = 'I' or FldType = 'B'; bb += 1; SrcCod = ' jxxxxxxxxxtxt(' + %char(bb) + ') ='; exsr srWriteCode; // Remove Quotes before generation Mbrtxt = %xlate(qd+qs:' ': QuslfldDS.FieldText); SrcCod = ' ' + qs + Mbrtxt + qs + ';'; exsr srWriteCode; SrcCod = ' jxxxxxxxxxnam(' + %char(bb) + ')=' + qs + QuslfldDS.FieldName + qs + ';'; exsr srWriteCode; SrcCod = ' jxxxxxxxxxtyp(' + %char(bb) + ') =' + qs + FldType + qs + ';'; exsr srWriteCode; 3b if FldType = 'A' or FldType = 'Z' or FldType = 'T' or FldType = 'L'; Length = QuslfldDS.FieldLengthA; DecimalPos = *blanks; 3x else; Length = QuslfldDS.FieldLengthN; DecimalPos = %triml(%editc(QuslfldDS.DecimalPos:'3')); 3e endif; SrcCod = ' jxxxxxxxxxdec(' + %char(bb) + ') = ' + qs + DecimalPos + qs + ';'; exsr srWriteCode; SrcCod = ' jxxxxxxxxxlen(' + %char(bb) + ') = ' + %char(Length) + ';'; exsr srWriteCode; 2e endif; QuslfldPTR += GenericHeader.ListEntrySize; 1e endfor; SrcCod = ' endsr;'; exsr srWriteCode; dealloc Fild0100ptr; close RPGSRC; f_System('OVRDBF FILE(' + %trimr(%subst(ReturnFileQual: 1: 10)) + ') TOFILE(' + f_GetQual(ReturnFileQual) + ') OVRSCOPE(*JOB)'); f_System('CRTBNDRPG PGM(QTEMP/JCRNOTR) ' + 'SRCFILE(QTEMP/FLDSRC) SRCMBR(JCRNOTR) ' + 'DBGVIEW(*NONE) OUTPUT(*NONE) TGTRLS(*CURRENT)'); f_SndStatMsg('Reading data file ' + %trimr(f_GetQual(p_FileQual)) + ' - in progress'); callp p_JCRNOTPOPC(); f_System('DLTOVR FILE(JCRNOTPOPP) LVL(*JOB)'); f_System('DLTOVR FILE(' + %trimr(%subst(ReturnFileQual: 1: 10)) + ') LVL(*JOB)'); f_DspLastSplf('JCRNOTPOPR': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Write generated code to outfile. begsr srWriteCode; SeqNum += .01; except WriteCode; clear SrcCod; endsr; /end-free ORPGSRC e WriteCode O SeqNum 6 O SrcTyp 18 O SrcCod 92 O SrcCmt 112 // ORPGSRC e wrtcodArry O SeqNum 6 O ConstSrc(aa) 112 ** FJCRNOTPOPPo e printer oflind(*in99) D jxxxxxxxxxcnt s 5u 0 D jxxxxxxxxxflg s n dim(5000) D ds D jxxxxxxxxxary dim(5000) D jxxxxxxxxxtxt 42a overlay(jxxxxxxxxxary:1) D jxxxxxxxxxnam 10a overlay(jxxxxxxxxxary: 43) D jxxxxxxxxxtyp 1a overlay(jxxxxxxxxxary:53) D jxxxxxxxxxdec 1a overlay(jxxxxxxxxxary:54) D jxxxxxxxxxlen 5s 0 overlay(jxxxxxxxxxary:55) /free exsr srLoadFieldAttributes; 2b if jxxxxxxxxxflg(jxxxxxxxxxcnt) = *off; FileText=jxxxxxxxxxtxt(jxxxxxxxxxcnt); FldName=jxxxxxxxxxnam(jxxxxxxxxxcnt); FldType=jxxxxxxxxxtyp(jxxxxxxxxxcnt); DecimalPos=jxxxxxxxxxdec(jxxxxxxxxxcnt); Length=jxxxxxxxxxlen(jxxxxxxxxxcnt); write PrtDetail; 3b if *in99; write PrtHead; *in99 = *off; 3e endif; 2e endif; 1e endfor; *inlr = *on; return; // ----------------------------------------------------- begsr srLoadFieldAttributes; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRNUMB - Number logic structures in RPG source - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Number Source - Reformat /Free') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PROMPT('RPG program name:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(0) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(HIGH_LITE) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Highlight comment lines:') PARM KWD(MATCHEND) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Match ENDxx statements:') PARM KWD(INDENTFREE) TYPE(*CHAR) LEN(4) RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Reformat RPG/free indentation:') PARM KWD(INDENTAMT) TYPE(*DEC) LEN(1) DFT(3) PROMPT('Spaces for indent level:') PARM KWD(RMV_EJECTS) TYPE(*CHAR) LEN(4) + RSTD(*YES) DFT(*YES) VALUES(*YES *NO) + PROMPT('Blank /EJECT lines:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRNUMB'.Number Source - Reformat /Free (JCRNUMB) - Help .*-------------------------------------------------------------------- :P.This JCR command updates your RPG4 or /free source code with structured programming operation statements in left margin of your source. Options are provided to allow highlighting of comment lines and colorization of structure markers. :P.Also provides source reformatting for /free code based on logic structures in the code. :NT.If prepping code for inclusion in XML documents, set Comment Highlight=*NO and Color Markers=*NO. This will remove hexadecimal values that are not valid in XML.:ENT. :P.The command also removes source code type from all columnar comment lines. This makes it much easier to distinguish comment lines from executable lines. :P.After using this command, you can view the source code and easily identify structured operation groups.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRNUMB/PGM'.RPG Program Name - Help :XH3.RPG program name (PGM) :P.Source member to be updated.:EHELP. :HELP name='JCRNUMB/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP name='JCRNUMB/HIGH_LITE'.Highlight comment lines - Help :XH3.Highlight comment lines (HIGH_LITE) :P.Comments will have their screen attribute character set to highlight. :PARML.:PT.:PK def.*YES:EPK.:PD.Comment lines are to appear highlighted. :PT.*NO :PD.Comment lines are to appear as normal code. Use *NO if code will be loaded into XML document.:EPARML.:EHELP. :HELP name='JCRNUMB/MARKCOLOR'.Color Structure Markers - Help :XH3.Color Structure Markerss (MARKCOLOR) :P.Structure markers to be colored standard green or low-distraction blue. :PARML.:PT.:PK def.*YES:EPK. :PD.Markers are to colored blue. :PT.*NO :PD.Markers to be default green colored. Use *NO before loading code into XML document.:EPARML.:EHELP. :HELP name='JCRNUMB/MATCHEND'.Match ENDxx statements - Help :XH3.Match ENDxx statements (MATCHEND) :P.END statements to be updated to correspond with their beginning control block statement. :PARML.:PT.:PK def.*YES:EPK.:PD.END statements to be updated. :PT.*NO :PD.END opcodes to be left in their current sorry state.:EPARML.:EHELP. :HELP name='JCRNUMB/INDENTFREE'.Reformat RPG/Free Indentation- Help :XH3.Reformat RPG/Free Indentation (INDENTFREE) :P.Reformat your /free code based on logic structures. This value has no effect on columnar code. :PARML.:PT.:PK def.*YES:EPK.:PD.Reformat /free code based on logic structure. :PT.*NO :PD.Do not reformat.:EPARML.:EHELP. :HELP name='JCRNUMB/INDENTAMT'.Spaces for indent level- Help :XH3.Spaces for indent level (INDENTAMT) :P.Number of blank spaces used for indention of /free code. This parm has no effect on columnar code or if INDENTFREE parm is set to *NO. :PARML.:PT.:PK def.3:EPK.:PD.Indent 3 spaces for each logic structure.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRNUMBR - Number logic structures in RPG source - RPG4 // Updates your RPG4 or /free source code with structured programming operation // statements in left margin of your source. // generate end matching in same text case as end opcode. // /free source code reformat based on logic structures. // strip all colors out of comment lines. // skip continuation lines that begin with what would be an opcode. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC uf f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn //--*STAND ALONE------------------------------------------- D CheckContin s 94a varying D UpperSrc s like(Src94) D WrkA s like(OpcodeDS) D SrcArry s 1a dim(94) based(SrcPtr) D FirstDigitOpc s 1a D p_SrcFil s 10a D p_SrcLib s 10a D op s 3a dim(100) D SecondDigitOpc s 1a D StructNumb s 4a D TypeOutput s 13a inz('COMMENT-FIXED') D WBlanks s 94a varying D WrkB s 188a D WrkB2 s 188a D ado s 5i 0 dim(100) D dd s 5i 0 D ee s 5i 0 D EndOfCode s 3u 0 D pp s 3u 0 D q1 s 3u 0 D q2 s 3u 0 D StartOfComment s 3u 0 D ww s 3u 0 D zz s 3u 0 D SrcPtr s * inz(%addr(Src94)) D IsCalcSpec s n D IsCallp s n D IsCasxx s n D IsContinuation s n D IsCSR s n D IsEndCheat s n D IsFree s n D IsFunction s n D IsInsideCalcs s n D IsSqlExec s n D SelectDepth s n dim(100) D Hex21 c const(x'21') D Hex3F c const(x'3F') D WhiteHex c const(x'22') //--*COPY DEFINES------------------------------------------ /Define Constants /Define f_GetQual /Define f_IsValidMbrType /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D SrcUpdateDS ds 112 D OpcodeDS ds inz qualified D One 1a overlay(OpcodeDS:1) D Two 2a overlay(OpcodeDS:1) D Three 3a overlay(OpcodeDS:1) D Four 4a overlay(OpcodeDS:1) D Six 6a overlay(OpcodeDS:1) //--*ENTRY PARMS------------------------------------------- D p_JCRNUMBR PR extpgm('JCRNUMBR') D 10a const D 20a D 4a const D 4a const D 4a const D 1p 0 const D 4a const D p_JCRNUMBR PI D p_SrcMbr 10a const D p_SrcFilQual 20a D p_HighLight 4a const D p_EndLabel 4a const D p_Indentfree 4a const D p_Indentspace 1p 0 const D p_BlankEjects 4a const //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 4 SeqNo I a 13 15 CompileArray I a 18 18 SpecType I a 19 19 Asterisk I a 19 20 SlashComment I a 19 27 FreeForm I a 19 20 SubRoutine I a 38 47 OpcodeDS I a 1 18 Src18 I a 19 112 Src94 //--------------------------------------------------------- /free 1b if not f_IsValidMbrType( p_SrcFilQual: p_SrcMbr: 'RPGLE ': 'SQLRPGLE'); *inlr = *on; return; 1e endif; extIfile = f_GetQual(p_SrcFilQual); p_SrcFil = %subst(p_SrcFilQual: 1: 10); p_SrcLib = %subst(p_SrcFilQual: 11: 10); open RPGSRC; read RPGSRC; 1b dow not %eof; // do not process compile time arrays 2b if CompileArray = '** ' or CompileArray = '**C' or CompileArray = '**c'; 1v leave; 2e endif; exsr srStripColors; // spin through until I get into C specs proper. // if C or c or /free, we are in C specs. 2b if SpecType = 'C' or SpecType = 'c'; IsCalcSpec = *on; 2e endif; 2b if SpecType = 'O' or SpecType = 'o' or SpecType = 'D' or SpecType = 'd' or SpecType = 'F' or SpecType = 'f' or SpecType = 'P' or SpecType = 'p'; IsCalcSpec = *off; 2e endif; // see if inside /free section 2b if Asterisk = '/'; FreeForm = %xlate(lo: up: FreeForm); 3b if FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 3x elseif FreeForm = '/END-FREE'; IsFree = *off; 3e endif; 2e endif; // see if // free comment line IsComment = *off; 2b if IsFree; 3b if %len(%triml(Src94)) > 1 and %subst((%triml(Src94)): 1: 2) = '//'; IsComment = *on; exsr srIndentFree; TypeOutput = 'COMMENT-FREE '; exsr srFormatOutput; 3e endif; 2x else; 3b if SlashComment = '//'; IsComment = *on; TypeOutput = 'COMMENT-FREE '; exsr srFormatOutput; 3e endif; 3b if Asterisk = '*'; IsComment = *on; TypeOutput = 'COMMENT-FIXED'; exsr srFormatOutput; 3e endif; 2e endif; //--------------------------------------------------------- 2b if IsCalcSpec and (not IsComment); IsCSR = *off; //SR remove IsInsideCalcs = *on; //Inside calcs 3b if Asterisk = '/' //skip SQL stuff or Asterisk = '+'; TypeOutput = 'CLEAR '; exsr srFormatOutput; 3x else; //--------------------------------------------------------- // For /free code, do a little work to get opcode // into OpcodeDS field. // Look for first ' ' and first ';' , which ever not // zero and lowest value is end of opcode 4b if IsFree and Src94 > *blanks; WrkA = %triml(Src94); clear OpcodeDS; 5b if not IsContinuation; aa = %scan(' ': WrkA: 1); bb = %scan(';': WrkA: 1); 6b if aa > 0 and (aa < bb or bb = 0); OpcodeDS = %subst(WrkA: 1: aa - 1); 6x elseif bb > 0 and (bb < aa or aa = 0); OpcodeDS = %subst(WrkA: 1: bb - 1); 6e endif; 5e endif; //--------------------------------------------------------- // Note: I must be careful if previous line of // code ended in continuation character + or -. // if that is case, blank out opcode so // program is not fooled into thinking a constant // is a valid opcode. // example: if A = 'a + // if b'; // The second If is not really opcode! //--------------------------------------------------------- IsContinuation = *off; CheckContin = %trimr(Src94); aa = %len(CheckContin); 5b if %subst(CheckContin: aa: 1) = '+' or %subst(CheckContin: aa: 1) = '-'; IsContinuation = *on; 5e endif; 4e endif; //--------------------------------------------------------- // save case of opcode for matching ends FirstDigitOpc = %subst(OpcodeDS: 1: 1); SecondDigitOpc = %subst(OpcodeDS: 2: 1); OpcodeDS = %xlate(lo: up: OpcodeDS); // bad person had field named END in their free code // ENDblank is valid in fixed format, but not in free 4b if IsFree and OpCodeDS = 'END '; OpCodeDS = *blanks; 4e endif; //--------------------------------------------------------- // With v5r4 came free format SQL statement // Idea here is to ignore everything between // EXEC opcode and line terminating with semicolon 4b if OpcodeDS = 'EXEC '; IsSqlExec = *on; 4e endif; 4b if not IsFree; SubRoutine = %xlate(lo: up: SubRoutine); IsCSR = (SubRoutine = 'SR'); 4e endif; 4b if not IsSqlExec; TypeOutput = 'CALC LINE '; // Load xB for IF and SELECT opcodes. 5b if (OpcodeDS.Two = 'IF' and (not IsFree)) or (OpcodeDS = 'IF ' and IsFree) or (OpcodeDS.Three = 'IF(' and IsFree); exsr srLoadBeginB; 5x elseif (OpcodeDS = 'SELECT '); exsr srLoadBeginB; SelectDepth(cc) = *on; //--------------------------------------------------------- // save most recent 'DO'/FOR number for use as indent nt // on iter and leave operations. Number is saved into array // whose element position is how many dos and element // value represents number of that do. 5x elseif (OpcodeDS.Two = 'DO' and (not IsFree)) or (OpcodeDS = 'DO ' and IsFree) or (OpcodeDS = 'DOU ' and IsFree) or (OpcodeDS = 'DOW ' and IsFree) or OpcodeDS = 'MONITOR ' or OpcodeDS = 'FOR ' or OpcodeDS.Four = 'FOR('; exsr srLoadBeginB; dd += 1; ado(dd) = cc; //--------------------------------------------------------- // CASxx opcodes. Trick is there could be several // cas opcodes in row and only first each group is // used to trigger record update. // IsCasxx is setof when end is found. 5x elseif OpcodeDS.Three = 'CAS' and (not IsCasxx) and (not IsFree); exsr srLoadBeginB; IsCasxx = *on; //--------------------------------------------------------- // process else, wh, & other op codes. Update record // and count remains same. 5x elseif OpcodeDS = 'GOTO ' //EVIL GOTO STATEMENTS and (not IsFree); StructNumb = 'GO'; exsr srFormatOutput; //--------------------------------------------------------- // flag LEAVESR for easy viewing 5x elseif OpcodeDS = 'LEAVESR '; StructNumb = 'LV'; 6b if p_Indentfree = '*YES' and IsFree; exsr srIndentFree; 6e endif; exsr srFormatOutput; //--------------------------------------------------------- // process else, wh, & other op codes. Update // record and count remains same. 5x elseif (OpcodeDS.Two = 'WH' and (not IsFree)) or OpcodeDS = 'OTHER ' or OpcodeDS = 'ELSE ' or OpcodeDS = 'ELSEIF ' or OpcodeDS = 'ON-ERROR ' or OpcodeDS = 'WHEN '; StructNumb = %char(cc) + 'x'; 6b if p_Indentfree = '*YES' and IsFree; IsEndCheat = *on; exsr srIndentFree; IsEndCheat = *off; 6e endif; exsr srFormatOutput; //--------------------------------------------------------- // process iter Opcode. i is moved into code // and record is updated using innermost // do count depth save array. 5x elseif OpcodeDS = 'ITER '; StructNumb = %char(ado(dd)) + 'i'; 6b if p_Indentfree = '*YES' and IsFree; exsr srIndentFree; 6e endif; exsr srFormatOutput; //--------------------------------------------------------- // process leave opcode. Load V into code and // record is updated using innermost do count from do // depth save array. 5x elseif OpcodeDS = 'LEAVE '; StructNumb = %char(ado(dd)) + 'v'; 6b if p_Indentfree = '*YES' and IsFree; exsr srIndentFree; 6e endif; exsr srFormatOutput; //--------------------------------------------------------- // process endxx . E is moved into code and record // is updated. depth has 1 subtracted after update. 5x elseif OpcodeDS <> 'ENDSR' and ( (OpcodeDS.Three = 'END' and (not IsFree)) or OpcodeDS = 'END ' or OpcodeDS = 'ENDSL ' or OpcodeDS = 'ENDIF ' or OpcodeDS = 'ENDDO ' or OpcodeDS = 'ENDMON ' or OpcodeDS = 'ENDFOR '); IsCasxx = *off; StructNumb = %char(cc) + 'e'; //--------------------------------------------------------- // if cc = 0 then there are too many END opcodes. // Send message with statement number where error // occurred. 6b if cc <= 0; close RPGSRC; f_SndCompMsg('WARNING: Unmatched ENDxx Opcode at ' + SeqNo + ' - JCRNUMB canceled!'); *inlr = *on; return; 6e endif; //--------------------------------------------------------- // match proper endxx to opcode that started the // structure. ie. if/endif , do/enddo // If END is free format, is required to have proper endXX suffix. 6b if p_EndLabel = '*YES'; 7b if op(cc) = 'SE'; OpcodeDS = 'endsl'; 7x elseif op(cc) = 'CA'; OpcodeDS = 'endcs'; 7x else; OpcodeDS = 'end' + op(cc); 7e endif; //--------------------------------------------------------- // Determine text case of end opcode. Write out // matching ENDxx in same case as it was before. 7b if %scan(FirstDigitOpc: up) = 0; OpcodeDS = %xlate(up: lo: OpcodeDS); 7x elseif %scan(SecondDigitOpc: up) > 0; OpcodeDS = %xlate(lo: up: OpcodeDS); 7x else; OpcodeDS = %xlate(up: lo: OpcodeDS); OpcodeDS.One = %xlate(lo: up: OpcodeDS.One); 7e endif; 7b if not IsFree; TypeOutput = 'ENDXX '; exsr srFormatOutput; 7x else; //--------------------------------------------------------- // determine size of existing end statement, then use %replace upperSrc = %xlate(lo: up: Src94); aa = %scan('END': upperSrc); bb = %scan(';': Src94: aa); //--------------------------------------------------------- // if bb = 0 then there is 'END' statement // coded that does not terminate with semi-colon. 8b if bb = 0; close RPGSRC; f_SndCompMsg( 'WARNING: Unterminated ENDxx opcode at ' + SeqNo + ' - JCRNUMB canceled!'); *inlr = *on; return; 8e endif; Src94 = %replace(%trimr(OpcodeDS) + ';': Src94: aa: (bb - aa) + 1); 8b if p_Indentfree = '*YES'; IsEndCheat = *on; exsr srIndentFree; IsEndCheat = *off; 8e endif; exsr srFormatOutput; 7e endif; 6e endif; //--------------------------------------------------------- // if END is for innermost do, then clear that // element of do number array. 6b if (dd > 0) and (ado(dd) = cc); ado(dd) = 0; dd -= 1; 6e endif; cc -= 1; ee -= 1; 6b if cc > 0; SelectDepth(cc) = *off; 6e endif; 5x else; //--------------------------------------------------------- // if none of above conditions are met, the excpt is used // to clear record from whatever may have been there before. 6b if p_Indentfree = '*YES' and IsFree; exsr srIndentFree; 6e endif; TypeOutput = 'CLEAR '; exsr srFormatOutput; 5e endif; 4e endif; // look for line terminating in semi-colon 4b if IsSqlExec; IsSqlExec = (%scan(';': Src94: 1) = 0); TypeOutput = 'CLEAR '; exsr srFormatOutput; 4e endif; 3e endif; 2e endif; read RPGSRC; 1e enddo; close RPGSRC; // send message if unmatched ENDXX codes 1b if cc > 0; f_SndCompMsg('WARNING: ' + %triml(%editc(cc:'4')) + ' ENDxx opcodes are missing. - JCRNUMB canceled!'); 1x else; f_SndCompMsg('JCRNUMB for ' + %trimr(p_SrcMbr) + ' in ' + %trimr(extIfile) + ' - completed'); 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Format output depending on line type; begsr srFormatOutput; SrcUpdateDS = Src18 + Src94; %subst(SrcUpdateDS: 13: 1) = ' '; //remove color 1b if TypeOutput = 'CALC LINE '; 2b if IsCSR; %subst(SrcUpdateDS: 19: 2) = *blanks; 2e endif; %subst(SrcUpdateDS: 14: 4) = StructNumb; //--------------------------------------------------------- 1x elseif TypeOutput = 'COMMENT-FREE '; 2b if IsInsideCalcs; %subst(SrcUpdateDS: 13: 6) = *blanks; 2e endif; 2b if p_HighLight = '*YES'; %subst(SrcUpdateDS: 16: 1) = WhiteHex; 2x else; %subst(SrcUpdateDS: 16: 1) = ' '; 2e endif; //--------------------------------------------------------- 1x elseif TypeOutput = 'COMMENT-FIXED'; 2b if IsInsideCalcs; %subst(SrcUpdateDS: 13: 5) = *blanks; 2e endif; 2b if p_HighLight = '*YES'; %subst(SrcUpdateDS: 18: 1) = WhiteHex; 2x else; %subst(SrcUpdateDS: 18: 1) = ' '; 2e endif; %subst(SrcUpdateDS: 19: 1) = '*'; //--------------------------------------------------------- 1x elseif TypeOutput = 'CLEAR '; 2b if IsInsideCalcs; %subst(SrcUpdateDS: 13: 5) = *blanks; 2e endif; 2b if IsCSR; %subst(SrcUpdateDS: 19: 2) = *blanks; 2e endif; //--------------------------------------------------------- 1x elseif TypeOutput = 'ENDXX '; %subst(SrcUpdateDS: 14: 4) = StructNumb; 2b if IsCSR; %subst(SrcUpdateDS: 19: 2) = *blanks; 2e endif; 2b if p_EndLabel = '*YES'; %subst(SrcUpdateDS: 38: 10) = OpcodeDS; 2e endif; 1e endif; update RPGSRC SrcUpdateDS; endsr; //--------------------------------------------------------- // strip all hex color codes out of all code lines //--------------------------------------------------------- begsr srStripColors; 1b for zz = 13 to 18; 2b if %subst(Src18: zz: 1) >= Hex21 and %subst(Src18: zz: 1) <= Hex3F; %subst(Src18: zz: 1) = *blanks; 2e endif; 1e endfor; 1b for zz = 1 to 94; 2b if SrcArry(zz) >= Hex21 and SrcArry(zz) <= Hex3F; SrcArry(zz) = *blanks; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // load number of begin and opcode name for use when flagging ends. begsr srLoadBeginB; 1b if p_Indentfree = '*YES' and IsFree; exsr srIndentFree; 1e endif; cc += 1; ee += 1; StructNumb = %char(cc) + 'b'; TypeOutput = 'CALC LINE '; exsr srFormatOutput; 1b if OpcodeDS = 'MONITOR' ; op(cc) = 'MON'; 1x elseif OpcodeDS.Two = 'FO'; op(cc) = 'FOR'; 1x else; op(cc) = OpcodeDS.Two; 1e endif; endsr; //--------------------------------------------------------- // reformat indentions for /free code. // if indention would make calc line go past 74 // then indent line as much as possible but do not go past 74. begsr srIndentFree; 1b if Src94 > *blanks; 2b if IsEndCheat; //--------------------------------------------------------- // if ee = 0 then there are too many END opcodes. // Send message with statement number where error // occurred. ee -= 1; 3b if ee < 0; close RPGSRC; f_SndCompMsg('WARNING: Unmatched ENDxx Opcode at ' + SeqNo + ' - JCRNUMB canceled!'); *inlr = *on; return; 3e endif; 2e endif; // parms under callp are synced to start of program name 2b if IsCallp or IsFunction; clear wrkb; %subst(wrkb: pp) = %triml(Src94); 2x else; %len(wblanks) = p_Indentspace * ee; wrkb = ' ' + Wblanks + %triml(Src94); 2e endif; exsr srIndentOrNot; 2b if IsEndCheat; ee += 1; 2e endif; //--------------------------------------------------------- // set CALLPARM flag if within callp // first ; outside comment resets to off 2b if OpcodeDS.Six = 'CALLP ' or OpcodeDS.Six = 'CALLP('; IsCallp = *on; // now to get where program name starts // callp(e) pgm( I want to line up with pgm. pp = %scan('(': Src94); 3b if OpcodeDS.Six = 'CALLP('; pp = %scan('(': Src94: pp + 1); 3e endif; 3b for aa = pp downto 1; 4b if %subst(Src94: aa: 1) = ' '; 3v leave; 4e endif; 3e endfor; pp = aa + 1; 2e endif; //--------------------------------------------------------- // My personal standard is all function names must // must begin with f_. Given this, I want all parms // under function name to line up with function name. 2b if not IsFunction; //already in function aa = %scan('f_': Src94); 3b if aa > 0 and %scan('(': Src94: aa) > 0; IsFunction = *on; pp = aa; 3e endif; 2e endif; // now to turn callp flag off. Trigger will be first // ; that is not behind comment line. aa = %scan(';': Src94); 2b if aa > 0; bb = %scan('//': Src94); 3b if bb = 0 or bb > aa; IsCallp = *off; IsFunction = *off; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Ok, two pieces distinct pieces of information on /free line. // with different rules for where they can be placed in code. // 1. code 2.comment // 1. code is defined as everything before // (if // is not inside // Quotations) // x=' // this is not a comment' // this is a comment // 2. comment is anything after unquoted // including //. // This 'code can only go to 92 but comments can go to 112' adds // whole new level of complexity to the whole thing! // After indentation, // 1. If code will not fit at position 92. Cannot Indent. // 2. If code will fit at 92 and comment will fit at 112. Indent OK // 3. If code will fit at 92 and comment will NOT fit at 112: // Is there enough space between end of code and // start of comment to compress out spaces? // x=a // qweqweqwe // x=a //qweqweqwe // If after compression, (see 2), else if it still will not fit, // do not indent. //--------------------------------------------------------- begsr srIndentOrNot; 1b if %len(%trimr(wrkb)) <= 74 // all good it will fit or (IsComment and %len(%trimr(wrkb)) <= 94); Src94 = wrkb; 1x else; //--------------------------------------------------------- // determine length of code, // if will not fit in 74, cannot indent // find starting position of last // in code StartOfComment = 0; ww = 0; 2b dou ww = 0; ww = %scan('//': wrkb: ww + 1); 3b if ww > 0; StartOfComment = ww; 3e endif; 2e enddo; 2b if StartOfComment = 0; //source will not fit in 74 LV leavesr; 2e endif; //--------------------------------------------------------- // determine if // is between two Quotes // Note this could get tripped up if there are // Quotes in comment and code. Oh well, I tried! // Sure bet would be not to put Quotes after //. // If no Quotes after //, then we have a legit comment. //--------------------------------------------------------- q2 = %scan(qs: wrkb: StartOfComment); 2b if q2 > 0; q1 = 0; 3b for ww = StartOfComment downto 1; 4b if %subst(wrkb: ww: 1) = qs; q1 = ww; 3v leave; 4e endif; 3e endfor; 3b if q1 > 0 and (q1 < StartOfComment and q2 > StartOfComment); LV leavesr; //the comment marker is within Quotes 3e endif; 2e endif; //--------------------------------------------------------- // If we get here, we have source that will fit but comments will not. // see if there are any spaces between end of code // and start of comment that can be compressed // out. If so, compress and see if indented line will fit. EndOfCode = %checkr(' ': wrkb: StartOfComment - 1); 2b if EndOfCode < 92; %len(wblanks) = StartOfComment - EndofCode; 3b dou %len(wblanks) = 1; wrkb2 = %subst(wrkb: 1: EndOfCode) + wblanks + %subst(wrkb: StartOfComment); 4b if %len(%trimr(wrkb2)) <= 94; Src94 = wrkb2; LV leavesr; 4e endif; %len(wblanks) = %len(wblanks) - 1; 3e enddo; 2e endif; 1e endif; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCRNUMBR3 - Number logic structures in RPG source - RPG3 * Put DO & IF numbers to right of source code similar to count placed to left of source * code in a compiler listing. * A *PSSR subroutine will execute if source has too many ENDS * Comment lines are changed to look like those in this pgm. * END statements are updated to match type of structure. * *OFF and *ON are used for indicators in place of 0 or 1. *---------------------------------------------------------------- FRPGSRC UF F 92 DISK D ADO s 2 0 DIM(100) DO DEPTH ARRAY D OP s 2a DIM(100) OPCODE FOR ENDS * D SDS D ERR *STATUS * D HEX22 c const(X'22') D CODE s 1a D FACT2 s 10a D RETURN s 6a D bb s 3u 0 NUMBER OF DOS D EndOpcode s 4a LABEL END OPCOD D vL s 2p 0 INDENT COUNT D vSAVE s 2p 0 D vSTNCM s 4a IRPGSRC NS LR 13 C* 14 C* * STOP 1ST ARRAY ENCOUNTERED. I NS 01 18 CC 19NC* I 1 4 vSEQNO I 19 20 vSRYUK I 40 41 DOIFWH I 40 42 CASEND I 40 43 ELSE I 40 44 OPCODE I 45 49 v2FACT I 30 32 IND1 I 45 47 STAT I 55 57 IND2 I 55 60 v3FACT I 63 63 vLength I 66 67 vHI I 68 69 vLO I 70 71 vEQ I NS 02 19 C* * * NS 02 18NC 19 C* I NS 03 *---------------------------------------------------------------- C EVAL vSTNCM = '*YES' STANDARD COMMEN C EVAL EndOpcode = '*YES' LABEL END OPCOD C EVAL *IN50 = *ON HIGH LIGHT CMNT * 1b C IF EndOpcode = '*YES' UPDATE ENDXX C EVAL *IN11 = *ON PRINT INDICATOR 1e C ENDIF * C READ RPGSRC LR PRIMER READ 1b C DOW not *INLR PROCESS LOOP C SETOFF 2030 * 2b C SELECT 2x C WHEN *IN03 NOT COMM/NOT IF C EXCEPT vCLEAR CLEAR ALL OTHER * 2x C WHEN *IN01 ONLY CALC LINES 3b C IF vSRYUK = 'SR' SUBROUTINE C EVAL *IN30 = *ON OUTPUT INDICATR 3e C ENDIF * *---------------------------------------------------------------- * Process IF & SELEC CALC codes. See subroutine. *---------------------------------------------------------------- 3b C SELECT 3x C WHEN DOIFWH = 'IF' or IF LINES C OPCODE = 'SELEC' BEGIN SELECT C EXSR SRIND C EXSR SRLOAD * *---------------------------------------------------------------- * Save most recent 'DO' number for use as indent count * on ITER and LEAVE operations. Number is saved into array * whose element position is how many DOs and value in * element represents number of that DO. *---------------------------------------------------------------- 3x C WHEN DOIFWH = 'DO' DO LINES C EXSR SRIND C EXSR SRLOAD C ADD 1 bb NUMBER OF DOS C EVAL ADO(bb) = vL DEPTH OF DO * *---------------------------------------------------------------- * Process CAS opcode. Trick is there could be several * CAS opcodes in a row and only first one in each group is * used to trigger record update. * *IN10 is setof when END is found. *---------------------------------------------------------------- 3x C WHEN CASEND = 'CAS' and CASE LINES C not *IN10 FIRST STATEMENT C EVAL *IN10 = *ON C EXSR SRIND C EXSR SRLOAD * *---------------------------------------------------------------- * Process ELSE, WH, & OTHER op codes. Record is updated * and count remains same. *---------------------------------------------------------------- 3x C WHEN ELSE = 'ELSE' or ELSE STATEMENTS C DOIFWH = 'WH' or WHEN TRUE C OPCODE = 'OTHER' C EVAL CODE = 'X' LOAD X CODE C EXCEPT vIFNUM UPDATE RECORD * *---------------------------------------------------------------- * Process ITER opcode. I is moved into code and * record is updated using INNERMOST DO count from DO * depth save array. *---------------------------------------------------------------- 3x C WHEN OPCODE = 'ITER ' ITERATE C EVAL vSAVE = vL C EVAL vL = ADO(bb) C EVAL CODE = 'I' C EXCEPT vIFNUM UPDATE RECORD C EVAL vL = vSAVE * *---------------------------------------------------------------- * Process LEAVE opcode. LI is moved into code and * record is updated using INNERMOST DO count from DO * depth save array. *---------------------------------------------------------------- 3x C WHEN OPCODE = 'LEAVE' LEAVE C EVAL vSAVE = vL C EVAL vL = ADO(bb) C EVAL CODE = 'L' C EXCEPT vIFNUM UPDATE RECORD C EVAL vL = vSAVE * *---------------------------------------------------------------- * Process ENDxx opcode. E is moved into code and * record is updated. Depth has 1 subtracted after update. *---------------------------------------------------------------- 3x C WHEN CASEND = 'END' and END C OPCODE <> 'ENDSR' C CLEAR *IN10 C EVAL CODE = 'E' * *---------------------------------------------------------------- * Match proper ENDxx to opcode that started * structure. ie. IF/ENDIF , DO/ENDDO *---------------------------------------------------------------- 4b C IF EndOpcode = '*YES' MATCH ENDXX 5b C SELECT 5x C WHEN OP(vL) = 'CA' CASXX C eval OPCODE = 'END' + 'CS' 5x C WHEN OP(vL) = 'SE' SELECT C eval OPCODE = 'END' + 'SL' 5x C OTHER C eval OPCODE = %trimr('END') + OP(vL) 5e C ENDSL 4e C ENDIF C EXCEPT vENDXX UPDATE RECORD C EVAL vSAVE = vL C EVAL vL = vL - 1 RESET COUNT * *---------------------------------------------------------------- * If END is for innermost DO, then clear that element * of DO number array. *---------------------------------------------------------------- 4b C IF bb > 0 and C ADO(bb) = vSAVE CHECK FOR END C CLEAR ADO(bb) OF INNERMOST C EVAL bb = bb - 1 DO 4e C ENDIF * *---------------------------------------------------------------- * If none of above conditions are met, the excpt is used * to clear record from whatever may have been there before. *---------------------------------------------------------------- 3x C OTHER C EXSR SRIND C EXCEPT vCLEAR CLEAR ALL OTHER 3e C ENDSL * 2x C WHEN *IN02 COMMENT LINE 3b C IF vSTNCM = '*YES' C EXCEPT vNEWCM STANDARD COMMNT 3x C ELSE C EXCEPT vCLEAR LEAVE ALONE 3e C ENDIF 2e C ENDSL C SETOFF 010203 RECORD ID * C READ RPGSRC LR GET NEXT REC 1e C ENDDO * *---------------------------------------------------------------- * Load indent count into return parm if there are not * enough ENDxx statements for the code. *---------------------------------------------------------------- 1b C IF vL > 0 C EVAL vSTNCM = '2M' TOO MANY C MOVE vL vSTNCM IFS. 1e C ENDIF C RETURN * *---------------------------------------------------------------- * Upgrade '0' or '1' to *OFF or *ON for indicators used as fields *---------------------------------------------------------------- C SRIND BEGSR 1b C IF IND1 = '*IN' or INDICATOR USED C IND2 = '*IN' INDICATOR USED * 2b C IF STAT = '''0''' *OFF C EVAL FACT2 = '*OFF' C EVAL *IN20 = *ON 2e C ENDIF * 2b C IF STAT = '''1''' *ON C EVAL FACT2 = '*ON' C EVAL *IN20 = *ON 2e C ENDIF 1e C ENDIF C ENDSR * *---------------------------------------------------------------- * Load number of BEGIN and opcode name for use when * flagging ENDs. *---------------------------------------------------------------- C SRLOAD BEGSR C ADD 1 vL INDENT COUNT C EVAL CODE = 'B' LOAD BEGIN CODE C EXCEPT vIFNUM UPDATE RECORD * C EVAL OP(vL) = DOIFWH SAVE OPCODE C ENDSR *---------------------------------------------------------------- * Monitor for array index error occurring (as commonly does * when source has too many ENDXX. Statement number of * line in error is loaded into one of input parms and * program cancels gracefully. *---------------------------------------------------------------- C *PSSR BEGSR 1b C IF ERR = 121 BAD ARRAY INDEX C EVAL vSTNCM = vSEQNO C EVAL *INLR = *ON C EVAL RETURN = '*CANCL' 1e C ENDIF C ENDSR RETURN * ORPGSRC E vCLEAR O 17 ' ' O 30 20 ' ' O 20 FACT2 54 *--------------------------------------------- O E vIFNUM O 17 ' ' O vL Z 14 O CODE 15 O 30 20 ' ' O 20 FACT2 54 *--------------------------------------------- O E vENDXX O 17 ' ' O vL Z 14 O CODE 15 O 30 20 ' ' O 11 OPCODE 44 *--------------------------------------------- O E vNEWCM O 17 ' ' O 19 ' *' O 50 HEX22 18 ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCROBJD - Expanded work with object descriptions - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Expanded Object Descriptions') PARM KWD(OBJ) TYPE(OBJ) PROMPT('Object:') OBJ: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) MIN(1) QUAL TYPE(*NAME) LEN(10) SPCVAL((*ALL *ALL) + (*ALLUSR *ALLUSR)) PROMPT('Library:') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) DFT(*ALL) + MIN(0) PROMPT('Object type:') PARM KWD(EXTOBJATR) TYPE(*CHAR) LEN(10) DFT(*ALL) + PROMPT('Object ATR (PF LF etc.):') PARM KWD(CREATEDBY) TYPE(*CHAR) LEN(10) DFT(*ALL) + CHOICE('*ALL, User Profile Name') + PROMPT('Created by User Profile Name:') PARM KWD(ALLOWOPT) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Allow Options Selection:') ]]> v5r4 *---------------------------------------------------------------- * JCROBJDD - Expanded work with object descriptions - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A CA03 A CA05 A CA12 A CA13 A CA14 A MOUBTN(*ULP CA13) A MOUBTN(*URP CA14) A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A INDARA A R SBFDTA1 SFL A HIDRISFL 1A H A HIDNDSFL 1A H A HIDSORTCRT 7A H A HIDSORTLST 7A H A HIDOTYPE 10A H A HIDOLIB 10A H A AOPTIONSFL 1A P A ARISFL 1A P A ANDSFL 1A P A SBFOPTION 1Y 0B 7 2EDTCDE(4) DSPATR(&AOPTIONSFL) A OBJNAME 10A O 7 4DSPATR(&ARISFL) A OBJTYPE 7A O 7 15DSPATR(&ARISFL) A OBJATTR 4A O 7 23DSPATR(&ARISFL) A OBJTEXT 19A O 7 28DSPATR(&ARISFL) A OBJSIZE 9Y 0O 7 48EDTCDE(4) DSPATR(&ARISFL) A CREATEDATE 6Y 0O 7 58EDTCDE(Y) DSPATR(&ARISFL) A LASTUSED 6Y 0O 7 67EDTCDE(Y) DSPATR(&ANDSFL) A DAYSUSED 4Y 0O 7 76EDTCDE(3) DSPATR(&ARISFL) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0180) A *DS4 SFLSIZ(0180) A *DS3 SFLPAG(0015) A *DS4 SFLPAG(0015) A OVERLAY A RTNCSRLOC(&CURRCD &CURFLD) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A CURRCD 10A H A CURFLD 10A H A AOPTIONS 1A P A ASHOWUSR1 1A P A ASHOWUSR2 1A P A ANOTUSED 1A P A 1 2'JCROBJD' A COLOR(BLU) A 1 23'Expanded Work With Objects' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'Object' A HEADEROBJ 10A B 2 9DSPATR(HI) A 2 21'Lib' A HEADERLIB 10A B 2 25DSPATR(HI) A 2 37'Created by UserProfile:' A DSPATR(&ASHOWUSR1) A P_CRTUSR 10A O 2 61DSPATR(&ASHOWUSR2) A 2 72SYSNAME A COLOR(BLU) A 3 2'Type options, press Enter.' A DSPATR(&AOPTIONS) A 4 3'1=WRKOBJ' A DSPATR(&AOPTIONS) A 4 12'2=DSPOBJD' A DSPATR(&AOPTIONS) A 4 22'3=DSPOBJLCK' A DSPATR(&AOPTIONS) A 4 34'4=DELETE' A DSPATR(&AOPTIONS) A 4 43'5=CLRPFM' A DSPATR(&AOPTIONS) A DBUTILITY 8A O 4 52DSPATR(&AOPTIONS) A 4 61'8=*ALLUSR' A DSPATR(&AOPTIONS) A 4 71'9=WRKMBR' A DSPATR(&AOPTIONS) A 5 12'Reverse image objects have no Last- A Used date.' A DSPATR(&ANOTUSED) A 5 68'Last' A DSPATR(HI) A 5 74'Times' A DSPATR(HI) A 6 2'Opt' A DSPATR(HI) A 6 7'Object' A DSPATR(HI) A 6 15'Type' A DSPATR(HI) A 6 23'Attr' A DSPATR(HI) A 6 28'Text' A DSPATR(HI) A 6 50'Size(K)' A DSPATR(HI) A 6 58'Created' A DSPATR(HI) A 6 68'Used' A DSPATR(HI) A 6 75'Used' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 11'F5=Refresh' COLOR(BLU) A 23 24'F13=Sort Ascending' COLOR(BLU) A 23 45'F14=Sort Descending' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCROBJD'.Expanded Object Descriptions (JCROBJ) - Help .*-------------------------------------------------------------------- :P.This JCR command works with list objects similar to WRKOBJ command. You may sort any column either ascending or descending by placing cursor on data in appropriate column and pressing a command key. Objects displayed in reverse image have not been used since creation date.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCROBJD/OBJ'.Object name - Help :XH3.Object name (OBJ) :P.Name/*All/Generic* and library of objects to be selected.:EHELP. :HELP name='JCROBJD/OBJTYPE'.Object Type - Help :XH3.Object Type (OBJTYPE) :P.Type of object to select.:EHELP. :HELP name='JCROBJD/EXTOBJATR'.Object ATR (PF LF etc.) - Help :XH3.Object ATR (PF LF etc.)(EXTOBJATR) :P.Allows to further refine *FILE objects with PF, LF, PRTF, or DSPF.:EHELP. :HELP name='JCROBJD/CREATEDBY'.Created by User Profile Name - Help :XH3.Created by User Profile Name (CREATEDBY) :P.Select only objects created by this profile.:EHELP. :HELP name='JCROBJD/ALLOWOPT'.Allow Options Selection - Help :XH3.Allow Options Selection (ALLOWOPT) :P.Show option selections on main screen. For a developer, you would probably want this *YES, for a business user, *NO.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCROBJDR - Expanded work with object descriptions // call Quslobj API to load list of Objects. // call Qlgsort API to sort subfile entries. // Show last used date. // Allow user to work with displayed Objects. // call API to reset job values to original values. // Note: only 9999 objects will be displayed. // added Qwtchgjbb API to speed up process a little. // PURGE=*NO. // RUNPTY= one less than current pty. // TIMESLICE = 500 more than current slice for duration of this program run. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCROBJDD cf e workstn sfile(SBFDTA1: rrn) Infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D SaveOriginal s like(QwcrtvcaDS) D dStamp s 8a D KeyFld s 10a inz('OBJSIZE') D SequenceText s 10a inz('Descending') D SortArry s 101a dim(9999) D LengthOfBuffer s 10i 0 D LoadedElements s 10i 0 D SequenceValue s 10i 0 inz(2) D DeleteCount s 5u 0 D ForCount2 s 3u 0 D NumberOfRecs s 5u 0 D RRNsave s 5u 0 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define ApiStampDS /Define Constants /Define Infds /Define Dspatr /Define FunctionKeys /Define Ind /Define Qlgsort /Define Quslobj /Define Qwccvtdt /Define Sds /Define UserSpaceHeaderDS /Define f_AddSortKey /Define f_BuildString /Define f_RunOptionObject /Define f_GetQual /Define f_Quscrtus /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_GetFileUtil /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // change job APIs D BinaryKeysArry ds qualified D Purge1604 10i 0 inz(1604) D Runpty1802 10i 0 inz(1802) D TimeSlice2002 10i 0 inz(2002) D QwcrtvcaDS ds 150 qualified D AttrReturnCnt 10i 0 inz // ds to extract retrieved attributes from API call D rtvc0100DS ds qualified based(rtvc0100Ptr) D Length 10i 0 D Key 10i 0 D DataType 1a D Reserved 3a D LenOfData 10i 0 D Data 30a D Alpha2NumDS ds qualified D Numeric 10i 0 inz // ScreenFieldDS - load screen fields into sort array. D ScreenFieldDS ds inz D ObjName D ObjType D ObjAttr D ObjText D ObjSize D CreateDate D LastUsed D DaysUsed D hidRIsfl D hidNDsfl D HidSortcrt C YY MM DD for sort D HidSortlst C YY MM DD for sort D HidOtype Full object type D HidOlib Full object type //--*CALL PROTOTYPES--------------------------------------- D Qwcrtvca PR extpgm('QWCRTVCA') retrieve current atr D 150a receiver D 10i 0 const receiver length D 8a const api format D 10i 0 const number of keys D 12a list of keys Db like(ApiErrDS) D Qwtchgjb PR extpgm('QWTCHGJB') change current job D 26a const job name *=current D 16a const internal identifier D 8a const api format D 150a receiver Db like(ApiErrDS) //--*ENTRY PARMS------------------------------------------- D p_JCROBJDR PR extpgm('JCROBJDR') D 20a D 10a D 10a D 10a D 4a D p_JCROBJDR PI D p_ObjQual 20a D p_ObjTyp 10a D p_Objatr 10a D p_CrtUsr 10a D p_AllowOption 4a //--------------------------------------------------------- /free IsFirstTime = *on; f_SndStatMsg(f_BuildString('Retrieving & type & - in progress': f_GetQual(p_ObjQual): p_ObjTyp)); aNotUsed = ND; evalr scDow = %trimr(f_GetDayName()); exsr srDiscretelyBumpJobPriorities; DbUtility = '6=' + f_GetFileUtil(); 1b if p_CrtUsr <> '*ALL '; aShowUsr1 = %bitor(Green: UL); aShowUsr2 = %bitor(White: RI); 1x else; aShowUsr1 = ND; aShowUsr2 = ND; 1e endif; 1b if p_AllowOption = '*NO '; aOptionSfl = %bitor(ND: PR); aOptions = ND; 1x else; aOptionSfl = %bitor(Green: UL); aOptions = Blue; 1e endif; // Create user space/retrieve pointer to user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; f_SndCompMsg(f_BuildString('JCROBJD for & type & - completed': f_GetQual(p_ObjQual): p_ObjTyp)); *inlr = *on; return; //--------------------------------------------------------- // Call API to load object name list. begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; aRIsfl = Green; aNDsfl = Green; aNotUsed = ND; write SBFCTL1; rrn = 0; HeaderObj = %subst(p_ObjQual: 1: 10); HeaderLib = %subst(p_ObjQual: 11: 10); callp QUSLOBJ( UserSpaceName: 'OBJL0700': p_ObjQual: p_ObjTyp: ApiErrDS); // change job back to original run priority 1b if IsFirstTime; IsFirstTime = *off; callp QWTCHGJB( '* ': ' ': 'JOBC0100': SaveOriginal: ApiErrDS); 1e endif; // Process data from user space by moving QuslobjPtr pointer. LoadedElements = 0; QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // only load objects that match selected attributes 2b if p_CrtUsr = '*ALL ' or p_CrtUsr = QuslobjDS.CreatedByUser; 3b if QuslobjDS.ExtendedAttr = p_Objatr or p_Objatr = '*ALL '; aRIsfl = Green; aNDsfl = Green; ObjName = QuslobjDS.ObjNam; HidOlib = QuslobjDS.ObjLib; ObjType = QuslobjDS.ObjTyp; HidOtype = QuslobjDS.ObjTyp; ObjAttr = QuslobjDS.ExtendedAttr; ObjText = QuslobjDS.ObjText; // Decode Date-Time_Stamp. dstamp = QuslobjDS.CreateStamp; callp QWCCVTDT( '*DTS ': dstamp : '*MDY ': ApiStampDS: ApiErrDS); HidSortcrt = ApiStampDS.Century + ApiStampDS.YY + ApiStampDS.MMDD; CreateDate = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); 4b if QuslobjDS.NumDaysUsed > 9999; DaysUsed = 9999; 4x else; DaysUsed = QuslobjDS.NumDaysUsed; 4e endif; 4b if QuslobjDS.NumDaysUsed > 0; dstamp = QuslobjDS.LastUseStamp; callp QWCCVTDT( '*DTS ': dstamp : '*MDY ': ApiStampDS: ApiErrDS); HidSortlst = ApiStampDS.Century + ApiStampDS.YY + ApiStampDS.MMDD; LastUsed = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); 4x else; aRIsfl = %bitor(Green: RI); aNotUsed = %bitor(Green: RI); aNDsfl = ND; LastUsed = 0; clear HidSortlst; 4e endif; ObjSize = (QuslobjDS.ObjSize * QuslobjDS.MultiplySize)/1024; 4b if ObjAttr = 'DDMF'; aRIsfl = Green; 4e endif; hidRIsfl = aRIsfl; hidNDsfl = aNDsfl; rrn += 1; LoadedElements += 1; SortArry(LoadedElements) = ScreenFieldDS; 4b if LoadedElements = 9999; 1v leave; 4e endif; 3e endif; 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; RRNsave = rrn; // Allow user to make selection from subfile. exsr srLoadFromSorter; 1b if IsRefresh <> *on or SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; 1b dow not (InfdsFkey = f03); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 2b if not Ind.sfldsp; f_RmvSflMsg(ProgId); f_SndSflMsg(ProgId: 'No objects matching your selection were found.'); 2e endif; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); // refresh 2b if InfdsFkey = f05; IsRefresh = *on; LV leavesr; 2e endif; // user selected new library or object 2b if not(HeaderObj = %subst(p_ObjQual: 1: 10) and HeaderLib = %subst(p_ObjQual: 11: 10)); %subst(p_ObjQual: 1: 10) = HeaderObj; %subst(p_ObjQual: 11: 10) = HeaderLib; LV leavesr; 2e endif; 2b if SflRecNbr > 0; SflRcdNbr = SflRecNbr; 2x else; SflRcdNbr = 1; 2e endif; // Selected to resort subfile 2b if InfdsFkey = f13 or InfdsFkey = f14; 3b if InfdsFkey = f13; SequenceText = 'Ascending'; SequenceValue = 1; 3e endif; 3b if InfdsFkey = f14; SequenceText = 'Descending'; SequenceValue = 2; 3e endif; KeyFld = curfld; exsr srSortAndReload; SflRcdNbr = 1; 1i iter; 2e endif; // Find record in subfile user has selected. DeleteCount = 0; readc SBFDTA1; 2b dow not %eof; 3b if sbfOption > 0; f_RunOptionObject( sbfOption: ObjName: HidOlib: HidOtype: ProgId); // Update subfile to reflect selected changes. 4b if sbfOption = 4; DeleteCount += 1; 4x else; sbfOption = 0; aRIsfl = hidRIsfl; aNDsfl = hidNDsfl; SflRcdNbr = rrn; update SBFDTA1; 4e endif; 3e endif; readc SBFDTA1; 2e enddo; 2b if DeleteCount > 0; exsr srSortAndReload; DeleteCount = 0; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // Read subfile and load records into sorting array. begsr srSortAndReload; NumberOfRecs = RRNsave; 1b if DeleteCount > 0; RRNsave -= DeleteCount; 2b if SflRcdNbr > RRNsave; SflRcdNbr = RRNsave; 2e endif; 1e endif; LoadedElements = 0; 1b for rrn = 1 to NumberOfRecs; chain rrn SBFDTA1; 2b if sbfOption <> 4; //DELETE OPTION LoadedElements += 1; SortArry(LoadedElements) = ScreenFieldDS; 2e endif; 1e endfor; exsr srLoadFromSorter; rrn = RRNsave; endsr; //--------------------------------------------------------- // Sort array and load back into subfile. begsr srLoadFromSorter; Ind.sfldsp = *off; Ind.sfldspctl = *off; aRIsfl = Green; aNDsfl = Green; write SBFCTL1; rrn = 0; qlgSortDS = %subst(qlgSortDS: 1: 80); //drop off keys qlgsortDS.RecordLength = %size(SortArry); qlgsortDS.RecordCount = LoadedElements; 1b if KeyFld = 'OBJSIZE '; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(41: 9: 2: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Size.'); 1x elseif KeyFld = 'OBJNAME '; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1: 10: 6: SequenceValue) + f_AddSortKey(82: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Object Name.'); 1x elseif KeyFld = 'OBJTYPE '; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(82: 10: 6: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Object Type.'); 1x elseif KeyFld = 'OBJATTR'; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(18: 4: 6: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Attribute.'); 1x elseif KeyFld = 'OBJTEXT '; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(22: 19: 6: SequenceValue); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Text.'); 1x elseif KeyFld = 'CREATEDATE'; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(68: 7: 6: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Created Date.'); 1x elseif KeyFld = 'LASTUSED'; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(75: 7: 6: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Last Used Date.'); 1x elseif KeyFld = 'DAYSUSED '; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(62: 4: 2: SequenceValue) + f_AddSortKey(1: 10); f_SndSflMsg(ProgId: 'Sort ' + %trimr(SequenceText) + ' by Number of Times Used.'); 1e endif; qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); LengthOfBuffer = LoadedElements * %size(SortArry); callp QLGSORT( qlgsortDS: SortArry: SortArry: LengthOfBuffer: LengthOfBuffer: ApiErrDS); 1b if LoadedElements >= 9999; f_RmvSflMsg(ProgId); f_SndSflMsg(ProgId: '9999+ objects returned. Narrow your search.'); LoadedElements = 9999; 1e endif; 1b for aa = 1 to LoadedElements; ScreenFieldDS = SortArry(aa); aRIsfl = hidRIsfl; aNDsfl = hidNDsfl; sbfOption = 0; rrn += 1; write SBFDTA1; 1e endfor; endsr; //--------------------------------------------------------- begsr srDiscretelyBumpJobPriorities; // retrieve job values callp QWCRTVCA( QwcrtvcaDS: %len(QwcrtvcaDS): 'RTVC0100': 3: BinaryKeysArry: ApiErrDS); //--------------------------------------------------------- // Trick is to first save original values then modify variable with our new values // so I can easily pass entire structure to change job API. // Lower Runpty by 1. // Set purge to *NO. // Add 500 to timeslice. SaveOriginal = QwcrtvcaDS; rtvc0100Ptr = %addr(QwcrtvcaDS) + 4; 1b for ForCount2 = 1 to QwcrtvcaDS.AttrReturnCnt; 2b if rtvc0100DS.Key = BinaryKeysArry.Purge1604; 3b if %subst(rtvc0100DS.Data: 1: rtvc0100DS.LenOfData) = '*YES'; %subst(rtvc0100DS.Data: 1: rtvc0100DS.LenOfData) = '*NO '; 3e endif; 2x elseif rtvc0100DS.Key = BinaryKeysArry.Runpty1802; Alpha2NumDS = rtvc0100DS.Data; 3b if Alpha2NumDS.Numeric > 1; Alpha2NumDS.Numeric -= 1; %subst(rtvc0100DS.Data: 1: 4) = Alpha2NumDS; 3e endif; 2x elseif rtvc0100DS.Key = BinaryKeysArry.TimeSlice2002; Alpha2NumDS = rtvc0100DS.Data; Alpha2NumDS.Numeric += 500; %subst(rtvc0100DS.Data: 1: 4) = Alpha2NumDS; 2e endif; rtvc0100Ptr += rtvc0100DS.Length; 1e endfor; // change job to new run values callp QWTCHGJB( '* ': ' ': 'JOBC0100': QwcrtvcaDS: ApiErrDS); endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCROLCK - Object lock list-sndbrkmsg or endjob(*immed) - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Jobs With Object Locks') PARM KWD(OBJ) TYPE(OBJ) PROMPT('Object:') OBJ: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) DFT(*FILE) MIN(0) PROMPT('Object type:') ]]> v5r4 *---------------------------------------------------------------- * JCROLCKD - Object lock list-sndbrkmsg or endjob(*immed) - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A INDARA A CA03 A CA05 A CA08 A CA10 A CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SCJOBNUMB 6A H A SBFOPTION 1Y 0B 6 2EDTCDE(4) A SCJOBNAME 10A O 6 5 A SCJOBUSER 10A O 6 16 * A SCDS 48 O 6 27 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0064) A *DS4 SFLSIZ(0064) A *DS3 SFLPAG(0016) A *DS4 SFLPAG(0016) A BLINK A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCROLCK' A COLOR(BLU) A 1 23'Jobs With Object Locks' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 2'Object:' A DSPATR(HI) A SCOBJHEAD 61A O 2 10 A 2 72SYSNAME A COLOR(BLU) A 3 2'Type options, press Enter.' A 4 2'1=Sndbrkmsg' A COLOR(BLU) A 4 15'2=Chgjob' A COLOR(BLU) A 4 25'3=Strsrvjob' A COLOR(BLU) A 4 38'4=Endjob' A COLOR(BLU) A 4 48'5=Dspjob' A COLOR(BLU) A 4 58'8=Wrksplf' A COLOR(BLU) A 5 5'Job' A DSPATR(HI) A 5 16'User' A DSPATR(HI) A SCTOGGHEAD 48 O 5 27DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A 23 2'F3=Exit' A COLOR(BLU) A 23 11'F5=Refresh' A COLOR(BLU) A 23 23'F8=Toggle Lock/User Info' A COLOR(BLU) A 23 49'F10=Set Break Msg' A COLOR(BLU) A 23 69'F12=Cancel' A COLOR(BLU) *---------------------------------------------------------------- A R WINDOWB A *DS3 WINDOW(5 2 5 73 *NOMSGLIN) A *DS4 WINDOW(5 2 5 73 *NOMSGLIN) A WDWTITLE((*TEXT 'Override Break Mes- A sage') (*COLOR WHT) (*DSPATR HI)) A OVERLAY A 1 2'Enter Break Message' A COLOR(PNK) A WBBRKMSG 70A B 3 2CHECK(LC) A 5 2'Enter=Accept' A COLOR(BLU) A 5 21'F12=Cancel' A COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCROLCK'.Jobs With Object Locks (JCROLCK) - Help .*-------------------------------------------------------------------- :P.This JCR command facilitates releasing locks on objects when you are in a hurry. You can SNDBRKMSG and ENDJOB *IMMED to jobs that have locks on selected object. Call to API retrieves list of jobs that have a lock. You can select options to perform on that job.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCROLCK/OBJ'.Object name - Help :XH3.Object name (OBJ) :P.Object and library to be selected.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCROLCKR - Object lock list-sndbrkmsg or endjob(*immed) // call Qwclobjl API to load jobs with object locks to user space. // use pointers to get offset information. // call API to extract job names from user space. // NOTE: If you wish to change standard break message text, change BreakMsgText. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCROLCKD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D SflRcdNbrSav s like(SflRcdNbr) D BreakMsgQueue s 20a dim(50) D BreakMsgText s 70a D JobNamePrev s 10a D JobNumbPrev s 6a D JobUserPrev s 10a D MbrName s 10a D IsToggleLock s n //--*DATA STRUCTURES--------------------------------------- // allow toggle between lock information and user profile text D LockInfoDS ds qualified D scLock 10a overlay(LockInfoDS:1) D scStatus 6a overlay(LockInfoDS:12) D scType 19a overlay(LockInfoDS:19) D scMbr 10a overlay(LockInfoDS:39) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define UserSpaceHeaderDS /Define f_BuildString /Define f_RunOptionJob /Define f_GetQual /Define f_GetDayName /Define f_Quscrtus /Define f_Qusrobjd /Define f_RmvSflMsg /Define f_SndSflMsg /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D Qmhsndbm PR extpgm('QMHSNDBM') send break message D 70a text D 10i 0 const length D 10a const type D 20a dim(50) msgq array D 10i 0 const msg length D 20a const msg reply queue Db like(ApiErrDS) D Qwclobjl PR extpgm('QWCLOBJL') object locks D 20a user space D 8a const api format D 20a object and lib D 10a object type D 10a mbr Db like(ApiErrDS) // ds of information returned from user space D QwclobjlDS DS qualified based(QwclobjlPtr) D JobName 10a overlay(QwclobjlDS:1) D JobUser 10a overlay(QwclobjlDS:11) D JobNumb 6a overlay(QwclobjlDS:21) D LockState 10a overlay(QwclobjlDS:27) D LockStatus 10i 0 overlay(QwclobjlDS:37) D LockType 10i 0 overlay(QwclobjlDS:41) D MbrName 10a overlay(QwclobjlDS:45) D Share 1a overlay(QwclobjlDS:55) D LockScope 1a overlay(QwclobjlDS:56) D ThreadID 8a overlay(QwclobjlDS:57) //--*ENTRY PARMS------------------------------------------- D p_JCROLCKR PR extpgm('JCROLCKR') D 20a D 10a D p_JCROLCKR PI D p_ObjQual 20a D p_ObjTyp 10a //--------------------------------------------------------- // Call to Qusrobjd to determine if object is // data file (LF or PF) or other type Object. If data file, // then set member parm to *ALL else set to *NONE //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); QusrObjDS = f_QUSROBJD(p_ObjQual: p_ObjTyp ); %subst(p_ObjQual: 11: 10) = QusrObjDS.ReturnLib; 1b if %subst(QusrObjDS.ExtendedAttr: 1: 2) = 'PF' or %subst(QusrObjDS.ExtendedAttr: 1: 2) = 'LF'; MbrName = '*ALL '; 1x else; MbrName = '*NONE'; 1e endif; scObjHead = f_BuildString('& & & &': %subst(p_ObjQual: 1: 10): QusrObjDS.ReturnLib: p_ObjTyp: QusrObjDS.Text); IsToggleLock = *on; BreakMsgText = f_BuildString('Lock status: &. Please SIGNOFF now.': p_ObjQual); // Create user space and get pointer to header section GenericHeaderPtr = f_Quscrtus(UserSpaceName); //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // call API to load object lockers name into user space. begsr srRefreshScreen; 1b if IsToggleLock; scToggHead = 'Lock'; %subst(scToggHead:12) = 'Status Type'; %subst(scToggHead:39) = 'Member'; 1x else; scToggHead = 'Text'; 1e endif; clear JobNamePrev; clear JobUserPrev; clear JobNumbPrev; callp QWCLOBJL( UserSpaceName: 'OBJL0100' : p_ObjQual : p_ObjTyp : MbrName: ApiErrDS); // Process list entries in user space. QwclobjlPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // Note: some jobs can have multiple different type locks on same object. // For this screen I only want to see one of them. 2b if not( JobNamePrev = QwclobjlDS.JobName and JobUserPrev = QwclobjlDS.JobUser and JobNumbPrev = QwclobjlDS.JobNumb); JobNamePrev = QwclobjlDS.JobName; JobUserPrev = QwclobjlDS.JobUser; JobNumbPrev = QwclobjlDS.JobNumb; // load presentation layer 3b if QwclobjlDS.LockStatus = 1; LockInfoDS.scStatus = '*ACTIV'; 3x elseif QwclobjlDS.LockStatus = 2; LockInfoDS.scStatus = '*WAIT '; 3x elseif QwclobjlDS.LockStatus = 3; LockInfoDS.scStatus = '*ASYNC'; 3x else; LockInfoDS.scStatus = '*ERROR'; 3e endif; 3b if QwclobjlDS.LockType = 1; LockInfoDS.scType = 'Lock on Object'; 3x elseif QwclobjlDS.LockType = 2; LockInfoDS.scType = 'Lock on Member'; 3x elseif QwclobjlDS.LockType = 3; LockInfoDS.scType = 'Lock on Access Path'; 3x elseif QwclobjlDS.LockType = 4; LockInfoDS.scType = 'Lock on Data '; 3e endif; scJobName = QwclobjlDS.JobName; scJobUser = QwclobjlDS.JobUser; scJobNumb = QwclobjlDS.JobNumb; LockInfoDS.scLock = QwclobjlDS.LockState; LockInfoDS.scMbr = QwclobjlDS.MbrName; scds = LockInfods; 3b if not IsToggleLock; QusrObjDS = f_QUSROBJD(QwclobjlDS.JobUser + 'QSYS ': '*USRPRF '); 4b if ApiErrDS.BytesReturned = 0; scDs = QusrObjDS.Text; 4x else; scDs = 'Not authorized '; 4e endif; 3e endif; rrn += 1; write SBFDTA1; 2e endif; QwclobjlPtr += GenericHeader.ListEntrySize; 1e endfor; // allow user to make selection from subfile. SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No Object Locks were found.'); 1e endif; Ind.sfldspctl = *on; 1b if IsRefresh and Ind.sfldsp; 2b if SflRcdNbrSav > rrn; SflRcdNbr = rrn; 2x else; 3b if SflRcdNbrSav = 0; SflRcdNbr = 1; 3x else; SflRcdNbr = SflRcdNbrSav; 3e endif; 2e endif; IsRefresh = *off; 1e endif; // display view 1b dow not (InfdsFkey = f03); write MSGCTL; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); SflRcdNbr = SflRecNbr; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; // refresh 2x elseif InfdsFkey = f05 or InfdsFkey = f08; IsRefresh = *on; SflRcdNbrSav = SflRcdNbr; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; rrn = 0; 3b if InfdsFkey = f08; IsToggleLock = not IsToggleLock; 3e endif; LV leavesr; // override standard break message 2x elseif InfdsFkey = f10; wbBrkMsg = BreakMsgText; exfmt WindowB; 3b if not (InfdsFkey = f12); BreakMsgText = wbBrkMsg; 3e endif; 2e endif; 2b if not Ind.sfldsp; 1i iter; 2e endif; // find record in subfile user has selected. readc SBFDTA1; 2b dow not %eof; 3b if sbfOption > 0; // Load and send break message. 4b if sbfOption = 1; BreakMsgQueue(1) = scJobName + '*LIBL '; f_SndSflMsg(ProgId: 'Break message sent.'); callp QMHSNDBM( BreakMsgText: %size(BreakMsgText): '*INFO ': BreakMsgQueue: 1: 'QSYSOPR *LIBL ': ApiErrDS); 4x else; f_RunOptionJob( sbfOption: scJobName: scJobUser: scJobNumb: ProgId); 4e endif; // update subfile to reflect selected change. sbfOption = 0; update SBFDTA1; SflRcdNbr = rrn; 3e endif; readc SBFDTA1; 2e enddo; 1e enddo; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRPARTI - Retrieve Partition Info for current system - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Retrieve Partition Info') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRPARTI'.Retrieve Partition Info (JCRPARTI) .*-------------------------------------------------------------------- :P.This JCR command returns message with system name, serial number, partition number (very important for licensing this days), OS version, User, and IP address. :P.Necessity when working on multiple systems/multiple partitions to help keep track of what system/partition you are on.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRPARTIR - Retrieve Partition Info for current system // *featured in 2010/01 iSeries News magazine //--------------------------------------------------------- H DFTACTGRP(*NO) ACTGRP(*CALLER) /IF DEFINED(*V6R1M0) H OPTION(*NOUNREF: *NODEBUGIO) /ELSE H OPTION(*NODEBUGIO) /ENDIF H BNDDIR('QUSAPIBD') //--*STAND ALONE------------------------------------------- D OsVersion s 6a D EquivalentOS s 6a D MsgTxt s 78a varying D NonVary s 78a D LparFormat s 10i 0 inz(1) D LparRcvLen s 10i 0 inz(%len(LparInfoDS)) D xx s 3u 0 D ListSpace s 20a inz('JCRCMDS QTEMP ') D IsFoundIP s n inz(*off) //--*DATA STRUCTURES--------------------------------------- D LparInfoDS ds qualified inz D LparNumber 10i 0 overlay(LparInfoDS:41) // Network Attribute Information Table returned D NetworkInfoDS ds qualified based(NetWorkInfoPtr) D Attribute 10a overlay(NetworkInfoDS:1) D TypeOfData 1a overlay(NetworkInfoDS:11) D InfoStatus 1a overlay(NetworkInfoDS:12) D LengthOfData 10i 0 overlay(NetworkInfoDS:13) D LocalSysName 8a overlay(NetworkInfoDS:17) D QwcrnetaDS ds 200 qualified inz D NumberKeys 10i 0 D OffsetToTable 10i 0 // Error return code parm for APIs. D ApiErrDS ds qualified D BytesProvided 10i 0 inz(%len(ApiErrDS)) D BytesReturned 10i 0 D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a D qwcrsvalDS ds 200 qualified D EntryCount 10i 0 overlay(qwcrsvalDS:1) D OffsetToVal 10i 0 overlay(qwcrsvalDS:5) dim(2) D InfoTableDS ds 50 qualified based(InfoTablePtr) D ValueName 10a overlay(InfoTableDS:1) D LenOfData 10i 0 overlay(InfoTableDS:13) D SystemValue 10a overlay(InfoTableDS:17) D jobi0100DS ds qualified D JobUser 10a overlay(jobi0100DS:19) D nifc0100DS ds qualified based(ptr) D IP 15 overlay(nifc0100DS:1) DLineDescription 10 overlay(nifc0100DS:51) //--------------------------------------------------------- // Get user space list info from header section. D GenericHeader DS qualified based(GenericHeaderPtr) D SizeOfUsrSpc 10i 0 overlay(GenericHeader:105) D OffSetToHeader 10i 0 overlay(GenericHeader:117) D OffSetToList 10i 0 overlay(GenericHeader:125) D ListEntryCount 10i 0 overlay(GenericHeader:133) D ListEntrySize 10i 0 overlay(GenericHeader:137) D UserSpaceName s 20a inz('JCRCMDS QTEMP ') D ForCount s 10i 0 //--*CALL PROTOTYPES--------------------------------------- D dlpar_get_info PR 10i 0 extproc('dlpar_get_info') LPAR info Db like(LparInfoDS) Receiver Db 10i 0 value Format Db 10i 0 value Receiver Length D Qmhsndpm PR extpgm('QMHSNDPM') Send Program Message D 7a const Message ID D 20a const File and Lib D 75a 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(ApiErrDS) Error Parm D Qwcrsval PR ExtPgm('QWCRSVAL') Get System Value D 200 Serial number D 10i 0 const QwcrsvalDS length D 10i 0 const Number of values D 20 const Sysval names Db like(ApiErrDS) Error parm D Qwcrneta PR extpgm('QWCRNETA') Network Attributes D 200a options(*varsize) Receiver Variable D 10i 0 const Receiver Length D 10i 0 const Number Of Keys D 20a const Constant Db like(ApiErrDS) Error Parm D Qusrjobi PR extpgm('QUSRJOBI') Retrieve Job Info Db 200a options(*varsize) Receiver D 10i 0 const Receiver Length D 8a const Api Format D 26a const Qualified Job Name D 16a const Internal Job Num Db like(ApiErrDS) Error Parm D qszchktg PR extpgm('QSZCHKTG') Check Target Release Db 10a const OS version D 10a const OS list D 10i 0 const Number of supported D 6a Validated release D 6a Equivalent release Db like(ApiErrDS) Error Parm D QtocLstNetIfc PR extproc('QtocLstNetIfc') D 20a user space D 8a const api format Db like(ApiErrDS) D f_Quscrtus PR * D 20a user space //--------------------------------------------------------- /free // get system name callp QWCRNETA( QwcrnetaDS : %size(QwcrnetaDS): 1: 'LCLCPNAME ': ApiErrDS); NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.OffsetToTable; MsgTxt = %trimr(NetworkInfoDS.LocalSysName); //--------------------------------------------------------- // get system serial number and model number callp QWCRSVAL( qwcrsvalDS: %size(qwcrsvalDS): 2: 'QMODEL QSRLNBR ': ApiErrDs); 1b for xx = 1 to qwcrsvalDS.EntryCount; InfoTablePtr = %addr(qwcrsvalDS) + qwcrsvalDS.OffsetToVal(xx); 2b if InfoTableDS.ValueName = 'QMODEL'; MsgTxt += ' M:'; 2x else; MsgTxt += ' S:'; 2e endif; MsgTxt += %trim( %subst(InfoTableDS.SystemValue: 1: InfoTableDS.LenOfData)); 1e endfor; //--------------------------------------------------------- // get Lpar partition number callp dlpar_get_info( LparInfoDS: LparFormat: LparRcvLen); MsgTxt += ' Partition:' + %trimr(%char(LparInfoDS.LparNumber)); //--------------------------------------------------------- // get OS version callp QSZCHKTG( '*CURRENT ': '*SAV ': 1: OsVersion: EquivalentOS: ApiErrDS); MsgTxt += ' ' + %trimr(OsVersion); //--------------------------------------------------------- // get current job information callp QUSRJOBI( jobi0100DS: %len(jobi0100DS): 'JOBI0100': '* ': ' ': ApiErrDS); MsgTxt += ' ' + %trimr(jobi0100DS.JobUser); //--------------------------------------------------------- // get IP address //--------------------------------------------------------- GenericHeaderPtr = f_Quscrtus(ListSpace); // call API to load network interface names into user space. callp QtocLstNetIfc( ListSpace: 'NIFC0100': ApiErrDS); IsFoundIP = *off; Ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if nifc0100DS.LineDescription = 'ETHERNET '; MsgTxt += ' ' + %trim(nifc0100DS.IP); IsFoundIP = *on; 1v leave; 2e endif; Ptr += GenericHeader.ListEntrySize; 1e endfor; // not everyone has their IP address labeled ETHERNET, if not found use first 1b if not IsFoundIP; Ptr = GenericHeaderPtr + GenericHeader.OffSetToList; MsgTxt += ' ' + %trim(nifc0100DS.IP); 1e endif; //--------------------------------------------------------- NonVary = MsgTxt; callp QMHSNDPM( ' ': ' ': NonVary: 78: '*INFO ': '*CTLBDY ': 1: ' ': ApiErrDS); *inlr = *on; return; /end-free //--------------------------------------------------------- // Create user space, change attributes to allow automatic extendibility, // and return pointer to user space. P f_Quscrtus B D f_Quscrtus PI * D p_UserSpace 20a D uPtr s * D ReturnLib s 10a D Quscrtus PR extpgm('QUSCRTUS') create user space D 20a user space D 10a const extended attribute D 10i 0 const length of space D 1a const hex0 initialize D 10a const use authority D 50a const text D 10a const replace object Db like(ApiErrDS) D 10a const domain D 10i 0 const transfer size D 1a const optimum space D Qusptrus PR extpgm('QUSPTRUS') retrieve pointer D 20a user space D * pointer Db like(ApiErrDS) /free callp QUSCRTUS( p_UserSpace: 'JCRCMDS': 102400: x'00': '*ALL': 'User Space JCRCMDS ': '*NO': ApiErrDS: '*DEFAULT': 32: '1'); callp QUSPTRUS( p_UserSpace: uPtr: ApiErrDS ); return uPtr; /end-free P f_Quscrtus... P E ]]> v6r1 */ /*--------------------------------------------------------------------------*/ /* JCRPATTR - Crtprtf with attributes from existing PRTF - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Create from PRTF Attributes') PARM KWD(PRTFMBR) TYPE(*NAME) MIN(1) PROMPT('PRTF source member name:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(0) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QDDSSRC) SPCVAL((QDDSSRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(CRTLIB) TYPE(*NAME) DFT(*SRCLIB) + SPCVAL((*SRCLIB)) MIN(0) PROMPT('Create PRTF in library:') PARM KWD(USEPRTF) TYPE(USEPRTF) MIN(1) PROMPT('Use Attributes from this Prtf:') USEPRTF: QUAL TYPE(*SNAME) LEN(10) DFT(*SRCMBR) SPCVAL((*SRCMBR)) QUAL TYPE(*NAME) LEN(10) DFT(*SRCLIB) SPCVAL((*SRCLIB)) PROMPT('Library:') ]]> v6r1 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRPATTR'.Create from PRTF Attributes (JCRPATTR) - Help .*-------------------------------------------------------------------- :P.This JCR command is used when you need to compile print file and use compile attributes from existing file. For example, your print file had different line count than default and you needed to recompile. :P.The command replicates common attributes from existing print file and applies them to compile command of your new print file. :P.This command uses the v6r1 Retrieve Printer File Attributes (QDFRPRTA) API. So is only available at v6r1 or better of the OS. Contact me if you need a V5 version.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRPATTR/PRTFMBR'.PRTF source member name - Help :XH3.PRTF source member name (PRTFMBR) :P.PRTF source member.:EHELP. :HELP name='JCRPATTR/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source member to be compiled.:EHELP. :HELP name='JCRPATTR/CRTLIB'.Create PRTF in library - Help :XH3.Create PRTF in library (CRTLIB) :P.Library where PRTF will be created.:EHELP. :HELP name='JCRPATTR/USEPRTF'.Use Attributes from this Prtf - Help :XH3.Use Attributes from this Prtf (USEPRTF) :P.Existing prtf object from which attributes will be retrieved. :PARML.:PT.:PK def.*SRCMBR:EPK.:PD.Use same name as PRTF being created. Useful if working on print and you have to recompile it several times. :PT.prtf-name :PD.Enter existing PRTF name. :PT.:PK def.*SRCLIB:EPK. :PD.Compile new PRTF into same library as source file. :PT.library-name :PD.Enter name of library to place PRTF object.:EPARML.:EHELP.:EPNLGRP. ]]> v6r1 //--------------------------------------------------------- // JCRPATTRR- Crtprtf with attributes from existing PRTF // Uses v6r1 Retrieve Printer File Attributes (QDFRPRTA) API. I am only pulling // fields that I have needed (or have been requested). If you need additional fields // added, contact me and I will get it in next release. I wish IBM had made // retrieve values such that you could plug them straight into a compile statement. // Most of this program is mapping from API returned values into compile values. // See data structure QDFRPRTADS in JCRCMDSCPY for fields. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs //--*STAND ALONE------------------------------------------- D string1 s 500a D xx s 3u 0 D PageRotation s 5a D IGCdata s 4a D IGCextension s 4a D Save s 4a D Hold s 4a D OverFlow s 3p 0 D pageLen s 6p 3 D pageWidth s 6p 3 D CPI s 3p 1 D LPI s 3p 1 D FMD s 7p 4 D FMA s 7p 4 D FrontMargin s 19a D FrontOverlay s 50a D BackOverlay s 50a D FrontOvlDown s 5p 3 D FrontOvlAccros s 5p 3 D BackOvlDown s 5p 3 D BackOvlAccros s 5p 3 D BackConstant s 11a D Chrid s 11a D MaxRecordsNum s 8p 0 D MaxRecords s 8a D CharIdSet s 5p 0 D CharIdCodePage s 5p 0 D UsrRscLibl s 100a D Text s 100a D PrtTxt s 100a //--*COPY DEFINES------------------------------------------ /Define ApiErrds /Define Constants /Define f_BuildString /Define f_GetQual /Define f_SndCompMsg /Define Qcmdexc /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- Df_InStringQuote PR 100a '''' for ' D 50a options(*varsize) quoted string D 3u 0 const length //--*CALL PROTOTYPES--------------------------------------- D QDFRPRTA PR extpgm('QDFRPRTA') print file attribute D 4000a receiver D 10i 0 const receiver length D 8a const format D 20a file name and lib Db like(ApiErrDS) D qdfrprtaDS DS 4000 qualified D BytesReturned 10i 0 overlay(qdfrprtaDS:1) D BytesAvail 10i 0 overlay(qdfrprtaDS:5) D PrintFileName 10a overlay(qdfrprtaDS:9) D Lib 10a overlay(qdfrprtaDS:19) D Device 10a overlay(qdfrprtaDS:29) D DeviceType 10a overlay(qdfrprtaDS:39) D PageSizeLen 15p 5 overlay(qdfrprtaDS:49) D PageSizeWidth 15p 5 overlay(qdfrprtaDS:57) D LPI 15p 5 overlay(qdfrprtaDS:77) D CPI 15p 5 overlay(qdfrprtaDS:85) D OverFlow 10i 0 overlay(qdfrprtaDS:93) D Text 50a overlay(qdfrprtaDS:98) D FMarginDown 15p 5 overlay(qdfrprtaDS:149) D FMarginAccros 15p 5 overlay(qdfrprtaDS:157) D PrintQuality 10a overlay(qdfrprtaDS:219) D FontIdentifier 10a overlay(qdfrprtaDS:249) D CharIdSet 10i 0 overlay(qdfrprtaDS:269) D CharIdCodePage 10i 0 overlay(qdfrprtaDS:273) D DecimalFormat 10a overlay(qdfrprtaDS:277) D PageRotation 10i 0 overlay(qdfrprtaDS:417) D PrtTxt 30a overlay(qdfrprtaDS:435) D PrintBothSides 10a overlay(qdfrprtaDS:469) D FrontOvlFile 8a overlay(qdfrprtaDS:490) D FrontOvlLib 10a overlay(qdfrprtaDS:498) D FrontOvlDown 15p 5 overlay(qdfrprtaDS:509) D FrontOvlAccros 15p 5 overlay(qdfrprtaDS:517) D BackOvlFile 10a overlay(qdfrprtaDS:525) D BackOvlLib 10a overlay(qdfrprtaDS:535) D BackOvlDown 15p 5 overlay(qdfrprtaDS:545) D BackOvlAccros 15p 5 overlay(qdfrprtaDS:553) DBackOvlConstant 1a overlay(qdfrprtaDS:561) D IPDSPASTHR 10a overlay(qdfrprtaDS:563) D UsrRscLiblOff 10i 0 overlay(qdfrprtaDS:573) D UsrRscLiblCnt 10i 0 overlay(qdfrprtaDS:577) D UsrRscLiblLen 10i 0 overlay(qdfrprtaDS:581) D FormType 10a overlay(qdfrprtaDS:688) D MaxRecords 10i 0 overlay(qdfrprtaDS:725) D Hold 1a overlay(qdfrprtaDS:743) D Save 1a overlay(qdfrprtaDS:744) D UsrDBCSdata 1a overlay(qdfrprtaDS:1066) D DBCSextension 1a overlay(qdfrprtaDS:1067) D UsrRscLiblEnt s 10a based(UsrRscLiblPtr) D UsrRscLiblPtr s * //--*ENTRY PARMS------------------------------------------- D p_JCRPATTRR PR extpgm('JCRPATTRR') D 10a D 20a D 10a D 20a D p_JCRPATTRR PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_CrtToLib 10a D p_LikePrtf 20a //--------------------------------------------------------- /free 1b if p_CrtToLib = '*SRCLIB '; p_CrtToLib = %subst(p_SrcFilQual:11:10); 1e endif; 1b if %subst(p_LikePrtf:1:10) = '*SRCMBR '; %subst(p_LikePrtf:1:10) = p_SrcMbr; 1e endif; 1b if %subst(p_LikePrtf:11:10) = '*SRCLIB '; %subst(p_LikePrtf:11:10) = %subst(p_SrcFilQual:11:10); 1e endif; callp QDFRPRTA( QDFRPRTAds: %size(QDFRPRTADS): 'PRTF0100': p_LikePrtf: ApiErrds); //--------------------------------------------------------- // User resource library list entries 1b if qdfrprtaDS.UsrRscLiblCnt = 0; UsrRscLibl = '*DEVD '; 1x else; UsrRscLiblPtr = %addr(qdfrprtaDS) + qdfrprtaDS.UsrRscLiblOff; 2b for xx = 1 to qdfrprtaDS.UsrRscLiblCnt; UsrRscLibl = %trimr(UsrRscLibl) + ' ' + UsrRscLiblEnt; UsrRscLiblPtr += qdfrprtaDS.UsrRscLiblLen; 2e endfor; 1e endif; IGCdata = '*NO '; 1b if qdfrprtaDS.UsrDBCSdata = '1'; IGCdata = '*YES'; 1e endif; IGCextension = '*NO '; 1b if qdfrprtaDS.DBCSextension = '1'; IGCextension = '*YES'; 1e endif; Hold = '*NO '; 1b if qdfrprtaDS.Hold = '1'; Hold = '*YES'; 1e endif; Save = '*NO '; 1b if qdfrprtaDS.Save = '1'; Save = '*YES'; 1e endif; // Degree 0=*DEVD but degree 360 = degree 0. Go figure. PageRotation = %char(qdfrprtaDS.PageRotation); 1b if qdfrprtaDS.PageRotation = 0; PageRotation = '*DEVD '; 1x elseif qdfrprtaDS.PageRotation = -1; PageRotation = '*COR '; 1x elseif qdfrprtaDS.PageRotation = -2; PageRotation = '*AUTO '; 1x elseif qdfrprtaDS.PageRotation = 360; PageRotation = '0'; 1e endif; 1b if qdfrprtaDS.CharIdSet = 0; Chrid = '*DEVD '; 1x elseif qdfrprtaDS.CharIdSet = -1; Chrid = '*SYSVAL '; 1x elseif qdfrprtaDS.CharIdSet = -2; Chrid = '*JOBCCSID '; 1x elseif qdfrprtaDS.CharIdSet = -3; Chrid = '*CHRIDCTL '; 1x else; CharIdSet = qdfrprtaDS.CharIdSet; CharIdCodePage = qdfrprtaDS.CharIdCodePage; Chrid = %char(CharIdSet) + ' ' + %char(CharIdCodePage); 1e endif; //--------------------------------------------------------- pageLen = qdfrprtaDS.PageSizeLen; pageWidth = qdfrprtaDS.PageSizeWidth; CPI = qdfrprtaDS.CPI; LPI = qdfrprtaDS.LPI; Overflow = qdfrprtaDS.OverFlow; 1b if QDFRPRTADS.FMARGINACCROS = -0000000002.00000; FrontMargin = '*DEVD '; 1x else; FMD = qdfrprtaDS.FMarginDown; FMA = qdfrprtaDS.FMarginAccros; FrontMargin = %char(fmd) + ' ' + %char(FMA); 1e endif; 1b if qdfrprtaDS.MaxRecords = 0; MaxRecords = '*NOMAX '; 1x else; MaxRecordsNum = qdfrprtaDS.MaxRecords; MaxRecords = %char(MaxRecordsNum); 1e endif; 1b if qdfrprtaDS.FrontOvlFile = '*NONE '; FrontOverlay = '*NONE '; 1x else; FrontOvlDown = qdfrprtaDS.FrontOvlDown; FrontOvlAccros = qdfrprtaDS.FrontOvlAccros; FrontOverlay = f_GetQual(qdfrprtaDS.FrontOvlFile + ' ' + qdfrprtaDS.FrontOvlLib) + ' ' + %char(FrontOvlDown) + ' ' + %char(FrontOvlAccros); 1e endif; 1b if %subst(qdfrprtaDS.BackOvlFile:1:1) = '*'; BackOverlay = qdfrprtaDS.BackOvlFile; 1x else; BackOvlDown = qdfrprtaDS.BackOvlDown; BackOvlAccros = qdfrprtaDS.BackOvlAccros; 2b if qdfrprtaDS.BackOvlConstant = '0'; BackConstant = '*NOCONSTANT'; 2x else; BackConstant = '*CONSTANT'; 2e endif; BackOverlay = f_GetQual(qdfrprtaDS.BackOvlFile + qdfrprtaDS.BackOvlLib) + ' ' + %char(BackOvlDown) + ' ' + %char(BackOvlAccros) + ' ' + BackConstant; 1e endif; //--------------------------------------------------------- // replace single quotes with '' Text = f_InStringQuote(qdfrprtaDS.Text: 50); PrtTxt = f_InStringQuote(qdfrprtaDS.PrtTxt: 30); //--------------------------------------------------------- // build create print file command string1 = f_BuildString('CRTPRTF FILE(&) SRCFILE(&) + DEV(&) DEVTYPE(&) IGCDTA(&) IGCEXNCHR(&) + PAGESIZE(& &) LPI(&) CPI(&) FRONTMGN(&) + OVRFLW(&) PAGRTT(&) TEXT(&Q&&Q) FONT(&) PRTQLTY(&) + PRTTXT(&Q&&Q) FRONTOVL(&) DUPLEX(&) DECFMT(&) + BACKOVL(&) IPDSPASTHR(&) FORMTYPE(&Q&&Q) + CHRID(&) SAVE(&) HOLD(&) USRRSCLIBL(&) MAXRCDS(&) ': f_GetQual(p_SrcMbr + p_CrtToLib): f_GetQual(p_SrcFilQual) : qdfrprtaDS.Device : qdfrprtaDS.DeviceType : IGCdata : IGCextension : %char(pageLen) : %char(pageWidth) : %char(LPI) : %char(CPI) : FrontMargin : %char(OverFlow) : PageRotation : Text : qdfrprtaDS.FontIdentifier : qdfrprtaDS.PrintQuality : PrtTxt : FrontOverlay : qdfrprtaDS.PrintBothSides : qdfrprtaDS.DecimalFormat : BackOverlay : qdfrprtaDS.IPDSPASTHR : qdfrprtaDS.FormType : Chrid : Save : Hold : UsrRscLibl : MaxRecords); //--------------------------------------------------------- 1b monitor; callp QCMDEXC(string1: %size(string1)); f_SndCompMsg('Print file ' +%trimr(p_SrcMbr) + ' in library ' + %trimr(p_CrtToLib) + ' compiled by JCRPATTR.'); 1x on-error *ALL; f_SndCompMsg('Print file ' +%trimr(p_SrcMbr) + ' in library ' + %trimr(p_CrtToLib) + ' compile FAILED.'); 1e endmon; *inlr = *on; return; /end-free //--------------------------------------------------------- // IBM represents quotes in quoted string with 2 quotes // 'This is a single quote '' in a string ' // If object text or print text have single quotes, // need to replace with two single quotes so // command processer will recognize as single quote. //--------------------------------------------------------- Pf_InStringQuote b Df_InStringQuote PI 100a D p_String 50a options(*varsize) D p_Len 3u 0 const D xx s 3u 0 D Quoted s 100a /free Quoted = %subst(p_String:1: p_Len); xx = %scan(qs: Quoted: 1); 1b dow xx <> 0; Quoted = %replace(qs+qs :Quoted: xx: 1); xx = %scan(qs: Quoted: xx + 2); 1e enddo; return Quoted; /end-free Pf_InStringQuote e ]]> v6r1 only //--------------------------------------------------------- // JCRPATTRV - Validity checking program for lib/file/member // Note this command uses a API that is found in v6 or greater. It is not in V5r4 //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRPATTRV PR extpgm('JCRPATTRV') D 10a D 20a D 10a D 20a D p_JCRPATTRV PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_CrtLib 10a D p_ObjQual 20a //--------------------------------------------------------- /free /IF DEFINED(*V6R1M0) /ELSE f_SndEscapeMsg('Sorry! APIs not available before V6R1. + See Help text.'); /ENDIF f_CheckMbr(p_SrcFilQual : p_SrcMbr); // check to see if Library selected for created object exists. 1b if p_CrtLib = '*SRCLIB '; p_CrtLib = %subst(p_SrcFilQual: 11: 10); 1e endif; f_CheckObj(p_CrtLib + '*LIBL ': '*LIB '); // check to see if print file attributes object exists. 1b if %subst(p_ObjQual : 1: 10) = '*SRCMBR '; %subst(p_ObjQual : 1: 10) = p_SrcMbr; 1e endif; 1b if %subst(p_ObjQual : 11: 10) = '*SRCLIB '; %subst(p_ObjQual : 11: 10) = %subst(p_SrcFilQual: 11: 10); 1e endif; f_CheckObj(p_ObjQual : '*FILE '); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRPRTF - Generate external print file from RPG4 Ospecs - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate External Print File') PARM KWD(RPGMBR) TYPE(*NAME) MIN(1) PROMPT('RPG4 source member:') PARM KWD(RPGSRCFIL) TYPE(RPGSRCFIL) PROMPT('Source file:') RPGSRCFIL: QUAL TYPE(*NAME) DFT(QRPGLESRC) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(PRTFMBR) TYPE(*NAME) MIN(1) PROMPT('DDS member to generate:') PARM KWD(PRTFSRCFIL) TYPE(PRTFSRCFIL) PROMPT('Source file:') PRTFSRCFIL: QUAL TYPE(*NAME) DFT(QDDSSRC) SPCVAL((QDDSSRC)) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(USEREFFLD) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*NO) VALUES(*YES *NO) PROMPT('Use REFFLD field references:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRPRTF'.Generate External Print File (JCRPRTF) - Help .*-------------------------------------------------------------------- :P.This JCR command generates DDS external print file source member from selected RPG4 (RPGLE or SQLRPGLE) program's O specs. :P.Please be aware of following special circumstances: :UL COMPACT.:LI.Multiple internal spooled files will be consolidated into single member :LI.Array elements will be converted but must be modified as these are not allowed in PRTF. :LI.If entire array name (not indexed) is used, it will be converted, but will require conversion to non-array name. :LI.Control indicators L0-L9 are converted but will have to be manually changed as they are not allowed in external print file. :LI.Duplicate fields within same record format must be manually changed after generation.:EUL. :P.The command gets name of RPG source member whose O specs are to used, the name and location where generated DDS print file member is supposed to go, and whether or not REFFLDs should be used in external print file. :NT.This command does not alter original RPG code in any way.:ENT. :NT.The command will create new DDS source member if one does not exist. If DDS member already exists, it will be overlaid with generated code.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRPRTF/RPGMBR'.RPG source member - Help :XH3.RPG source member(RPGMBR) :P.Program whose internal O specs will be used to generate external print file DDS source.:EHELP. :HELP name='JCRPRTF/RPGSRCFIL'.Source file - Help :XH3.Source file (RPGSRCFIL) :P.Source file containing source program member.:EHELP. :HELP name='JCRPRTF/PRTFMBR'.DDS member to generate - Help :XH3.DDS member to generate(PRTFMBR) :P.DDS member name of external print file that is be generated.:EHELP. :HELP name='JCRPRTF/PRTFSRCFIL'.Source file - Help :XH3.Source file (PRTFSRCFIL) :P.Source file that contains external print file member.:EHELP. :HELP name='JCRPRTF/USEREFFLD'.Use REFFLD field references - Help :XH3.Use REFFLD field references (USEREFFLD) :P.External print file to be generated using REFFLD or internal field descriptions. :PARML.:PT.:PK def.*NO:EPK.:PD.REFFLDs are not to used in external print file. :PT.*YES :PD.REFFLD definitions to be used where available.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRPRTFR - Generate external print file from RPG4 Ospecs // Interesting note: RPG o specs use record level spacing/skipping. O specs allow // same record name to be defined multiple times with different spacing and skipping. // DDS allows record format to be defined only once. This requires conversion from // record level definitions in RPG to field level spacing/skipping in DDS. Ughh. // SkipB and SpaceB will coded after first IPP line after IPO line. // SkipA and SpaceA will coded after last IPP line in IPO group. // call program to load field names & attributes into imported array // load output arrays with Positional field data and field names // Read RPG o specs, generate DDS PRTF source code //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC if f 112 disk extfile(extIfile) extmbr(p_RpgMbr) input source file F usropn FDDSSRC o a f 92 disk extfile(extOfile) extmbr(p_DDsMbr) write out DDS F usropn //--*STAND ALONE------------------------------------------- D KeywordSkipa s like(PrtfDDs.Keyword) D KeywordSkipb s like(PrtfDDs.Keyword) D KeywordSpacea s like(PrtfDDs.Keyword) D KeywordSpaceb s like(PrtfDDs.Keyword) D LinePosSav s like(PrtfDDs.LinePosition) D oooFMT s like(oConstant) D Commas s 1a D DDsSrcFile s 10a D DDsSrcLib s 10a D EditCodeArry s 1a dim(16) ctdata perrcd(1) D EditDataArry s 2a dim(16) alt(EditCodeArry) D Field s 15a D FloatDollar s 3a inz('''$''') D HaveFields s 27a D JustDidFmt s 27a D LastExceptName s 15a D LookupName s 15a D NegativeType s 1a D RpgSrcFile s 10a D RpgSrcLib s 10a D DimSizeA s 5a D WriteLine s 1a D vspos s 5i 0 D vswork s 5i 0 D DecimalPos s 1s 0 D SrcSeq s 6s 2 D CommaRemainder s 5u 0 D CommaResult s 5u 0 D DetailLineCnt s 5u 0 D ExceptLineCnt s 5u 0 D HeaderLineCnt s 5u 0 D jj s 5u 0 D kk s 5u 0 D LenActual s 5u 0 D NewEndingPos s 5u 0 D pe s 5u 0 D ps s 5u 0 D pStart s 5u 0 D TotalLineCnt s 5u 0 D xd s 5u 0 D xx s 5u 0 D yy s 5u 0 D IsWrite s n //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define Constants /Define FieldsAttrDS /Define f_BuildString /Define f_FakeEditWord /Define f_GetQual /Define f_SndCompMsg /Define f_SndEscapeMsg /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Define fields from different spec types. D ds inz D SrcDta 1 80a // OUTPUT SPECS D CompileArray 1 3a D SpecType 6 6a D Asterisk 7 7a D Commentln 8 80a D oAndOr 16 18a D oLineType 17 17a D oIndicator 21 29a D oSpaceB 42 42a D oSpaceA 45 45a D oSkipB 47 48a D oSkipA 50 51a D oEname 30 43a D oEditCode 44 44a D oEndPos 47 51a D oEndPosN 47 51s 0 D uppercase 1 51a D oConstant 53 80a // DDS SPECS D PrtfDDs ds qualified inz D SrcType 6 6a D oAndOr 7 7a D CommentLine 8 80a D Indicator 8 16a D FormatR 17 17a D FormatName 19 28a D Referenced 29 29a D Length 31 34a D DataType 35 35a D DecimalPos 37 37a D LinePosition 42 44a D Keyword 45 80a //--*ENTRY PARMS------------------------------------------- D p_JCRPRTFR PR extpgm('JCRPRTFR') D 10a D 20a D 10a D 20a D 4a D p_JCRPRTFR PI D p_RpgMbr 10a D p_RpgFileQual 20a D p_DDsMbr 10a D p_DDsFileQual 20a D p_RefFields 4a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 13 92 SrcDta //--------------------------------------------------------- /free RpgSrcFile = %subst(p_RpgFileQual: 1: 10); RpgSrcLib = %subst(p_RpgFileQual: 11: 10); DDsSrcFile = %subst(p_DDsFileQual: 1: 10); DDsSrcLib = %subst(p_DDsFileQual: 11: 10); extIfile = f_GetQual(p_RpgFileQual); extOfile = f_GetQual(p_DDsFileQual); // Get program field attributes // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_RpgFileQual: p_RpgMbr: DiagSeverity); 1b if DiagSeverity > '20'; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; //--------------------------------------------------------- // open input file and output open RPGSRC; open DDSSRC; read RPGSRC; 1b dow not %eof; 2b if CompileArray = '** ' or CompileArray = '**C' or CompileArray = '**c' or SpecType = 'P' //procedure or SpecType = 'p'; 1v leave; 2e endif; 2b if Asterisk <> '/' // Eject and (SpecType = 'O' or SpecType = 'o'); // If comment lines, then translate over as is. 3b if Asterisk = '*'; //COMMENT LINE PrtfDDs.oAndOr = Asterisk; //LOAD DS PrtfDDs.CommentLine = Commentln; //LOAD DS exsr srWriteSrcCode; 3x else; uppercase = %xlate(lo: up: uppercase); 4b if oLineType > *blanks and //IPO LINES D,E,H oAndOr <> 'OR ' and //IPO LINES D,E,H oAndOr <> 'AND'; //IPO LINES D,E,H exsr srFormatLine; 4x else; //FIELD/LITERAL exsr srFieldLine; 4e endif; 3e endif; 2e endif; *in01 = *off; *in03 = *off; read RPGSRC; 1e enddo; // all processed. exsr srSpaceAfter; close RPGSRC; close DDSSRC; f_SndCompMsg('JCRPRTF for ' + %trimr(p_DDsMbr) + ' in ' + %trimr(extOfile) + ' - completed.'); *inlr = *on; return; //--------------------------------------------------------- // Generate record format code for either except lines // or when new line is coded in original RPG. begsr srFormatLine; IsWrite = *on; // If previous record format had no printable fields // or constants defined, then generate space/skip // BEFORE code at record format level. 1b if HaveFields = 'Record Format had no fields'; exsr srSpaceBefore; 1e endif; exsr srSpaceAfter; 1b if oLineType = 'E'; //EXCPT 2b if oEname > *blanks and oEname = LastExceptName; //SAME NAMED LINE IsWrite = *off; 2x else; 3b if oEname = *blanks; ExceptLineCnt += 1; oEname = %trimr('EXP') + %triml(%editc(ExceptLineCnt:'3')); 3e endif; PrtfDDs.FormatName = oEname; LastExceptName = oEname; 2e endif; 1x elseif oLineType = 'H'; //HEADER LINE HeaderLineCnt += 1; //HEADER LINE CNT PrtfDDs.FormatName = %trimr('HDR') + %triml(%editc(HeaderLineCnt:'3')); clear LastExceptName; 1x elseif oLineType = 'D'; //DETAIL DetailLineCnt += 1; PrtfDDs.FormatName = %trimr('DTL') + %triml(%editc(DetailLineCnt:'3')); clear LastExceptName; 1x elseif oLineType = 'T'; //TOTAL TotalLineCnt += 1; PrtfDDs.FormatName = %trimr('TOT') + %triml(%editc(TotalLineCnt:'3')); clear LastExceptName; 1e endif; 1b if IsWrite; PrtfDDs.FormatR = 'R'; exsr srWriteSrcCode; 1e endif; //--------------------------------------------------------- // Space or Skip before must after first field // (or constant) defined after record format record. // They are saved for after first field in rcdfmt. 1b if oSpaceB > ' '; //SPACE BEFORE KeywordSpaceb = %trimr('SPACEB(') + oSpaceB+')'; 1e endif; 1b if oSkipB > ' '; //SKIP BEFORE KeywordSkipb = %trimr('SKIPB(') + oSkipB + ')'; 1e endif; //--------------------------------------------------------- // Space or Skip after must go at end of each group. // Checked at beginning of each record format. 1b if oSpaceA > ' '; //SPACE AFTER KeywordSpacea = %trimr('SPACEA(') + oSpaceA+')'; 1e endif; 1b if oSkipA > ' '; //SKIP AFTER KeywordSkipa = %trimr('SKIPA(') + oSkipA+')'; 1e endif; vspos = 0; HaveFields = 'Record Format had no fields'; JustDidFmt = 'Just did record format '; endsr; //--------------------------------------------------------- // Generate Skip or Space before DDs code. begsr srSpaceBefore; 1b if KeywordSpaceb > *blanks; //SPACE BEFORE PrtfDDs.Keyword = KeywordSpaceb; exsr srWriteSrcCode; 1e endif; 1b if KeywordSkipb > *blanks; //SKIP BEFORE PrtfDDs.Keyword = KeywordSkipb; exsr srWriteSrcCode; 1e endif; clear KeywordSpaceb; clear KeywordSkipb; endsr; //--------------------------------------------------------- // Generate Skip or Space after DDs code. begsr srSpaceAfter; 1b if KeywordSpacea > *blanks; //SPACE AFTER PrtfDDs.Keyword = KeywordSpacea; exsr srWriteSrcCode; 1e endif; 1b if KeywordSkipa > *blanks; //SKIP AFTER PrtfDDs.Keyword = KeywordSkipa; exsr srWriteSrcCode; 1e endif; clear KeywordSpacea; clear KeywordSkipa; endsr; //--------------------------------------------------------- // Determine whether field name or constant is to be loaded. begsr srFieldLine; //IPP SPECS LenActual = 0; HaveFields = 'Record Format has fields '; 1b if oEname > *blanks; //FIELD NAMES WriteLine = 'N'; //SET TO NO Field = oEname; // There could be indexed array name as output field. // Do lookup with array name to get attributes. LookupName = oEname; aa = %scan('(': LookupName: 1); 2b if aa <> 0; LookupName = %subst(LookupName: 1: aa - 1); 2e endif; aa = %lookup(LookupName: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 2b if aa > 0; FieldsAttrDS = FieldsAttrArry(aa); 3b if FieldsAttrDS.DecimalPos = *blanks; DecimalPos = 0; 3x else; DecimalPos = FieldsAttrDS.DecimalPosN; 3e endif; PrtfDDs.FormatName = oEname; //--------------------------------------------------------- // Back to array fun! It could be that // that un-indexed array name was coded on output. // JCRGETFLDR program loads array definitions // in two parts. Multiply element length by num elements. ps = %scan('DIM(': FieldsAttrDS.Text: 1); 3b if ps <> 0 //start of DIM( and LookupName = oEname; //not indexed pe = %scan(')': FieldsAttrDS.Text: ps); 4b if pe <> 0; //end of ) xd = (pe - 1) - 4; pStart = 6 - xd; DimSizeA = *blanks; %subst(dimsizea: pStart: xd) = %subst(FieldsAttrDS.Text: 5: xd); 5b if DimSizeA = *blanks; DimSizeA = '00000'; 5e endif; FieldsAttrDS.Length = FieldsAttrDS.Length * %uns(DimSizeA); 4e endif; 3e endif; PrtfDDs.Indicator = oIndicator; //--------------------------------------------------------- // If field was defined via external file definition and // user specified that field references should be used, // use REFFLD keyword, otherwise hardcode actual field // characteristics. 3b if FieldsAttrDS.FromFile <> ' ' and //INTERNALLY DESC p_RefFields = '*YES'; //USE REFERENCES PrtfDDs.Referenced = 'R'; PrtfDDs.Keyword = 'REFFLD(' + %trimr(PrtfDDs.FormatName) + ' *LIBL/' + %trimr(FieldsAttrDS.FromFile) + ')'; 3x else; // Hard code fields that are not referenced. 4b if FieldsAttrDS.DataType = 'A'; evalr PrtfDDs.Length = %editc(FieldsAttrDS.Length:'4'); clear PrtfDDs.DataType; clear PrtfDDs.DecimalPos; 4x elseif FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; clear PrtfDDs.Length; 5b if FieldsAttrDS.DataType = 'D'; PrtfDDs.DataType = 'L'; 5x else; PrtfDDs.DataType = FieldsAttrDS.DataType; 5e endif; clear PrtfDDs.DecimalPos; 4x else; evalr PrtfDDs.Length = %editc(FieldsAttrDS.Length:'4'); clear PrtfDDs.DataType; PrtfDDs.DecimalPos = %editc(DecimalPos:'3'); 4e endif; WriteLine = 'Y'; 3e endif; 2e endif; // Calculate starting Position of either field or constant. LenActual = FieldsAttrDS.Length; 2b if oEditCode > ' '; exsr srAllowForEditCode; 2x elseif oConstant > *blanks; //GET CONST LENGT 3b if FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; exsr srMakeLikeAnEditWord; 3e endif; kk = %checkr(' ': oConstant); LenActual = kk - 2; //CALC LENGTH 2e endif; exsr srBlankOrPlusSign; vswork = vswork - LenActual; vswork += 1; evalr PrtfDDs.LinePosition = %editc(vswork:'4'); // Handle exception of UDATE. Entire line is cleared and // starting Position and new DATE keyword are written. 2b if PrtfDDs.FormatName = 'UDATE '; LinePosSav = PrtfDDs.LinePosition; WriteLine = 'N'; clear PrtfDDs; PrtfDDs.LinePosition = LinePosSav; PrtfDDs.Keyword = 'DATE'; 2e endif; 2b if WriteLine <> 'Y'; exsr srWriteSrcCode; 2e endif; // If floating dollar sign, include in EDTCDE keyword) 2b if oEditCode > ' '; PrtfDDs.Keyword = 'EDTCDE(' + oEditCode + ')'; 3b if oConstant = FloatDollar; PrtfDDs.Keyword = 'EDTCDE(' + oEditCode + ' $)'; 3e endif; exsr srWriteSrcCode; clear WriteLine; 2x elseif oConstant > *blanks; //EDTWRD SPECIFID 3b if FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; PrtfDDs.Keyword = oooFMT; 3x else; PrtfDDs.Keyword = 'EDTWRD(' + %trimr(oConstant) + ')'; 3e endif; exsr srWriteSrcCode; clear WriteLine; 2e endif; 2b if WriteLine = 'Y'; exsr srWriteSrcCode; 2e endif; 1x elseif oConstant > *blanks; //CONSTANTS jj = %checkr(' ': oConstant); PrtfDDs.Indicator = oIndicator; exsr srBlankOrPlusSign; vswork -= jj; vswork += 3; evalr PrtfDDs.LinePosition = %editc(vswork:'4'); //LOAD FLD LENGTH PrtfDDs.Keyword = oConstant; //LOAD CONSTANT exsr srWriteSrcCode; 1e endif; 1b if JustDidFmt = 'Just did record format '; exsr srSpaceBefore; JustDidFmt = 'Not '; 1e endif; endsr; //--------------------------------------------------------- // If ending Position is blank, load +0 and let // the calc ending subroutine handle it . if there // is + sign in end position, then calc ending pos. begsr srBlankOrPlusSign; 1b if oEndPos = *blanks; oEndPos = ' +0'; 1e endif; bb = %scan('+': oEndPos: 1); 1b if bb <> 0; //load zeros into any spaces between + and value, ie + 1 = +0001 2b for yy = bb to 5; 3b if %subst(oEndPos: yy: 1) = ' '; %subst(oEndPos: yy: 1) = '0'; 3e endif; 2e endfor; // Calculate ending positions yy = 2; xx = 0; 2b if oEname <> ' ' and %subst(oConstant: 1: 1) <> ' ' and oConstant <> FloatDollar; 3b dow %subst(oConstant: yy: 1) <> ''''; xx += 1; yy += 1; 3e enddo; 2x elseif oEname = ' ' and %subst(oConstant: 1: 1) <> ' '; 3b dow yy < 29 and %subst(oConstant: yy: 1) <> ''''; xx += 1; yy += 1; 3e enddo; 2e endif; NewEndingPos = vspos + %uns(%subst(oEndPos: bb + 1)) + xx; 2b if xx = 0; //no edit word NewEndingPos += LenActual; 2e endif; oEndPosN = NewEndingPos; 1e endif; vspos = oEndPosN; vswork = vspos; endsr; //--------------------------------------------------------- // New to O specs is ability to format date, time and and timestamp fields. I decided // best way to handle it would be to create fake edit word based on type field and // formatting selected. begsr srMakeLikeAnEditWord; clear oooFMT; 1b if FieldsAttrDS.DataType = 'Z'; 1x else; oConstant = %xlate(lo: up: oConstant); 2b if FieldsAttrDS.DataType = 'T'; oooFMT = 'TIMFMT(' + %trimr(oConstant) + ')'; 2x elseif FieldsAttrDS.DataType = 'D'; oooFMT = 'DATFMT(' + %trimr(oConstant) + ')'; 2e endif; 1e endif; oConstant = f_FakeEditWord(oConstant: FieldsAttrDS.DataType); endsr; //--------------------------------------------------------- // Allow for effects of edit codes on overall field length. begsr srAllowForEditCode; 1b if oEditCode = 'Y'; 2b if FieldsAttrDS.Length = 3 or FieldsAttrDS.Length = 4; LenActual += 1; 2x elseif FieldsAttrDS.Length >= 5 and FieldsAttrDS.Length <= 9; LenActual += 2; 2e endif; 1x else; jj = %lookup(oEditCode: EditCodeArry: 1); 2b if jj > 0; Commas = %subst(EditDataArry(jj): 1: 1); //USE COMMAS? NegativeType = %subst(EditDataArry(jj): 2: 1); //WHAT TYPE NEG 3b if oConstant = FloatDollar; //FLOATING $ LenActual += 1; 3e endif; 3b if DecimalPos > 0; //ADJUST FOR DEC LenActual += 1; 3e endif; 3b if NegativeType = '-'; //MINUS SIGN LenActual += 1; 3x elseif NegativeType = 'C'; //CR SIGN LenActual += 2; 3e endif; 3b if Commas = 'Y'; //ALLOW FOR COMMA CommaResult = FieldsAttrDS.Length - DecimalPos; CommaResult = %div(CommaResult: 3); //HOW MANY COMMAS CommaRemainder = %rem(CommaResult: 3); //HOW MANY COMMAS 4b if CommaRemainder = 0 and CommaResult > 0; //EVENLY DIVIDED CommaResult -= 1; 4e endif; LenActual += CommaResult; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Write records to DDS member. begsr srWriteSrcCode; PrtfDDs.SrcType = 'A'; SrcSeq += .01; except DDsout; //WRITE DDs clear PrtfDDs; endsr; /end-free ODDSSRC eadd DDsout O SrcSeq 6 O PrtfDDs 92 *EDIT CODE COMMAS (Y/N) TYPE SIGN(None,Cr,or -) ** 1YN 1 2YN 2 3NN 3 4NN 4 AYC 5 BYC 6 CNC 7 DNC 8 JY- 9 KY- 10 LN- 11 MN- 12 NY- 13 OY- 14 PN- 15 QN- 16 ]]> v5r4 //--------------------------------------------------------- // JCRPRTFRV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /Define f_IsValidMbrType /Define f_OutFileAddPfm /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRPRTFRV PR extpgm('JCRPRTFRV') D 10a D 20a D 10a D 20a D 4a D p_JCRPRTFRV PI D p_RpgMbr 10a D p_RpgFileQual 20a D p_DDsMbr 10a D p_DDsFileQual 20a D p_RefFields 4a //--------------------------------------------------------- /free 1b if not f_IsValidMbrType(p_RpgFileQual: p_RpgMbr: 'RPGLE ': 'SQLRPGLE '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(p_RpgMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; f_CheckObj(p_DDsFileQual : '*FILE '); f_OutFileAddPfm(p_DDsFileQual: p_DDsMbr: 'PRTF ': 'PRTF for ' + p_RpgMbr); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRQJOBD - Find jobds using selected jobq - CMD */ /* http://www.recursos-as400.com/ */ /* mailto:mrierab@teleline.es */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find Job Queue on Jobd') PARM KWD(JOBQ) TYPE(JOBQ) MIN(1) PROMPT('Job Queue on JOBD:') JOBQ: QUAL TYPE(*NAME) LEN(10) MIN(1) EXPR(*YES) QUAL TYPE(*NAME) LEN(10) MIN(1) EXPR(*YES) PROMPT('Library Name:') PARM KWD(OBJTYP) TYPE(*CHAR) CONSTANT('*JOBQ ') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) MIN(0) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRQJOBD'.Find JOBDS using selected JOBQ (JCRQJOBD) - Help .*-------------------------------------------------------------------- :P.The Find Job Descriptions using selected Job Queue (JCRQJOBD) command generates report listing showing which jobds have selected jobq. :P.End result is spooled file listing all JOBDs that use selected library. Also available is the option to display generated spooled file.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRQJOBD/JOBQ'.JOBQ (JCRQJOBD) - Help :XH3.Job Queue Entry (JOBQ) :P.Jobq to check for in JOBDs.:EHELP. :HELP name='JCRQJOBD/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print or display list of jobds.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRQJOBDP - Find jobds using selected jobq - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRQJOBD' A 20'Find JOBDS Using a Selected Jobq' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 1'JOBQ:' A P_JOBQQUAL 20A O 8SPACEA(2) *--- A 1'Jobd' A 13'Library' A +8'Text' A +2'----------------------------------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A OBJNAM 10A O 1 A OBJLIB 10A O 13 A OBJTEXT 40A O +5 ]]> v5r4 //--------------------------------------------------------- // JCRQJOBDR - find JOBD using selected JOBQ //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRQJOBDP o e printer oflind(*in99) usropn //--*STAND ALONE------------------------------------------- D UserID s 10a inz(*user) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Quslobj /Define Qwdrjobd /Define UserSpaceHeaderDS /Define f_Quscrtus /Define f_SndStatMsg /Define f_GetQual /Define f_GetDayName /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // extract jobq info from API return variable D ReceiverVar ds 1000 D JobQueue 20a overlay(ReceiverVar:55) //--*ENTRY PARMS------------------------------------------- D p_JCRQJOBDR PR extpgm('JCRQJOBDR') D 20a D 10a const D 8a D p_JCRQJOBDR PI D p_JobqQual 20a D p_Objtype 10a const D p_Output 8a //--------------------------------------------------------- /free // Send status message f_SndStatMsg('Search for job descriptions using ' + %trimr(f_GetQual(p_JobqQual)) + ' - in progress'); // open spooled file, write headings open JCRQJOBDP; evalr scDow = %trimr(f_GetDayName()); write PrtHead; // call API to load object names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0200': '*ALL *ALL ': '*JOBD': ApiErrDS); // Spin through user space. call API then extract libraries QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; callp QWDRJOBD( ReceiverVar: %size(ReceiverVar): 'JOBD0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); 2b if p_JobqQual = JobQueue; ObjNam = QuslobjDS.ObjNam; ObjLib = QuslobjDS.ObjLib; ObjText = QuslobjDS.ObjText; write PrtDetail; 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; close JCRQJOBDP; f_DspLastSplf('JCRQJOBDR ': p_Output); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRRECRT - Recreate *CMD using existing values - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Recreate Command') PARM KWD(CMD) TYPE(CMD) MIN(1) PROMPT('Command:') CMD: QUAL TYPE(*SNAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) CONSTANT('*CMD ') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRRECRT'.Recreate Command (JCRRECRT) - Help .*-------------------------------------------------------------------- :P.This JCR command uses system API to retrieve orignal creation parameters of selected command. You are presented CRTCMD (Create Command) prompt with creation parameters already filled by original values.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRRECRT/CMD'.CMD - Help :XH3.CMD (CMD) :P.Name and library of command to be selected.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRRECRTR - Recreate *CMD using existing values // Execute function to return command recreation string // Prompt CRTCMD command using QCAPCMD command processor API. // This API does some neat stuff like return user changes to program // but its complexity far outweighs any advantages over system or QCMDEXEC //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_CrtCmdString /Define f_GetQual /Define f_RtvMsgAPI /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D CompMsg s 73a D LimitUser s 10a inz('YES ') D String s 500a D ChangedSrc s 500a D ChangedLen s 10i 0 D Replacement s 112a D ReplaceLib s 10a D xx s 3u 0 D yy s 3u 0 //--*CALL PROTOTYPES--------------------------------------- D QCAPCMD PR extpgm('QCAPCMD') process commands Db 500a source command D 10i 0 const length of source Db like(cpop0100DS) options block D 10i 0 const options block len D 8a const options format Db 500a changed command D 10i 0 const length available D 10i 0 length of changed Db like(ApiErrDS) D cpop0100DS ds qualified D TypeProcess 10i 0 overlay(cpop0100DS:1) inz(0) command running D DBCShandling 1a overlay(cpop0100DS:5) inz('0') ignore D PrompterAct 1a overlay(cpop0100DS:6) inz('2') prompt if ? D CmdSyntax 1a overlay(cpop0100DS:7) inz('0') use system syntax D MessageKey 4a overlay(cpop0100DS:8) request message D inz(x'00000000') D Ccsid 10i 0 overlay(cpop0100DS:12) inz(0) D Reserved 5a overlay(cpop0100DS:16) D inz(x'0000000000') //--*ENTRY PARMS------------------------------------------- D p_JCRRECRTR PR extpgm('JCRRECRTR') D 20a D 10a D p_JCRRECRTR PI D p_CmdQual 20a D p_ObjType 10a //--------------------------------------------------------- /free // Extract command definitions String = f_CrtCmdString(p_CmdQual); // execute command processing API callp QCAPCMD( String: %len(String): cpop0100DS: %len(cpop0100ds): 'CPOP0100': ChangedSrc: %size(ChangedSrc): ChangedLen: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; 2b if ApiErrDS.ErrMsgId = 'CPF6801'; //f3 or f12 pressed Replacement = %subst(ApierrDS.MsgReplaceVal:1:3); 2x else; // extract actual library name xx = %scan('CMD(': String); yy = %scan('/':String: xx + 4); ReplaceLib = %subst(String: xx + 4: (yy-(xx + 4))); Replacement = %subst(p_CmdQual:1:10) + ReplaceLib; 2e endif; CompMsg = ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: Replacement); 1x else; CompMsg = 'JCRRECRT for command ' + %trimr(%subst(p_CmdQual:1:10)) + ' - completed'; 1e endif; f_SndCompMsg(CompMsg); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRRFIL - Record format/file xref for RPG source - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Record Format / File Name Xref') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PROMPT('RPG program name:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(0) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') ]]> v5r4 *---------------------------------------------------------------- * JCRRFILD - Record format/file xref for RPG source - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA A CA03 CA05 CA07 CA08 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A HIDRCDFMT 10A H A SBFOPTION 1Y 0B 5 2EDTCDE(4) A SCRFILENAM 10A O 5 4 A SCRRCDFMT 10A O 5 15 A SCRBASEDPF 10A O 5 26 A SCRRENAMED 10A O 5 37 A SCRUSAGE 1A O 5 48 A SCRRECTEXT 29A O 5 50 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) BLINK OVERLAY A SFLPAG(17) SFLSIZ(119) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRRFIL' COLOR(BLU) A 1 23'Record Format / File Name Xref' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 64 O 2 7 A 2 72SYSNAME COLOR(BLU) A SCHEADOPT 65A O 3 2COLOR(BLU) A 4 4'File' DSPATR(HI) A COLHEAD08 7A O 4 15DSPATR(HI) A 4 26'PF' DSPATR(HI) A 4 37'Renamed' DSPATR(HI) A 4 47'Use' DSPATR(HI) A 4 51'Text' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 23 2'F3=Exit' COLOR(BLU) * 23 15'F5=Refresh' COLOR(BLU) A FOOTMSG07 16A O 23 30COLOR(BLU) A FOOTMSG08 15A O 23 50COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRRFIL'.Record Format / File Name Xref (JCRRFIL) - Help .*-------------------------------------------------------------------- :P.This JCR command reads the F specs in your source. It works through all Rename, Include, and Ignore logic, then displays subfile listing of File names, Record format names, Renames, and Based-on physicals of all Files / Record Formats used in RPG3 or 4 program.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRRFIL/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Program for which record formats to be displayed.:EHELP. :HELP name='JCRRFIL/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRRFILR - Record format/file xref for RPG source //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRRFILD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) FRPGSRC if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn //--*STAND ALONE------------------------------------------- D FormatIncludeOrIgnore... D s 10a dim(32) D CountIncExc s 3u 0 D CountRename s 3u 0 D ForCount s 10i 0 D FileNameSave s 10a D FileHowUsed s 1a D RenamedFmt s 10a dim(32) D BeingRenamed s 10a dim(32) D WorkFileQual s 20a D BitOffset s 10u 0 inz(2) D xx s 5u 0 D EndParenthesis s 5u 0 D CurrentColon s 5u 0 D yy s 5u 0 D IsLeave s n D IsProcess s n D IsIgnore s n D IsInclude s n D IsCloseParenth s n D IsLF s n D IsRPG4 s n D FileExt s 10a D LibExt s 10a D RenameSave s 10a D QuoteStart s 3u 0 D QuoteEnd s 3u 0 D ContinuationString... D s 2048a varying D IsToggle07 s n inz(*off) D IsToggle08 s n inz(*off) D dbUtility s 8a //--*DATA STRUCTURES--------------------------------------- // Define arrays for file information D DS D FileDataDS 80a dim(300) D aFileName 10a overlay(FileDataDS:1) D aLibName 10a overlay(FileDataDS:*next) D aFormatName 10a overlay(FileDataDS:*next) D aFormatReName 10a overlay(FileDataDS:*next) D aBasedOnPF 10a overlay(FileDataDS:*next) D aHowUsed 1a overlay(FileDataDS:*next) D aFileText 29a overlay(FileDataDS:*next) //--*COPY DEFINES------------------------------------------ /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define f_BuildString /Define f_RunOptionFile /Define f_GetFileUtil /Define f_GetQual /Define f_GetDayName /Define f_Qusrmbrd /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndSflMsg /Define ApiErrDS /Define Constants /Define SrcDS /Define Qdbrtvfd /Define Fild0100ds /Define Tstbts /Define f_Quscrtus /Define f_Qusrobjd /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRRFILR PR extpgm('JCRRFILR') D 10a D 20a D p_JCRRFILR PI D p_SrcMbr 10a D p_SrcFilQual 20a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 112 SrcDS /free Fild0100ptr = %alloc(1); // so realloc will work evalr scDow = %trimr(f_GetDayName()); FootMsg07 = 'F7=Sort By Rcdmt'; FootMsg08 = 'F8=Show Library'; ColHead08 = 'RcdFmt '; QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; extIfile = f_GetQual(p_SrcFilQual); IsRPG4 = (QusrmbrdDS.MbrType = 'RPGLE ' or QusrmbrdDS.MbrType = 'SQLRPGLE '); scObjHead = f_BuildString('& & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); //--------------------------------------------------------- open RPGSRC; read RPGSRC; 1b dow not %eof; exsr srOnlyFspecs; 2b if IsLeave; 1v leave; 2e endif; //--------------------------------------------------------- // load fields from f spec externally described fields. 2b if IsProcess; clear RenamedFmt; 3b if not IsRPG4; // RPG3 SrcDS.fUsage = SrcDS.fUsage3; SrcDS.fDevice = SrcDS.fDevice3; SrcDS.fEorF = SrcDS.fEorF3; SrcDS.fFileName = SrcDS.fFileName3; 3e endif; //--------------------------------------------------------- 3b if SrcDS.fFileName > *blanks and SrcDS.fEorF = 'E' and SrcDS.fDevice = 'DISK '; FileNameSave = SrcDS.fFileName; FileHowUsed = SrcDS.fUsage; FileExt = *blanks; LibExt = '*LIBL '; CountRename = 0; FormatIncludeOrIgnore(*) = *blanks; CountIncExc = 0; IsIgnore = *off; IsInclude = *off; RenamedFmt(*) = *blanks; BeingRenamed(*) = *blanks; //--------------------------------------------------------- // The joy here is renames and ignores may be on multiple // lines. Spin down and get all keywords // (or multiple keywords) from each before the next file. //--------------------------------------------------------- 4b dou IsLeave; 5b if IsRPG4; 6b if IsProcess and SrcDS.dKeyWord > *blanks; exsr srLoadExtFile; exsr srLoadRenamed; exsr srLoadIncludeOrIgnore; 6e endif; 5x else; // RPG3 6b if SrcDS.fKeyWord3 = 'KRENAME'; CountRename += 1; BeingRenamed(CountRename) = SrcDS.fBeingRenamed3; RenamedFmt(CountRename) = SrcDS.fRenamed3; 6x elseif SrcDS.fKeyWord3 = 'KIGNORE'; IsIgnore = *on; CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = SrcDS.fBeingRenamed3; 6e endif; 5e endif; read RPGSRC; exsr srOnlyFspecs; 5b if IsLeave or (IsProcess and SrcDS.fFileName3 > *blanks); readp RPGSRC; // reposition 4v leave; 5e endif; 4e enddo; exsr srLoadFileData; 3e endif; 2e endif; read RPGSRC; 1e enddo; close RPGSRC; dealloc Fild0100ptr; f_RmvSflMsg(ProgId); exsr srViewSubfile; f_SndCompMsg(f_BuildString('JCRRFIL for & in & - completed.': p_SrcMbr: f_GetQual(p_SrcFilQual))); *inlr = *on; return; //--------------------------------------------------------- // Check to see if read loop should be left or if record should be processed begsr srOnlyFspecs; IsLeave = *off; IsProcess = *off; SrcDS = %xlate(lo: up: SrcDS); // finished with F specs 1b if SrcDS.SpecType = 'C' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'O' or SrcDS.SpecType = 'P' or SrcDS.SlashComment = '/F' // /free or SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c'; IsLeave = *on; 1x elseif SrcDS.SpecType = 'F' and not (SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/'); IsProcess = *on; 1e endif; endsr; //--------------------------------------------------------- // load fields from files begsr srLoadFileData; WorkFileQual = FileNameSave + LibExt; AllocateSize = f_GetAllocSize01(WorkFileQual: '*FIRST '); 1b if ApiErrDS.BytesReturned > 0; yy += 1; aFileName(yy) = FileNameSave; aLibName(yy) = *all'*'; aFormatName(yy) = *all'*'; aFormatReName(yy) = *all'*'; aBasedOnPF(yy) = '*NOT FOUND'; aHowUsed(yy) = *blanks; aFileText(yy) = '*FILE NOT FOUND'; 1x else; Fild0100ptr = %realloc(Fild0100ptr: AllocateSize); callp QDBRTVFD( Fild0100ds : AllocateSize : ReturnFileQual: 'FILD0100' : WorkFileQual: '*FIRST ': '0' : '*LCL ': '*EXT ': ApiErrDS); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; IsLF = tstbts(Fild0100ds.TypeBits: BitOffset) = 1; //--------------------------------------------------------- // Process record formats 2b for ForCount = 1 to Fild0100ds.NumOfBasedPf; RenameSave = *blanks; // apply all includes/ignores and renames 3b if CountRename > 0; aa = %LookUp(FileScopeArry.RcdFmt: BeingRenamed: 1: CountRename); 4b if aa> 0; RenameSave = RenamedFmt(aa); 4e endif; 3e endif; IsProcess = *on; 3b if CountIncExc > 0; aa = %LookUp(FileScopeArry.RcdFmt: FormatIncludeOrIgnore: 1: CountIncExc); 4b if IsInclude and aa = 0; IsProcess = *off; 4e endif; 4b if IsIgnore and aa > 0; IsProcess = *off; 4e endif; 3e endif; 3b if IsProcess; yy += 1; aFileName(yy) = FileNameSave; aLibName(yy) = %subst(ReturnFileQual: 11: 10); aFormatName(yy) = FileScopeArry.RcdFmt; aFormatRename(yy) = RenameSave; aHowUsed(yy) = FileHowUsed; 4b if IsLF; aBasedOnPF(yy) = FileScopeArry.BasedOnPf; QusrObjDS = f_QUSROBJD(FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib: '*FILE '); aFileText(yy) = QusrObjDS.Text; 4x else; aBasedOnPF(yy) = *blanks; aFileText(yy) = Fild0100ds.FileText; 4e endif; 3e endif; fscopePtr += 160; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // extract extfile( or extdesc( values from RPG4 code // 1) Ignore extfile(*extdesc), will get those looking for extdesc( // 2) only process extfile(' that have a tic mark after the (. // 3) extract library name (if given) and file name. //--------------------------------------------------------- begsr srLoadExtFile; bb = %scan('EXTFILE(': SrcDS.dKeyWord); 1b if bb > 0; 2b if %subst(SrcDS.dKeyWord: bb+8: 1) = qs; exsr srExtractExtFileandLib; 2e endif; 1e endif; bb = %scan('EXTDESC(': SrcDS.dKeyWord); 1b if bb > 0; 2b if %subst(SrcDS.dKeyWord: bb+8: 1) = qs; exsr srExtractExtFileandLib; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srExtractExtFileandLib; FileExt = *blanks; LibExt = '*LIBL '; QuoteStart = bb+8; QuoteEnd = %scan(qs: SrcDS.dKeyWord : QuoteStart + 1); bb = %scan('/': SrcDS.dKeyWord : QuoteStart + 1); 1b if bb = 0; // no library FileExt = %subst(SrcDS.dKeyWord: QuoteStart + 1: (QuoteEnd-QuoteStart)-1); 1x else; LibExt = %subst(SrcDS.dKeyWord: QuoteStart+1: (bb-QuoteStart)-1); FileExt = %subst(SrcDS.dKeyWord: bb + 1: (QuoteEnd-bb)-1); 2b if LibExt = 'QTEMP '; LibExt = '*LIBL '; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // extract RENAME values from RPG4 code. //--------------------------------------------------------- begsr srLoadRenamed; bb = %scan('RENAME(': SrcDS.dKeyWord); 1b if bb > 0; exsr SrBuildContinuationString; bb = %scan('RENAME(': ContinuationString); CountRename += 1; aa = %scan(':': ContinuationString: bb); BeingRenamed(CountRename) = %triml(%subst(ContinuationString: bb + 7: aa - (bb + 7))); bb = %scan(')': ContinuationString: aa); RenamedFmt(CountRename) = %triml(%subst(ContinuationString: aa + 1: (bb - aa) - 1)); 1e endif; endsr; //--------------------------------------------------------- // Check if record formats should be IGNORED from this file. // Note : multiple formats could be in one statement separated by : . // Idea here is extract all formats that are included/ignored and return // them in array of record formats. //--------------------------------------------------------- begsr srLoadIncludeOrIgnore; 1b if %scan('IGNORE(': SrcDS.dKeyWord) > 0; IsIgnore = *on; 1x elseif %scan('INCLUDE(': SrcDS.dKeyWord) > 0; IsInclude = *on; 1e endif; // You could also have rename(a:b) ingore(ccc) on a single line. // Look for INCLUDE or IGNORE (could be in string many times) // IGNORE(A) IGNORE(b:c) //--------------------------------------------------------- 1b if %scan('IGNORE(': SrcDS.dKeyWord) > 0 or %scan('INCLUDE(': SrcDS.dKeyWord) > 0; exsr SrBuildContinuationString; 2b if IsIgnore; xx = %scan('IGNORE(': ContinuationString); 3b dow xx > 0; xx += 7; exsr srExtractNames; xx = %scan('IGNORE(': ContinuationString:xx); 3e enddo; 2e endif; 2b if IsInclude; xx = %scan('INCLUDE(': ContinuationString); 3b dow xx > 0; xx += 8; exsr srExtractNames; xx = %scan('INCLUDE(': ContinuationString:xx+1); 3e enddo; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // So look for end parenthesis, process between parenthesis, then check for more //--------------------------------------------------------- begsr srExtractNames; EndParenthesis = %scan(')': ContinuationString: xx); //---------------------------------------------- // xx = after ( of ignore( or include(. // The idea is only process this keyword to ) //---------------------------------------------- CurrentColon = xx; CurrentColon = %scan(':': ContinuationString: CurrentColon + 1); 1b if CurrentColon = 0 or CurrentColon > EndParenthesis; //(singlename) CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(ContinuationString: xx: EndParenthesis - xx)); 1x else; // tiptoe through the colon(s) (a :b:c) etc... 2b dou CurrentColon = 0 or CurrentColon > EndParenthesis; CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(ContinuationString: xx: CurrentColon - xx)); xx = CurrentColon + 1; CurrentColon = %scan(':': ContinuationString: xx); 3b if CurrentColon = 0 or CurrentColon > EndParenthesis; CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(ContinuationString: xx: EndParenthesis - xx)); 2v leave; 3e endif; 2e enddo; 1e endif; endsr; //--------------------------------------------------------- //FFile is e k disk rename( //F xxx010r:r) //F include(xxx010r //F :xxx010t) // I have seen crud like this, or it could be a legimate // include/Ignore of multiple record formats that goes across multiple source // lines. Load data from however many records into a single string. //--------------------------------------------------------- begsr SrBuildContinuationString; %len(ContinuationString) = 0; ContinuationString = %trim(SrcDS.dKeyWord); 1b dou IsCloseParenth; 2b if %scan(')': SrcDS.dKeyWord) > 0; 1v leave; 2e endif; read RPGSRC; exsr srOnlyFspecs; 2b if IsLeave or (IsProcess and SrcDS.fFileName3 > *blanks); readp RPGSRC; // reposition 1v leave; 2e endif; 2b if IsProcess; ContinuationString += %trim(SrcDS.dKeyWord); 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // load subfile fields from sorted array begsr srSort; SflRcdNbr = 1; rrn = 0; Ind.sfldsp = *off; Ind.sfldspctl = *off; write SBFCTL1; 1b if yy > 1; 2b if FootMsg07 = 'F7=Sort By Rcdmt'; sorta %subarr(aFileName: 1: yy); 2x else; sorta %subarr(aFormatname: 1: yy); 2e endif; 1e endif; 1b for aa = 1 to yy; 2b if aFileName(aa) > *blanks; ScrFileNam = aFileName(aa); 3b if FootMsg08 = 'F8=Show Rcdfmts'; ScrRcdFmt = aLibName(aa); 3x else; ScrRcdFmt = aFormatname(aa); 3e endif; HidRcdFmt = aFormatname(aa); 3b if aFormatReName(aa) = *blanks; ScrRenamed = '.'; 3x else; ScrRenamed = aFormatReName(aa); 3e endif; 3b if aBasedOnPF(aa) = *blanks; ScrBasedPF = '.'; 3x else; ScrBasedPF = aBasedOnPF(aa); 3e endif; ScrUsage = aHowUsed(aa); ScrRecText = aFileText(aa); rrn += 1; write SBFDTA1; 2e endif; 1e endfor; Ind.sfldspctl = *on; Ind.sfldsp = (rrn > 0); 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'Program uses no external data files.'); 1e endif; endsr; //--------------------------------------------------------- begsr srViewSubfile; exsr srSort; DbUtility = '2=' + f_GetFileUtil(); scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 3=Record Formats 7=Wrkobj *all'; 1b dou 1 = 2; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); 2b if (not Ind.sfldsp) or InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; 2b if InfdsFkey = f07; IsToggle07 = not IsToggle07; 3b if IsToggle07; FootMsg07 = 'F7=Sort By File '; 3x else; FootMsg07 = 'F7=Sort By Rcdmt'; 3e endif; exsr srSort; 1i iter; 2x elseif InfdsFkey = f08; IsToggle08 = not IsToggle08; 3b if IsToggle08; FootMsg08 = 'F8=Show Rcdfmts'; ColHead08 = 'Library'; 3x else; FootMsg08 = 'F8=Show Library'; ColHead08 = 'RcdFmt '; 3e endif; exsr srSort; 1i iter; 2e endif; // Process record in subfile user has selected. // as a precaution; only process on screen selection options readc SBFDTA1; 2b dow not %eof; 3b if sbfOption = 1 or sbfOption = 2 or sbfOption = 3 or sbfOption = 7; f_RunOptionFile( sbfOption: ScrFileNam: '*LIBL ': HidRcdFmt: '*FIRST ': ProgId); 3e endif; sbfOption = 0; update SBFDTA1; SflRcdNbr = rrn; readc SBFDTA1; 2e enddo; 1e enddo; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRRFLD - Show field names/attributes in RPGLE source - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Show RPG Field Attributes') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PROMPT('RPG program name:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(0) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') ]]> v5r4 *---------------------------------------------------------------- * JCRRFLDD - Show field names/attributes in RPGLE source - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA06 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A FIELDNAME 27A O 5 2 A MAPDTATYP 1A O 5 30 A MAPFLDLEN 7Y 0O 5 32EDTCDE(Z) A MAPDECPOS 2A O 5 40 A MAPFLDTXT 25A O 5 44 A MAPFLDSRC 10A O 5 70 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) BLINK OVERLAY A SFLPAG(17) SFLSIZ(170) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR *TOP) A 1 2'JCRRFLD' COLOR(BLU) A 1 23'Field Attributes in RPG Source' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 64A O 2 7 A 2 72SYSNAME COLOR(BLU) A SCPOSITION 14A I 3 2DSPATR(PC) A 3 17'Position to' COLOR(BLU) A 4 2'Field Name' DSPATR(HI) A 4 29'Type' DSPATR(HI) A 4 36'Len' DSPATR(HI) A 4 40'Dec' DSPATR(HI) A 4 44'Text/Qualified/Dim' DSPATR(HI) A 4 69'File' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 23 2'F3=Exit' COLOR(BLU) A 23 17'Enter=Position cursor to' A COLOR(BLU) A 23 49'F6=Print' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRRFLD'.Field Attributes in RPG Source (JCRRFLD) - Help .*-------------------------------------------------------------------- :P.This JCR command displays list of length, attributes, and where-from for all fields in RPG4 program.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRRFLD/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Program for which field lengths to be displayed.:EHELP. :HELP name='JCRRFLD/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRRFLDP - Show field names/attributes in RPGLE source - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) *--- PAGESIZE(66 198) *--- OVRFLW(60) *--- FOLD(*NO) A R PRTHEAD A SKIPB(1) A SPACEA(1) A 2'JCRRFLD' A 20'Field Attributes in RPG Source' A SCDOW 9A O 72 A 82DATE A EDTWRD(' / / ') A 92TIME A EDTWRD(' : : ') A 104'Page' A 109PAGNBR A EDTCDE(4) A SPACEA(1) *--- *--- A 2'Source Member:' A SCOBJHEAD 64A 17 A SPACEA(2) *--- *--- A 3'TEXT' A 30'FIELD' A 57'TYPE' A 64'LENGTH' A 71'DEC' A 76'FILE' A R PRTDETAIL *---------------------------------------------------------------- A SPACEA(1) A MAPFLDTXT 25A 3 A FIELDNAME 27A 30 A MAPDTATYP 1A 58 A MAPFLDLEN 7 0 62 A EDTCDE(Z) A MAPDECPOS 2A 71 A MAPFLDSRC 10A 76 ]]> v5r4 //--------------------------------------------------------- // JCRRFLDR - Show field names/attributes in RPGLE source // call program to load field names and attributes into imported array //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRRFLDD cf e workstn sfile(SBFDTA1: rrn) F infds(Infds) indds(Ind) FJCRRFLDP o e printer oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D vsetll s 15a D NumberOfRecs s 5u 0 //--*COPY DEFINES------------------------------------------ /Define Constants /Define Infds /Define Ind /Define Sds /Define FieldsArry /Define FieldsAttrDS /Define FunctionKeys /Define f_Qusrmbrd /Define f_BuildString /Define f_DspLastSplf /Define f_qmhrcvpm /Define f_GetQual /Define f_GetDayName /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndEscapeMsg /Define f_SndSflMsg /Define f_OvrPrtf /Define f_Dltovr /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRRFLDR PR extpgm('JCRRFLDR ') D 10a D 20a D p_JCRRFLDR PI D p_SrcMbr 10a D p_SrcFilQual 20a //--------------------------------------------------------- /free QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; scObjHead = f_BuildString('& & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFilQual: p_SrcMbr: DiagSeverity); //--------------------------------------------------------- f_RmvSflMsg(ProgId); evalr scDow = %trimr(f_GetDayName()); // if compile error, show severity as not all fields may have been defined 1b if DiagSeverity > '20'; f_SndSflMsg(ProgId: 'Diagnostic severity ' + DiagSeverity + '. Not all fields may be defined. See listing.'); 1e endif; //--------------------------------------------------------- // Pull all entries from imported array to screen fields 1b for NumberOfRecs = 1 to FieldsArry_NumberOfEntries; FieldsAttrDS = FieldsAttrArry(NumberOfRecs); 2b if FieldsAttrDS.Text <> '*NOT REFERENCED'; FieldName = FieldsNameArry(NumberOfRecs); MapFldTxt = FieldsAttrDS.Text; MapFldLen = %dec(FieldsAttrDS.Length: 7:0); MapDtaTyp = FieldsAttrDS.DataType; MapDecPos = FieldsAttrDS.DecimalPos; MapFldSrc = FieldsAttrDS.FromFile; rrn += 1; write SBFDTA1; 2e endif; 1e endfor; //--------------------------------------------------------- // display subfile to user. NumberOfRecs = rrn; SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No Fields defined in program.'); 1e endif; Ind.sfldspctl = *on; 1b dow not (InfdsFkey = f03); write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if (not Ind.sfldsp) or InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; f_RmvSflMsg(ProgId); // print subfile. 2b if InfdsFkey = f06; f_OvrPrtf('JCRRFLDP ': *OMIT: p_SrcMbr); open JCRRFLDP; evalr scDow = %trimr(f_GetDayName()); write PrtHead; 3b for rrn = 1 to NumberOfRecs; chain rrn SBFDTA1; write PrtDetail; 4b if IsOverFlow; write PrtHead; IsOverFlow = *off; 4e endif; 3e endfor; close JCRRFLDP; f_Dltovr('JCRRFLDP '); f_DspLastSplf(ProgId: '*PRINT '); f_SndSflMsg(ProgId: f_qmhrcvpm(3)); 2x else; //--------------------------------------------------------- // position subfile. aa = %checkr(' ': scPosition); 3b if aa = 0; SflRcdNbr = 1; 1i iter; 3e endif; 3b for rrn = 1 to NumberOfRecs; chain rrn SBFDTA1; vsetll = %subst(FieldName: 1: aa); 4b if scPosition <= vsetll or NumberOfRecs = rrn; SflRcdNbr = rrn; 3v leave; 4e endif; 3e endfor; 2e endif; 1e enddo; close JCRRFLDD; f_SndCompMsg(f_BuildString('JCRRFLD for & in & - completed.': p_SrcMbr: f_GetQual(p_SrcFilQual))); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRRTVRPG - Retrieve RPGLE source from compiled object - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Retrieve RPGLE Source') PARM KWD(RPGOBJECT) TYPE(RPGOBJECT) MIN(1) + PROMPT('Object compiled *LIST or *ALL:') RPGOBJECT: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) PROMPT('RPGLE member to generate:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRRTVRPGC - Retrieve RPGLE source from compiled object - CMDPGM */ /* Create PF in qtemp */ /* Dump system object to print file. */ /* Copy spooled file into previously created PF */ /* Call RPG program to extract and display entries */ /* This version works correctly for programs compiled since v5r1. */ /*--------------------------------------------------------------------------*/ PGM PARM(&OBJ_LIB &MBR &SRC_LIB) DCL VAR(&OBJ_LIB) TYPE(*CHAR) LEN(20) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&SRC_LIB) TYPE(*CHAR) LEN(20) DCL VAR(&OBJ) TYPE(*CHAR) LEN(10) DCL VAR(&OLIB) TYPE(*CHAR) LEN(10) DCL VAR(&SRC) TYPE(*CHAR) LEN(10) DCL VAR(&SLIB) TYPE(*CHAR) LEN(10) CHGVAR VAR(&OBJ) VALUE(%SST(&OBJ_LIB 1 10)) CHGVAR VAR(&OLIB) VALUE(%SST(&OBJ_LIB 11 10)) CHGVAR VAR(&SRC) VALUE(%SST(&SRC_LIB 1 10)) CHGVAR VAR(&SLIB) VALUE(%SST(&SRC_LIB 11 10)) CLRLIB LIB(QTEMP) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Dump + system object - in progress') + TOPGMQ(*EXT) MSGTYPE(*STATUS) OVRPRTF FILE(QPSRVDMP) + PRTTXT(' ') + HOLD(*YES) USRDFNOPT(*NONE) USRDFNDTA(*NONE) CRTPF FILE(QTEMP/JCRRTVRPG) RCDLEN(132) IGCDTA(*NO) + TEXT('JCRRTVRPG dump object data') SIZE(*NOMAX) MONMSG MSGID(CPF0000) CLRPFM FILE(QTEMP/JCRRTVRPG) DMPOBJ OBJ(&OLIB/&OBJ) OBJTYPE(*PGM) CPYSPLF FILE(QPSRVDMP) TOFILE(QTEMP/JCRRTVRPG) SPLNBR(*LAST) MBROPT(*REPLACE) OVRDBF FILE(JCRRTVRPG) TOFILE(QTEMP/JCRRTVRPG) + OVRSCOPE(*JOB) OVRDBF FILE(RPGSRC) TOFILE(&SLIB/&SRC) MBR(&MBR) + OVRSCOPE(*JOB) CALL PGM(JCRRTVRPGR) DLTOVR FILE(JCRRTVRPG) LVL(*JOB) DLTOVR FILE(RPGSRC) LVL(*JOB) DLTSPLF FILE(QPSRVDMP) SPLNBR(*LAST) SNDPGMMSG MSG('Source retrieval for ' *CAT &MBR + *TCAT ' in ' *CAT &SLIB *TCAT '/' *CAT + &SRC *TCAT ' - completed') ENDPGM ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRRTVRPG'.Retrieve RPGLE Source (JCRRTVRPG) - Help .*-------------------------------------------------------------------- :P.This JCR command retrieves the source member for V5 or V6 RPGLE object compiled with DBGVIEW *LIST or *ALL. :P.One weird circumstance: If retrieving fixed format program (not /free) and program has F specs. Utility will not retrieve first C spec and you will have to delete last line in the generated code. :P.Second thing: This program uses IBM generated dump file. IBM has been known to change format of dumps on different release levels. This version works correctly for programs compiled since v5r1.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRRTVRPG/RPGOBJECT'.Object compiled *LIST or *ALL - Help :XH3.Object compiled *LIST or *ALL (RPGOBJECT) :P.RPGLE program for which you wish to retrieve source.:EHELP. :HELP name='JCRRTVRPG/SRCMBR'.RPGLE member to generate - Help :XH3.RPGLE member to generate (SRCMBR) :P.RPGLE member name that will generated when source is retrieved. If same name as existing member, existing member will be overlaid.:EHELP. :HELP name='JCRRTVRPG/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Name of source file will contains RPGLE member.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRRTVRPGR - Retrieve RPGLE source from compiled object // NOTE: This will only work for programs compiled *LIST or *ALL!! // Weird: if retrieving columnar program (not /free) and program has F specs. The // program will not retrieve first C spec and you will have to delete last line in // generated code. // Final note: Due to this utility using object dump file, it may be operating system // sensitive. Meaning IBM has been known to change format of dumps on different release // levels. This version works correctly for programs compiled since v5r1. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRRTVRPG if f 132 disk FRPGSRC o f 112 disk //--*STAND ALONE------------------------------------------- D BasedField s like(dumptext) based(xPtr) D BasedField2 s like(StartText) based(xPtr) D BasedSrc s 95a based(xPtr) D Check1st6 s 6a based(Ptr1) D Check2nd5 s 5a based(Ptr2) D Check3rd6 s 6a based(Ptr3) D OutData s 95a D StartText s 5a INZ('DBGV-') D ScanCount s 10u 0 D SizeOfSpace s 10u 0 D xCount s 3u 0 D uPtr s * inz(*null) D IsFound s n //--*COPY DEFINES------------------------------------------ /Define UserSpaceHeaderDS /Define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS *NONE* ----------------------------------- //--*INPUT SPECS------------------------------------------- IJCRRtvRpg ns I a 87 87 Asterick I a 88 119 DumpText //--------------------------------------------------------- /free // Create user space uPtr = f_Quscrtus(UserSpaceName); // Load blocks of dump data into user space so entire dump is in single long string. xPtr = uPtr; read JCRRtvRpg; 1b dow not %eof; 2b if Asterick = '*'; BasedField = DumpText; xPtr += %len(DumpText); SizeOfSpace += %len(DumpText); 2e endif; read JCRRtvRpg; 1e enddo; //--------------------------------------------------------- // Find where source starts. ScanCount = 1; IsFound = *off; xPtr = uPtr; 1b dou ScanCount > SizeOfSpace; 2b if BasedField2 = StartText; IsFound = *on; 1v leave; 2e endif; xPtr += 1; ScanCount += 1; 1e enddo; // Start writing records to source member. 1b if IsFound; xPtr += 47; ScanCount += 47; 2b dou ScanCount > SizeOfSpace; OutData = BasedSrc; //--------------------------------------------------------- // For some inexplicable reason, some records // are 'shorter than others, and data from // following record could at end of // current records buffer. // This rather complex section determines if // condition exists and clears following records data from buffer. //--------------------------------------------------------- IsFound = *off; Ptr1 = %addr(OutData) + 1; xCount = 1; 3b Dou xCount > %len(OutData) - 16; xCount += 1; Ptr1 += 1; Ptr2 = Ptr1 + 6; Ptr3 = Ptr1 + 11; 4b if %check('0123456789': check1st6: 1) = 0 and %check(' ': check2nd5: 1) = 0 and %check('0123456789': check3rd6: 1) = 0; IsFound = *on; 3v leave; 4e endif; 3e enddo; 3b if IsFound; OutData = %subst(OutData: 1: xCount - 1); 3e endif; //--------------------------------------------------------- // Another interesting Quirk, if code be retrieved // is old - style and still uses resulting // indicators, dump will put '--' // if there are 'empty' indicators. like so, // 10---- // - - 10-- // --- - 10 // Remove -- before writing code. 3b if %subst(OutData: 65: 1) = ' '; 4b if %subst(OutData: 66: 2) = '--'; %subst(OutData: 66: 2) = ' '; 4e endif; 4b if %subst(OutData: 68: 2) = '--'; %subst(OutData: 68: 2) = ' '; 4e endif; 4b if %subst(OutData: 70: 2) = '--'; %subst(OutData: 70: 2) = ' '; 4e endif; 3e endif; 3b if not (%subst(OutData: 1: 19) = 'MAIN PROCEDURE EXIT'); except WriteSrc; 3e endif; xPtr += 30; ScanCount += 30; //--------------------------------------------------------- // After 1st source record, everything is random // located. Only true indication of source record // beginning is where date and sequence numbers are // located in the file. Ughh. // Spin until it finds 6 digits, 5 spaces, then 6 more digits. // At this point it is then a constant value over to // start of source line. 3b Dou %check('0123456789': check1st6: 1) = 0 and %check(' ': check2nd5: 1) = 0 and %check('0123456789': check3rd6: 1) = 0 or ScanCount > SizeOfSpace; xPtr += 1; ScanCount += 1; Ptr1 = xPtr; Ptr2 = Ptr1 + 6; Ptr3 = Ptr1 + 11; 3e enddo; xPtr += 30; ScanCount += 30; 2e enddo; 1e endif; *inlr = *on; return; /end-free ORPGSRC e WriteSrc O outData 112 ]]> v5r4 //--------------------------------------------------------- // JCRRTVRPGV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_CheckObj /Define f_OutFileAddPfm /Define f_RtvMsgAPI /Define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRRTVRPGV PR extpgm('JCRRTVRPGV') D 20a const D 10a const D 20a const D p_JCRRTVRPGV PI D p_ObjQual 20a const D p_SrcMbr 10a const D p_SrcQual 20a const //--------------------------------------------------------- /free f_CheckObj(p_ObjQual: '*PGM '); f_CheckObj(p_SrcQual: '*FILE '); f_OutFileAddPfm(p_SrcQual: p_SrcMbr: 'RPGLE ': 'Source recovered by JCRRTVRPG'); 1b if ApiErrDS.BytesReturned > 0; ApiErrDS.MsgReplaceVal = p_SrcMbr + p_SrcQual; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRSBSDR - generate report comparing pool IDs used by routing entries. // call Qwclasbs API to load all active subsystem names into array. // call Qwdrsbsd API to get pool id. // call Qwdlsbse API to pool id of routing entries. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FQSYSPRT o f 132 printer oflind(IsOverFlow) usropn //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_DspLastSplf /Define f_Quscrtus /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D SBSArry s 20a dim(250) D a21 s 21a D PrtPools s 75a D PrtRouting s 30a D QualSbsName s 20a D RoutingExtract s 3a D SystemName s 8a D RoutingArry s 10i 0 dim(50) ascend D LengthOfBuffer s 10i 0 D scDow s 9a D ForCount2 s 10i 0 D aa s 5u 0 D bb s 5u 0 D cc s 5u 0 D yy s 5u 0 D zz s 10u 0 //--*DATA STRUCTURES--------------------------------------- // active subsystems D QwclasbsDS ds qualified based(QwclasbsPtr) D QualSbsName 20a overlay(QwclasbsDS:1) // routing entries D QwdlsbseDS ds qualified based(QwdlsbsePtr) D RoutingEntry 10i 0 overlay(QwdlsbseDS:49) D sbsi0100DS ds 500 qualified D NumberOfPools 10i 0 overlay(sbsi0100DS:77) D PoolExtractDS ds qualified based(PoolExtractPtr) D PoolNumber 10i 0 D PoolName 10a // load print string D PoolPrintDS ds 15 qualified D PoolNumber 2a overlay(PoolPrintDS:1) D PoolName 11a overlay(PoolPrintDS:4) // Number of keys returned and offset to attribute data D QwcrnetaDS ds 100 qualified inz D NumberKeys 10i 0 D TableOffset 10i 0 // Network Attribute Information Table returned D NetworkInfoDS ds qualified based(NetWorkInfoPtr) D Attribute 10a overlay(NetworkInfoDS:1) D TypeOfData 1a overlay(NetworkInfoDS:11) D InfoStatus 1a overlay(NetworkInfoDS:12) D LengthOfData 10i 0 overlay(NetworkInfoDS:13) D Data 8a overlay(NetworkInfoDS:17) //--*CALL PROTOTYPES--------------------------------------- D Qwcrneta PR extpgm('QWCRNETA') Network Attributes D 200a options(*varsize) Receiver Variable D 10i 0 const Receiver Length D 10i 0 const Number Of Keys D 11a const Constant Db like(ApiErrDS) Error Parm D Qwclasbs PR extpgm('QWCLASBS') Active Subsystems D 20a Space Name and Lib D 8a const Api Format Db like(ApiErrDS) Error Parm D Qwdrsbsd PR extpgm('QWDRSBSD') Subsystem Info D 500a Receiver D 10i 0 const Length D 8a const Api Format D 20a Subsystem Name Db like(ApiErrDS) Error Parm D Qwdlsbse PR extpgm('QWDLSBSE') List SBS Entries D 20a User Space and Lib D 8a const Api Format D 20a Qualified Sbs Name Db like(ApiErrDS) Error Parm //--*ENTRY PARMS *NONE* ----------------------------------- /free open QSYSPRT; evalr scDow = %trimr(f_GetDayName()); // retrieve Network attributes to get sys name callp QWCRNETA( QwcrnetaDS : %size(QwcrnetaDS): 1: 'SYSNAME': ApiErrDS); NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.TableOffset; SystemName = NetworkInfoDS.Data; except PrtHead; //load active subsystem names to user space then to array GenericHeaderPtr = f_QUSCRTUS(UserSpaceName); callp QWCLASBS( UserSpaceName: 'SBSL0100': ApiErrDS); QwclasbsPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; SBSArry(ForCount) = QwclasbsDS.QualSbsName; QwclasbsPtr += GenericHeader.ListEntrySize; 1e endfor; sorta %subarr(SBSArry: 1 : GenericHeader.ListEntryCount); //--------------------------------------------------------- // Spin though subsystems and load pools and routing entries yy = GenericHeader.ListEntryCount; 1b for ForCount = 1 to yy; QualSbsName = SBSArry(ForCount); // Get POOL id number and names. Load up to 5 entries. callp QWDRSBSD( sbsi0100DS: %len(sbsi0100DS): 'SBSI0100': QualSbsName: ApiErrDS); PoolExtractPtr = %addr(sbsi0100DS) + 80; clear PrtPools; aa = 1; 2b for zz = 1 to sbsi0100DS.NumberOfPools ; 3b if zz > 5; 2v leave; 3e endif; evalr PoolPrintDS.PoolNumber = %editc(PoolExtractDS.PoolNumber:'4'); PoolPrintDS.PoolName = PoolExtractDS.PoolName; %subst(PrtPools: aa) = PoolPrintDS; aa += 15; PoolExtractPtr += 28; 2e endfor; // load routing entries for this subsystem into user space callp QWDLSBSE( UserSpaceName: 'SBSE0100': QualSbsName: ApiErrDS); //--------------------------------------------------------- // Same routing pool entry ID could be in many // routing entries. I only want to show one . // Use array to lookup and see if entry is used yet. aa = 0; clear RoutingArry; PrtRouting = *all'- '; QwdlsbsePtr = GenericHeaderPtr + GenericHeader.OffSetToList; 2b for ForCount2 = 1 to GenericHeader.ListEntryCount; 3b if aa = 0 or %lookup(QwdlsbseDS.RoutingEntry: RoutingArry: 1: aa) = 0; aa += 1; RoutingArry(aa) = QwdlsbseDS.RoutingEntry; 3e endif; QwdlsbsePtr += GenericHeader.ListEntrySize; 2e endfor; // Sort array and load it into print string. 2b if aa > 1; sorta %subarr(RoutingArry: 1: aa); 2e endif; // Spin through array, loading print string cc = 1; 2b for bb = 1 to aa; evalr RoutingExtract = %editc(RoutingArry(bb):'4'); %subst(PrtRouting: cc: 3) = RoutingExtract; cc += 3; 2e endfor; a21 = %subst(QualSbsName: 1: 10)+' '+%subst(QualSbsName: 11: 10); except PrtDetail; 1e endfor; close QSYSPRT; f_DspLastSplf('JCRSBSDR ': '* '); *inlr = *on; return; /end-free Oqsysprt e PrtHead 1 01 O 10 'JCRSBSDR ' O 42 'ANALYZE SUBSYSTEM POOLS' O scDow 85 O udate y 95 O 111 'Page' O PAGE1 117 O e PrtHead 2 O 57 'SYSTEM:' O SystemName 68 O e PrtHead 1 O 4 'SBSD' O 43 'ROUTING ENTRY POOLID' O 58 'POOLS' O e PrtDetail 1 O a21 O PrtRouting + 1 O PrtPools + 1 ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSDENT- Indented source list CL or RPG - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print Indented Source Listing') PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Source member name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) + SPCVAL((QRPGLESRC) (QCLSRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRSDENT'.Indented source list CL or RPG (JCRSDENT) - Help .*-------------------------------------------------------------------- :P.This JCR command prints a CL or RPG source listing with structured programming operations indented for improved readability. :P.Please note inclusion of /free RPG made some compromises inevitable, especially with mixed columnar and /free code in same source. All comment lines are indented over and SELECT groups are expected to terminate with ENDSL, not just END.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSDENT/SRCMBR'.Source Member Name - Help :XH3.Source Member Name (SRCMBR) :P.Source member for which indented list is to be printed.:EHELP. :HELP name='JCRSDENT/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP name='JCRSDENT/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRSDENTP - Indented source list CL or RPG - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A INDARA A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRSDENT' A PRINTTITLE 48A O 20 A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') SPACEA(1) A 2'Mbr:' A SCOBJHEAD 105A 7SPACEA(1) A 2'Seqno' A 9'Source Code' SPACEA(1) A 2'------' A 9'----------------------------------- A ------------------------------------ A ----' A 124'--------' *---------------------------------------------------------------- A R PRTCLSPEC SPACEA(1) A SEQNO 6S 2O 1EDTCDE(4) A LINEOFCODE 114A O 10 A 20 LASTCHGDAT 6 0 123EDTWRD('0 / / ') A 132' ' *---------------------------------------------------------------- A R PRTXSPEC SPACEA(1) A SEQNO 6S 2O 1EDTCDE(4) A SRCALL 100A O 9 *---------------------------------------------------------------- A R PRTCSPEC SPACEA(1) A SEQNO 6S 2O 1EDTCDE(4) A PART1_SRC 25A O 9 A LINEOFCODE 114A O 34 ]]> v5r4 //--------------------------------------------------------- // JCRSDENTR - Indented source list CL or RPG print //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FSRCMBR if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn infds(Infds) FJCRSDENTP o e printer oflind(IsOverFlow) usropn F indds(Ind) //--*STAND ALONE------------------------------------------- D WrkA s like(OpCodeDS) D Upper s like(SrcAll) D LevelsDeep s 3u 0 D RecLen s 5u 0 D LevelsDown s 3u 0 D LevelsUp s 3u 0 D xx s 3u 0 D yy s 3u 0 D IsArrowIn s n D IsCalcSpec s n D IsCasxx s n D IsCompileTime s n D IsFree s n D IsSqlExec s n D IsDo s n D IsDoEnd s n //--*COPY DEFINES------------------------------------------ /Define Constants /Define Ind /Define Infds /Define f_BuildString /Define f_DspLastSplf /Define f_GetQual /Define f_Qusrmbrd /Define f_GetDayName /Define f_System /Define f_BlankCommentsCL /Define f_Dltovr /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D OpCodeDS ds inz qualified D Two 2a overlay(OpCodeDS:1) D Three 3a overlay(OpCodeDS:1) D Four 4a overlay(OpCodeDS:1) //--*ENTRY PARMS------------------------------------------- D p_JCRSDENTR PR extpgm('JCRSDENTR') D 10a Source Member D 20a Source File and Lib D 8a D p_JCRSDENTR PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_Output 8a //--*INPUT SPECS------------------------------------------- ISRCMBR ns I s 1 6 2Seqno I s 7 12 0LastChgDat I a 13 15 CompileArray I a 13 37 Part1_Src I a 18 18 SpecType I a 19 19 Asterisk I a 19 27 FreeForm I a 38 47 OpCodeDS I a 38 112 Part2_Src I a 13 112 Src112 I a 19 112 SrcAllFree //--------------------------------------------------------- /free f_System(f_BuildString( 'OVRPRTF FILE(JCRSDENTP) PRTTXT(&Q&&Q) USRDFNOPT(*NONE) + SPLFNAME(&) OVRSCOPE(*JOB)': ' ': p_SrcMbr)); open JCRSDENTP; // Get source type for heading and logic selection QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); PrintTitle = 'Indented ' + %trimr(QusrmbrdDS.MbrType) + ' Source Listing'; scObjHead = f_BuildString('& & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); evalr scDow = %trimr(f_GetDayName()); write PrtHead; extIfile = f_GetQual(QusrmbrdDS.File + QusrmbrdDS.Lib); open SRCMBR; read SRCMBR; 1b dow not %eof; // If 92 record length, blank out any garbage from 93 to 112 2b if InfdsRecLen = 92; %subst(Src112:81) = *all' '; 2e endif; 2b if QusrmbrdDS.MbrType = 'CLP ' or QusrmbrdDS.MbrType = 'CLLE '; exsr srClSrc; 2x else; exsr srRPGSrc; 2e endif; read SRCMBR; 1e enddo; exsr srClose; //--------------------------------------------------------- begsr srClose; close JCRSDENTP; close SRCMBR; f_Dltovr('JCRSDENTP '); f_DspLastSplf('JCRSDENTR ': p_Output); *inlr = *on; return; endsr; //--------------------------------------------------------- begsr srRPGSrc; // do not process compile time arrays 1b if CompileArray = '** ' or CompileArray = '**C' or CompileArray = '**c'; IsCompileTime = *on; 1e endif; // don't worry about indenting till I get to C specs. // if C or c or /free, I am in C specs. 1b if SpecType = 'C' or SpecType = 'c'; IsCalcSpec = *on; 1e endif; // see if inside /free section 1b if Asterisk = '/'; FreeForm = %xlate(lo: up: FreeForm); 2b if FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 2x elseif FreeForm = '/END-FREE'; IsFree = *off; 2e endif; 1e endif; // only indent certain lines 1b if (SpecType = 'C' or SpecType = 'c' or SpecType = ' ' or SpecType < x'40') //color attributes and IsCompileTime = *off and IsCalcSpec = *on; LevelsDown = 0; LevelsUp = 0; 2b if not (Asterisk = '*' or Asterisk = '+' //no sql or Asterisk = '/'); //no copy statements //--------------------------------------------------------- // For /free code, do a little work to get Opcode // into OpCodeDS field, then let existing program process indentions. // Look for first ';' and first ';' , which ever not // zero and lowest value is end of opcode 3b if IsFree and Src112 > *blanks; WrkA = %triml(SrcAllFREE); aa = %scan(' ': WrkA: 1); bb = %scan(';': WrkA: 1); clear OpCodeDS; 4b if aa > 0 and (aa < bb or bb = 0); OpCodeDS = %subst(WrkA: 1: aa - 1); 4x elseif bb > 0 and (bb < aa or aa = 0); OpCodeDS = %subst(WrkA: 1: bb - 1); 4e endif; 3e endif; OpCodeDS = %xlate(lo: up: OpCodeDS); // bad person had field named END in their free code // ENDblank is valid in fixed format, but not in free 3b if IsFree and OpCodeDS = 'END '; OpCodeDS = *blanks; 3e endif; //--------------------------------------------------------- // With v5r4 came free format SQL statement // Idea here is to ignore everything between // EXEC opcode and line terminating with semicolon 3b if OpcodeDS = 'EXEC '; IsSqlExec = *on; 3e endif; 3b if not IsSqlExec; 4b if (OpCodeDS.Two = 'DO' and IsFree = *off) or (OpCodeDS.Two = 'IF' and IsFree = *off) or (OpCodeDS = 'DOU ' and IsFree = *on) or (OpCodeDS.Four = 'DOU(' and IsFree = *on) or (OpCodeDS = 'DOW ' and IsFree = *on) or (OpCodeDS.Four = 'DOW(' and IsFree = *on) or (OpCodeDS = 'IF ' and IsFree = *on) or (OpCodeDS.Three = 'IF(' and IsFree = *on) or OpCodeDS = 'FOR ' or OpCodeDS = 'MONITOR ' or OpcodeDS.Four = 'FOR('; LevelsDown = 1; 4x elseif OpCodeDS = 'SELECT '; LevelsDown = 2; //--------------------------------------------------------- // process cas opcode. There could be several // cas in a row and only first one in each group // used to trigger offset. 4x elseif OpCodeDS.Three = 'CAS' and IsCasxx = *off and IsFree = *off; LevelsDown = 1; IsCasxx = *on; //--------------------------------------------------------- // Set indicator to load marker for these opcodes. 4x elseif (OpCodeDS.Two = 'WH' and IsFree = *off) or OpCodeDS = 'OTHER ' or OpCodeDS = 'ELSE ' or OpCodeDS = 'ELSEIF' or OpCodeDS = 'ON-ERROR ' or OpCodeDS = 'WHEN '; IsArrowIn = *on; //--------------------------------------------------------- // Set Flag if END is found, reset CAS indicator. 4x elseif OpCodeDS <> 'ENDSR' and ( (OpCodeDS.Three = 'END' and IsFree = *off) or OpCodeDS = 'END ' or OpCodeDS = 'ENDSL ' or OpCodeDS = 'ENDIF ' or OpCodeDS = 'ENDDO ' or OpCodeDS = 'ENDMON ' or OpCodeDS = 'ENDFOR '); LevelsUp = 1; IsCasxx = *off; 4e endif; //--------------------------------------------------------- // Step up for WHEN/OTHER under WHEN, OTHER statement. 4b if OpCodeDS = 'ENDSL'; LevelsUp = 2; 4e endif; 4b if ((OpCodeDS.Two = 'WH' and IsFree = *off) or OpCodeDS = 'WHEN ' or OpCodeDS = 'OTHER '); LevelsDeep -= 1; 4e endif; 3e endif; // look for line terminating in semi-colon 3b if IsSqlExec; IsSqlExec = (%scan(';': SrcAllFREE: 1) = 0); 3e endif; 2e endif; //--------------------------------------------------------- // Load indent char and source line for printing. 2b if (LevelsDeep = 0 and LevelsUp > 0); f_SndCompMsg('WARNING: Unmatched ENDxx Opcode at ' + %triml(%editc(SeqNo:'4')) + ' - JCRSDENT canceled!'); exsr srClose; 2e endif; LevelsDeep -= LevelsUp; // Step over how far to indent clear LineOfCode; xx = 1; 2b for yy = 1 to LevelsDeep; %subst(LineOfCode: xx: 3) = '| '; 3b if IsArrowIn = *on and LevelsDeep = yy; %subst(LineOfCode: xx: 3) = '|> '; IsArrowIn = *off; 3e endif; xx += 3; 2e endfor; 2b if IsFree = *on or Asterisk = '*' or Asterisk = '+' or Asterisk = '/'; %subst(LineOfCode: xx) = %triml(SrcAllFree); %subst(Part1_Src: 7) = *all' '; 2x else; %subst(LineOfCode: xx) = Part2_Src; 2e endif; write PrtCspec; LevelsDeep += LevelsDown; // step back down level for stuff under WHEN/OTHER 2b if not (Asterisk = '*' or Asterisk = '+' or Asterisk = '/'); 3b if (OpCodeDS.Two = 'WH' and IsFree = *off) or OpCodeDS = 'WHEN ' or OpCodeDS = 'OTHER '; LevelsDeep += 1; 3e endif; 2e endif; 1x else; SrcAll = Src112; write PrtXspec; 1e endif; endsr; //--------------------------------------------------------- begsr srCLSrc; // slam everything to left for indentation then upper case Src112 = ' ' + %triml(Src112); Upper = %xlate(lo: up: Src112); // It is easier to blank out all comments before scanning. Upper = f_BlankCommentsCL(Upper); // Check for indent start and end commands. 1b if Upper > *blanks; IsDo = (%scan(' DO ': Upper) > 0 or %scan('(DO': Upper) > 0 or %scan('DOUNTIL': Upper) > 0 or %scan('DOWHILE': Upper) > 0 or %scan('DOFOR': Upper) > 0 or %scan(' SELECT ': Upper) > 0 or %scan('(SELECT ': Upper) > 0); IsDoEnd = (%scan('ENDDO ': Upper) > 0 or %scan('ENDSELECT': Upper) > 0); 1x else; IsDo = *off; IsDoEnd = *off; 1e endif; //--------------------------------------------------------- // If ENDDO is found, sub one from counter. // Spin though number of DO levels deep and load ' |' char. // If DO, increment counter by one for next time. 1b if IsDoEnd; LevelsDeep -= 1; 1e endif; clear LineOfCode; 1b for cc = 1 to LevelsDeep; LineOfCode = %trimr(LineOfCode) + ' |'; 1e endfor; LineOfCode = %trimr(LineOfCode) + Src112; 1b if IsDo; LevelsDeep += 1; 1e endif; Ind.IsChangedDate = (LastChgDat > 0); write PrtCLspec; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSMLT - Scan mult source file/mbrs for mult strings - CMD */ /* 1 - added special values to SRCFILE parm to allow groups of */ /* files to be searched if value is selected. See program */ /* JCRSMLTRD for details of files associated with these keywords */ /* Please note: Feel free to change these keywords and program */ /* JCRSMLTRD to whatever groupings you would prefer. */ /* 2- include parm to define relation of strings to mbr. */ /* *ALL - member contains all strings (full set) */ /* *ANY - member contains any of the strings (any set) */ /* *NONE - member contains none of the strings (empty set) */ /* *NOTALL - member contains at least one string */ /* but is missing one of the other strings. */ /* This command is used to find multiple values in multiple files. */ /* It can accept up to 10 search strings of 25 characters */ /* and search through up to 9 source files. */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Scan Multiple Files / Strings') PARM KWD(SCANSTRING) TYPE(*CHAR) LEN(25) MIN(1) + MAX(10) VARY(*YES *INT2) CASE(*MIXED) PROMPT('Scan ''string'':') PARM KWD(CASENSITVE) TYPE(*CHAR) LEN(4) + RSTD(*YES) DFT(*NO) VALUES(*YES *NO) PROMPT('Case Sensitive Search:') PARM KWD(IFCONTAINS) TYPE(*CHAR) LEN(7) + RSTD(*YES) DFT(*ANY) VALUES(*ANY *ALL + *NONE *NOTALL) PROMPT('If member contains string:') PARM KWD(SRCFILE) TYPE(SRCFILE) MIN(1) MAX(9) PROMPT('Source File(s):') SRCFILE: ELEM TYPE(*NAME) LEN(10) SPCVAL((*HISTORY)) + CHOICE('File Name or F4 for predefined') PROMPT('File Name:') ELEM TYPE(*NAME) LEN(10) PROMPT(' Library:') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL, name, generic*') PROMPT(' Member:') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL,RPGLE,RPG,CL,DSPF,etc.') + PROMPT(' Member Type:') PARM KWD(LISTLEVEL) TYPE(*CHAR) LEN(6) RSTD(*YES) + DFT(*FIRST) VALUES(*FIRST *ALL) PROMPT('List occurrences in each mbr:') PARM KWD(SCANCMNT) TYPE(*CHAR) LEN(5) RSTD(*YES) + DFT(*NO) VALUES(*NO *YES *ONLY) + PROMPT('Scan Comment Lines:') PARM KWD(FROMPOS) TYPE(*DEC) LEN(3) DFT(1) PROMPT('Start Search FROM position:') PARM KWD(TOPOS) TYPE(*DEC) LEN(3) DFT(100) PROMPT('End Search TO position:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *OUTFILE *) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) PROMPT('Output member options:') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or add records') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) NBRTRUE(*EQ 1) ]]> v5r4 *---------------------------------------------------------------- * JCRSMLTF - Scan mult source file/mbrs - outfile - PF *---------------------------------------------------------------- A R JCRSMLTFR TEXT('Scan Multiple') A DATE L COLHDG('Display Date') A TIME T COLHDG('Display Date') A SCANSET 7A COLHDG('Scan set') A SRCLIB 10A COLHDG('Source Lib') A SRCFIL 10A COLHDG('Source File') A RTVMBR 10A COLHDG('Source Mbr') A MBRTYPE 10A COLHDG('Mbr Type') A SRCSEQ 6S 2 COLHDG('Line Number') A SRCDTA 100A COLHDG('Source') A SRCCHGDAT 6S 0 COLHDG('Change Date') A SRCTXT 50A COLHDG('Text') A SCANSTR1 25A COLHDG('Scan Strings') A SCANSTR2 25A A SCANSTR3 25A A SCANSTR4 25A A SCANSTR5 25A A SCANSTR6 25A A SCANSTR7 25A A SCANSTR8 25A A SCANSTR9 25A A SCANSTR10 25A ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRSMLT'.Scan Multiple Files / Strings (JCRSMLT) - Help .*-------------------------------------------------------------------- :P.This JCR command searches up to ten different character strings in selected members of up to nine source physical files. You can scan for trailing blanks by enclosing scan string in quotes. For example. 'ABC ' would scan for ABC followed by three blank spaces. :NT.Keywords for groups of files can be predefined in program JCRSMLTRD.:ENT. :P.You can define selection strings as sets. See help on IFCONTAINS keyword.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSMLT/SCANSTRING'.Search Strings - Help :XH3.Search Strings (SCANSTRING) :P.String or list of strings (up to ten) that you want to search for in source members you specify. 'XX ' will search for XX and a space or blank character. :NT.If scanning for '11', you would enter '''11''' on scan line.:ENT.:EHELP. :HELP name='JCRSMLT/CASENSITVE'.Case Sensitive Search - Help :XH3.Case Sensitive Search: (CASENSITIVE) :P.Allows case differences to be ignored or included in search. :PARML.:PT.:PK def.*NO:EPK.:PD.Upper or lower case is not considered in search. :PT.*YES :PD.Search is case sensitive.:EPARML.:EHELP. :HELP name='JCRSMLT/IFCONTAINS'.If member contains string - Help :XH3.If member contains string: (IFCONTAINS) :P.Controls member selection depending on how search strings are evaluated. :PARML.:PT.:PK def.*ANY:EPK.:PD.The member is listed if ANY of the search strings are found in source member. Think of it as an OR relation if you have selected multiple search strings. Member must contain string1 OR string2 OR etc..... This is fastest performing option. :PT.*ALL :PD.Member is listed only if ALL search strings are found. Each search string must be found in the member. Think of it as an AND relation if you have selected multiple search strings. Member must contain string1 AND string2 AND etc... :PT.*NONE :PD.Member is listed if NONE of search strings are found. :PT.*NOTALL :PD.The member is listed if it contains one or more search strings and also does NOT contain one or more search strings.:EPARML.:EHELP. :HELP name='JCRSMLT/SRCFILE'.Source File(s) - Help :XH3.Source File(s) (SRCFILE) :P.Name and library of source physical file or list of files (up to nine) that should be searched by the command. :NT.You can associate groups of files with keyword in program JCRSMLTRD.:ENT.:EHELP. :HELP name='JCRSMLT/LISTLEVEL'.List occurrences in each mbr - Help :XH3.List occurrences in each mbr (LISTLEVEL) :P.Controls level of detail of output. :PARML.:PT.:PK def.*FIRST:EPK. :PD.Only first occurrence of the found string is listed. Useful for getting list of programs that contain one of the search strings. :PT.*ALL :PD.Every occurrence of search string in source member is listed. There will be same number of programs as with the *FIRST option, but same program might be listed multiple times depending on how many times search string is found in the source.:EPARML.:EHELP. :HELP name='JCRSMLT/SCANCMNT'.Scan Comment Lines - Help :XH3.Scan Comment Lines (SCANCMNT) :P.Scan comment lines during search. :PARML.:PT.:PK def.*NO:EPK.:PD.The default is do not include source comment lines in scan. :PT.*YES :PD.Include source comment lines in search. :PT.*ONLY :PD.Only search source comment lines.:EPARML.:EHELP. :HELP name='JCRSMLT/FROMPOS'.Start Search FROM position - Help :XH3.Start Search FROM position (FROMPOS) :P.Position in source code to begin scanning. :PARML.:PT.:PK def.1:EPK. :PD.The default is to start scanning from first position in source. :PT.number :PD.Select position to begin scan.:EPARML.:EHELP. :HELP name='JCRSMLT/TOPOS'.End Search TO position - Help :XH3.End Search TO position (TOPOS) :P.Position in source code to stop scanning. :PARML.:PT.:PK def.100:EPK.:PD.The default is to scan to position 100 in source. :PT.number :PD.Select position to end scan.:EPARML.:EHELP. :HELP name='JCRSMLT/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.Output to print file or data file. :PARML.:PT.:PK def.*PRINT:EPK.:PD.Generate report listing in batch. :PT.*OUTFILE :PD.Output is redirected to selected data file. (see OUTFILE help). :PT.* :PD.Report listing is shown interactively. Could tie up your interactive session for long periods of time if scanning large number of members.:EPARML.:EHELP. :HELP name='JCRSMLT/OUTFILE'.File to receive output - Help :XH3.File to receive output (OUTFILE) :P.Name and library of database file to which output of command is directed. If file does not exist, this command creates database file in specified library. :NT.If new file is created, text describing that file is "Outfile for JCRSMLT utility". The database format (JCRSMLTF) of output file is same as that used in supplied file database JCRSMLTF.:ENT. :P.JCRSMLTF cannot be specified as outfile to receive output. :P.The possible library values are: :PARML.:PT.:PK def.*LIBL:EPK.:PD.All libraries in job's library list are searched until first match is found. :PT.*CURLIB :PD.The current library for job is used to locate file. If no library is specified as current library for job, QGPL is used. :PT.library-name :PD.Specify library where file is located.:EPARML.:EHELP. :HELP name='JCRSMLT/OUTMBR'.Output - Help :XH3.Output (OUTMBR) :P.Database file member that receives output of command. :P.The possible name values are: :PARML.:PT.:PK def.*FIRST:EPK.:PD.The first member in file receives output. If it does not exist, the system creates member with name of file specified in :HP2.File to receive output:EHP2. prompt (OUTFILE parameter). :PT.member-name :PD.Specify name of file member that receives output. If it does not exist, the system creates it.:EPARML. :P.The possible values for how information is stored are: :PARML.:PT.:PK def.*REPLACE:EPK. :PD.The system clears existing member and adds new records. :PT.*ADD :PD.The system adds new records to end of existing records.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRSMLTP - Scan mult source file/mbrs - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A INDARA A R PRTHEAD1 SKIPB(1) SPACEA(1) A 2'JCRSMLT' A 22'Scan Multiple Files / Multiple Str- A ings(JCRSMLT)' A SCDOW 9A O 110 A 120DATE EDTWRD(' / / ') A 130TIME EDTWRD(' : : ') A 140'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 71'List' A 84'Scan' SPACEA(1) *--- A 20'Library' A 32'File' A 44'Member' A 56'Type' A 71'Occurrence' A 84'Comments' *---------------------------------------------------------------- A R PRTHEAD2 SPACEA(1) A N10 2'Scan Source List:' A SRCLIB 10A O 20 A SRCFIL 10A O 32 A SRCMBR 10A O 44 A SRCMBRTYP 10A 56 A N10 PLISTLVL 6A 71 A N10 PSCANCMNT 5A 84 *---------------------------------------------------------------- A R PRTHEAD3 SPACEA(1) A N10 2'Search Strings:' A SCNSTR 25A O 20 A N10 49'String Set:' A N10 P_SETDEFN 7A 61 A N10 SETVERBAGE 50A 73 *---------------------------------------------------------------- A R PRTHEAD4 SPACEA(1) A 1'Library' A 12'File' A 24'Member' A 27 36'Seqno' A 27 45'Source Data' A 27 126'Chg Date' A 136'Text' A SPACEA(1) *--- A 1'----------' A 12'----------' A 24'----------' A 36'-------' A 45'----------------------------------- A ------------------------------------ A -----------' A 126'--------' A 136'----------------------------------- A --------------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SRCLIB 10A O 1 A SRCFIL 10A O 12 A RTVMBR 10A O 24 A 27 SRCSEQ 6 2O 36EDTCDE(4) A 27 SRCDTA80 80A O 45 A 20 30 SRCCHGDAT 6 0 126EDTWRD('0 / / ') A SRCTXT 50A 136 *---------------------------------------------------------------- A R PRTSPACEA1 SPACEA(1) A 1' ' ]]> v5r4 ‚ //--------------------------------------------------------- ‚ // JCRSMLTR - Scan mult source file/mbrs - scanner ‚ // call Quslmbr API to load selected member names into user space. ‚ // read source member and scan for string. ‚ //--------------------------------------------------------- ‚ // Set Definitions (LdaDS.IfContains) *ALL - member must contain all strings (full set) *ANY - ‚ // member may contain any of strings (any set) *NONE - member contains none of the ‚ // strings (empty set) *NOTALL - member contains at least one string but is missing one ‚ // of the other strings. (incomplete set) Code is going to be a bit complex to do this ‚ // with a single pass through each member, but performance is prime consideration. ‚ //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FMBRSRC if f 112 disk extfile(extIfile) extmbr(RtvMbr) F usropn Infds(Infds) FJCRSMLTF o e disk extfile(extOfile) extmbr(ExtOmbr) F usropn FJCRSMLTP o e printer oflind(IsOverFlow) indds(Ind) F usropn ‚ //--*STAND ALONE------------------------------------------- D extOmbr s 10a D NumOfFiles s 3u 0 DNumOfScanValues s 3u 0 D ScanLen s 3u 0 D ToPosSave s 3u 0 D ToPos s 3u 0 D FromPos s 3u 0 D ScanRRN s 5u 0 dim(16000) D CurrentRRN s 5u 0 D Displacement s 5i 0 based(DisplacePtr) D RtvMbr s 10a D SrcCase s like(SrcDta) D ForCount2 s like(NumOfFiles) D SrcListPtr s * inz(*null) D IsAllFound s n D IsNoneFound s n D IsSomeFound s n D IsFoundArry s n dim(10) D yy s 5u 0 D ScanVals s 25a dim(10) based(ParseValuesPtr) varying ‚ //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Ind /Define Infds /Define Quslmbr /Define UserSpaceHeaderDS /Define f_BlankCommentsCL /Define f_GetQual /Define f_GetDayName /Define f_ParmListCount /Define f_Quscrtus /Define f_OvrPrtf /Define f_Dltovr /COPY JCRCMDS,JCRCMDSCPY ‚ //--*DATA STRUCTURES--------------------------------------- ‚ // Get number of source files selected and source file/lib/mbr names D InnerList ds based(InnerListPtr) D SrcFil 10a overlay(InnerList:3) D SrcLib 10a overlay(InnerList:*next) D SrcMbr 10a overlay(InnerList:*next) D SrcMbrTyp 10a overlay(InnerList:*next) D LdaDS ds DTAARA(*LDA) qualified D SrcFiles 398a D ScanStrings 272a D Case 4a D IfContains 7a D Listlvl 6a D ScanComment 5a D From 3u 0 D To 3u 0 D Output 8a D OutFileQual 20a D OutMbrOpt 22a D OutFileData ds D SCANSTR1 D SCANSTR2 D SCANSTR3 D SCANSTR4 D SCANSTR5 D SCANSTR6 D SCANSTR7 D SCANSTR8 D SCANSTR9 D SCANSTR10 D ScanStrOutFile like(scanstr1) overlay(OutFileData:1) D dim(10) ‚ //--*ENTRY PARMS *NONE* ----------------------------------- ‚ // LDA is used for long parms ‚ //--*INPUT SPECS------------------------------------------- IMBRSRC ns I s 1 6 2SrcSeq I s 7 12 0SrcChgdat I a 19 19 SrcComment I a 19 20 SrcCommentFree I a 13 112 SrcDta ‚ //--------------------------------------------------------- /free in LdaDS; SrcListPtr = %addr(LdaDS.SrcFiles); ParseValuesPtr = %addr(LdaDS.ScanStrings) + 2; NumOfFiles = f_ParmListCount(LdaDS.SrcFiles); NumOfScanValues = f_ParmListCount(LdaDS.ScanStrings); evalr scDow = %trimr(f_GetDayName()); ‚ // if not case senstitive, covert all to upper case 1b if LdaDS.Case = '*NO '; 2b for cc = 1 to NumOfScanValues; ScanVals(cc) = %xlate(lo: up: ScanVals(cc)); 2e endfor; 1e endif; Ind.ShowSrcData = (LdaDS.IfContains = '*ANY ' or LdaDS.IfContains = '*ALL '); FromPos = LdaDS.From; ToPos = LdaDS.To; 1b if ToPos > %len(SrcCase); ToPos = %len(SrcCase); 1e endif; ToPosSave = ToPos; ScanLen = (ToPos - FromPos) + 1; ‚ //--------------------------------------------------------- 1b if LdaDS.OutPut = '* '; LdaDS.OutPut = '*PRINT '; 1e endif; ‚ //--------------------------------------------------------- ‚ // Print selected files/Lib/mbr names at top of report. ‚ // Spin down number of offsets to List entries. ‚ // Inner List pointer (start of List + displacement ‚ // pointer) moves DS through List 1b if LdaDS.OutPut = '*PRINT '; f_OvrPrtf('JCRSMLTP ': *OMIT: ScanVals(1)); open JCRSMLTP; write PrtHead1; pListLvl = LdaDS.ListLvl; pScanCmnt = LdaDS.ScanComment; DisplacePtr = SrcListPtr; 2b for ForCount2 = 1 to NumOfFiles; DisplacePtr += 2; InnerListPtr = SrcListPtr + Displacement; write PrtHead2; Ind.HeadingSwitch = *on; 2e endfor; write PrtSpaceA1; ‚ //--------------------------------------------------------- ‚ // Print selected strings in heading of report. ‚ // Load verbiage for set definition parameter. 2b if LdaDS.IfContains = '*ALL '; setverbage = 'Member contains ALL selected search strings'; 2x elseif LdaDS.IfContains = '*ANY '; setverbage = 'Member contains ANY of the search strings'; 2x elseif LdaDS.IfContains = '*NONE'; setverbage = 'Member contains NONE of the search strings'; 2x elseif LdaDS.IfContains = '*NOTALL'; setverbage = 'Member contains some but not all strings'; 2e endif; Ind.HeadingSwitch = *off; 2b for aa = 1 to NumOfScanValues; scnstr = ScanVals(aa); write PrtHead3; Ind.HeadingSwitch = *on; 2e endfor; write PrtSpaceA1; write PrtHead4; ‚ //--------------------------------------------------------- ‚ // open outfile and load scan value file fields 1x else; extOmbr = %subst(LdaDS.OutMbrOpt: 3: 10); extOfile = f_GetQual(LdaDS.OutFileQual); open JCRSMLTF; date = %date(); time = %time(); SCANSET = LdaDS.IfContains; ScanStrOutFile(*) = *blanks; 2b for aa = 1 to NumOfScanValues; ScanStrOutFile(aa) = ScanVals(aa); 2e endfor; 1e endif; ‚ // Create user space/retrieve pointer to user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); ‚ // load user space with List of mbr names for selected files DisplacePtr = SrcListPtr; 1b for ForCount2 = 1 to NumOfFiles; DisplacePtr += 2; InnerListPtr = SrcListPtr + Displacement; extIfile = f_GetQual(SrcFil + SrcLib); ‚ // member List API callp QUSLMBR( UserSpaceName: 'MBRL0200': SrcFil + SrcLib: SrcMbr: '0': ApiErrDS); 2b if ApiErrDS.BytesReturned = 0; //no errors on return ‚ // Process members in user space, ‚ // override input file to each member QuslmbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 3b for ForCount = 1 to GenericHeader.ListEntryCount; RtvMbr = QuslmbrDS.MbrName; ‚ // member type selection 4b if SrcMbrTyp = '*ALL ' or SrcMbrTyp = QuslmbrDS.MbrType; SrcTxt = QuslmbrDS.Text; Mbrtype = QuslmbrDS.MbrType; open MBRSRC; exsr srReadMbr; close MBRSRC; ‚ // Note that exclusive options, *NONE and *NOTALL ‚ // can only be processed after entire member is read. 5b if LdaDS.IfContains = '*NONE ' and IsNoneFound; exsr srPrintLine; 5x elseif LdaDS.IfContains = '*NOTALL ' and IsSomeFound; exsr srPrintLine; 5e endif; 4e endif; QuslmbrPtr += GenericHeader.ListEntrySize; 3e endfor; 2e endif; 1e endfor; 1b if LdaDS.OutPut = '*PRINT '; close JCRSMLTP; f_Dltovr('JCRSMLTP '); 1x else; close JCRSMLTF; 1e endif; *inlr = *on; return; ‚ //--------------------------------------------------------- ‚ // read through member scanning for each find string selected. ‚ // For inclusive sets (*ALL *ANY), keep track of ‚ // RRNs that will be used later for printing. begsr srReadMbr; IsFoundArry(*) = *off; IsAllFound = *off; IsSomeFound = *off; IsNoneFound = *on; rrn = 0; cc = 0; read MBRSRC; 1b dow not %eof; rrn += 1; ‚ // If LdaDS.ScanComment = *NO , do not consider comment lines. 2b if LdaDS.ScanComment = '*YES' OR (LdaDS.ScanComment = '*NO ' and not (SrcComment = '*' or SrcCommentFree = '//')) OR (LdaDS.ScanComment = '*ONLY ' and (SrcComment = '*' or SrcCommentFree = '//')); 3b if InfdsRecLen = 92 or LdaDS.ScanComment = '*NO '; %subst(SrcDta:81) = *blanks; // blank out inline comments 3e endif; 3b if LdaDS.Case = '*NO '; SrcCase = %xlate(lo: up: Srcdta); 3x else; SrcCase = SrcDta; 3e endif; ‚ // If scan comment = *NO, then blank out comment sections of source 3b if LdaDS.ScanComment = '*NO '; 4b if QuslmbrDS.MbrType = 'RPGLE ' or QuslmbrDS.MbrType = 'SQLRPGLE '; aa = %scan('//': SrcCase); 5b if aa > 0; %subst(SrcCase:aa) = *blanks; 5e endif; 4x elseif QuslmbrDS.MbrType = 'CLP ' or QuslmbrDS.MbrType = 'CLLE ' or QuslmbrDS.MbrType = 'CMD ' or QuslmbrDS.MbrType = 'CLP38 '; ‚ // blank out all comments before scanning. SrcCase = f_BlankCommentsCL(SrcCase); 4e endif; 3e endif; ‚ //--------------------------------------------------------- 3b for aa = 1 to NumOfScanValues; //NUM OF STRINGS bb = 0; bb = %scan(ScanVals(aa): %subst(SrcCase: FromPos: ScanLen) :1); 4b if bb > 0; ‚ //--------------------------------------------------------- ‚ // If set = *ANY. Meaning include if source ‚ // contains any strings defined. ‚ // If level is set to *FIRST, ‚ // print and leave when 1st one is found. 5b if LdaDS.IfContains = '*ANY '; 6b if cc = 0; cc = 1; 6e endif; exsr srPrintLine; 6b if LdaDS.ListLvl = '*FIRST'; LV leavesr; 6x else; 3v leave; 6e endif; ‚ //--------------------------------------------------------- ‚ // If set is defined as *ALL. ‚ // Exsr subroutine to see if all strings are present ‚ // until all strings are determined to be in Mbr. 5x elseif LdaDS.IfContains = '*ALL '; ‚ //--------------------------------------------------------- ‚ // If set is defined as *ALL. Meaning include if source contains ‚ // ALL strings defined. ‚ // The idea is spin through member and see if all strings are present. ‚ // If user has selected to view only *FIRST occurrence of each string, ‚ // then I have to only load RRN of each first occurrence into array. ‚ // If user has selected *ALL occurrences of string, then I have ‚ // to load all rrns, until I know that all strings are present, ‚ // then I can just read and print reset. ‚ //--------------------------------------------------------- 6b if not IsAllFound; 7b if cc = 0; ScanRRN(1) = RRN; cc = 1; 7x else; 8b if not (LdaDS.ListLvl = '*FIRST' and IsFoundArry(aa) = *on); 9b if ScanRRN(cc) <> RRN; //no dupes cc += 1; ScanRRN(cc) = RRN; 9e endif; 8e endif; 7e endif; IsFoundArry(aa) = *on; ‚ //--------------------------------------------------------- ‚ // Determine if all strings have been found. ‚ // If all have been found, save current RRN, spin back through RRN array ‚ // and output all records that have been previously found. ‚ // Reset file to current record and continue. IsAllFound = *on; 7b for yy = 1 to NumOfScanValues; 8b if IsFoundArry(yy) = *off; IsAllFound = *off; 7v leave; 8e endif; 7e endfor; 7b if IsAllFound; CurrentRRN = RRN; 8b for yy = 1 to cc; rrn = ScanRRN(yy); chain rrn MBRSRC; exsr srPrintLine; 8e endfor; RRN = CurrentRRN; chain rrn MBRSRC; 7e endif; ‚ //--------------------------------------------------------- 7b if IsAllFound and LdaDS.ListLvl = '*FIRST'; LV leavesr; 7e endif; 6x else; exsr srPrintLine; 3v leave; 6e endif; ‚ //--------------------------------------------------------- ‚ // If set is defined as *NOTALL ‚ // When first scan is found, set flag to off ‚ // and exit subroutine. 5x elseif LdaDS.IfContains = '*NONE '; IsNoneFound = *off; LV leavesr; ‚ //--------------------------------------------------------- ‚ // If set is defined as *SOME, ‚ // As each string is found, set indicator off and exit subroutine. 5x elseif LdaDS.IfContains = '*NOTALL'; IsFoundArry(aa) = *on; ‚ //--------------------------------------------------------- ‚ // Determine if all string have been found, ‚ // set IsSomeFound = *off and exit read process. IsSomeFound = *on; IsAllFound = *on; 6b for yy = 1 to NumOfScanValues; 7b if IsFoundArry(yy) = *off; IsAllFound = *off; 7e endif; 6e endfor; 6b if IsAllFound; IsSomeFound = *off; LV leavesr; 6e endif; 5e endif; 4e endif; 3e endfor; 2e endif; read MBRSRC; 1e enddo; endsr; ‚ //--------------------------------------------------------- ‚ // Print detail line. begsr srPrintLine; Ind.IsChangedDate = (SrcChgdat > 0); 1b if LdaDS.OutPut = '*PRINT '; SrcDta80 = SrcDta; write PrtDetail; 1x else; 2b if Ind.ShowSrcData = *off; SrcSeq = 0; SrcChgdat = 0; clear SrcDta; 2e endif; write JCRSMLTFR; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRSMLTRD - load optional default list of source files. // Idea here is there may be multiple files you wish to search together as a group. This // program lets you associate a group of source files with a keyword in SRCFILE parm. // Example: say you have value *DFTLIST defined in JCRSMLT command, then you could // come here and say, IF *DFTLIST, then I want to search QRPGLESRC, QRPGSRC, QCLSRC in // library XYZ. Please note, I have several of mine already programmed in, feel to change // these to whatever values will work best for you. //--------------------------------------------------------- // Use value in SRCFILE parm to determine which list to load. // Load hard coded file names into arrays // Process arrays into IBM list processing format. // Return IBM list format in parm. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D FileName s 10a dim(9) D LibName s 10a dim(9) D MbrName s 10a dim(9) D MbrTyp s 10a dim(9) D SelectVal s 10a D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(p_SrcListPtr) D OffsetToEntry s 5i 0 D xx s 5i 0 D IsLoaded s n //--*DATA STRUCTURES--------------------------------------- D InnerList ds based(InnerListPtr) qualified D NumElems 5i 0 D SrcFil 10 overlay(InnerList:3) D SrcLib 10 overlay(InnerList:*next) D SrcMbr 10 overlay(InnerList:*next) D SrcTyp 10 overlay(InnerList:*next) D LdaDS ds 1024 DTAARA(*LDA) qualified D p_SrcList 398a overlay(LdaDS:1) //--*ENTRY PARMS *NONE* ----------------------------------- // LDA is used for long parms //--------------------------------------------------------- /free in LdaDS; SelectVal = %subst(LdaDS.p_SrcList: 7: 10); IsLoaded = *off; // Load list values for various selected keywords. // HISTORY - historical source code 1b if SelectVal = '*HISTORY '; IsLoaded = *on; 2b for xx = 1 to 9; LibName(xx) = 'YOUR_LIB '; MbrName(xx) = '*ALL '; MbrTyp(xx) = '*ALL '; 2e endfor; FileName(1) = 'YOUR_SRCF1'; FileName(2) = 'YOUR_SRCF3'; FileName(3) = ' '; 1e endif; //--------------------------------------------------------- // No human modifiable code beyond this point. //--------------------------------------------------------- // Now fun begins. Load from arrays into format used // by IBM command list processing variable. // CL manual tries to explain it. (good luck!) // First value required is number of files in list. // Next variable number string of values are offsets to list entries // List entries start with number of elements in entry //--------------------------------------------------------- xx = 0; 1b if IsLoaded; p_SrcListPtr = %addr(LdaDS.p_SrcList); //to entry parm DisplacePtr = p_SrcListPtr; //start of displace 2b dou xx = 9 or FileName(xx) = *blanks; xx += 1; 2e enddo; 2b if FileName(xx) = *blanks; xx -= 1; 2e endif; NumOfLists = xx; //--------------------------------------------------------- // This is tricky. For each file in list, I have to load 2 digit binary field in // next sequential position of parm. Value of this binary field is offset from start // of field to beginning of entry. Problem is offset to first entry changes with // count of 2 digit binary fields I have to load as offsets to other entries. offsetToEntry = ((NumOfLists - 1) * 2) + 4; 2b for xx = 1 to NumOfLists; DisplacePtr += 2; Displacement = OffsetToEntry; InnerListPtr = p_SrcListPtr + Displacement; InnerList.NumElems = 3; InnerList.SrcFil = FileName(xx); InnerList.SrcLib = LibName(xx); InnerList.SrcMbr = MbrName(xx); InnerList.SrcTyp = MbrTyp(xx); OffsetToEntry += 42; 2e endfor; 1e endif; out LdaDS; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRSMLTRS - Scan mult source file/mbrs - job submitter // Save existing *LDA // Load long list variables to *LDA // SBMJOB // Reset *LDA to previous value. // Normally, I HATE *LDA!! (that would make a good bumper sticker). But // given IBM's bungling of long parms on SBMJOB, there was no other good choice. //--------------------------------------------------------- /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_SbmJob /Define f_Pgm /Define f_RtvMsgAPI /Define f_SndCompMsg /Define f_System /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D SavLda s like(LdaDS) //--*DATA STRUCTURES--------------------------------------- D LdaDS uds DTAARA(*LDA) qualified D SrcFiles 398a D ScanStrings 272a D Case 4a D IfContains 7a D Listlvl 6a D ScanComment 5a D From 3u 0 D To 3u 0 D Output 8a D OutFileQual 20a D OutMbrOpt 22a //--*CALL PROTOTYPES--------------------------------------- D p_JCRSMLTRD PR extpgm('JCRSMLTRD') CHECK PREDEFINED LST D p_JCRSMLTR PR extpgm('JCRSMLTR ') //--*ENTRY PARMS------------------------------------------- D p_JCRSMLTRS PR extpgm('JCRSMLTRS') D 272a D 4a D 7a D 398a D 6a D 5a D 3p 0 D 3p 0 D 8a D 20a D 22a D p_JCRSMLTRS PI opdesc D p_ScanStrings 272a D p_Case 4a D p_IfContains 7a D p_SrcFiles 398a D p_Listlvl 6a D p_ScanComment 5a D p_From 3p 0 D p_To 3p 0 D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free SavLda = LdaDs; LdaDs.srcFiles = p_SrcFiles; LdaDS.Case = p_Case; LdaDS.IfContains = p_IfContains; LdaDS.SrcFiles = p_SrcFiles; LdaDS.Listlvl = p_Listlvl; LdaDS.ScanComment = p_ScanComment; LdaDS.From = p_From; LdaDS.To = p_To; LdaDS.Output = p_Output; LdaDS.OutFileQual = p_OutFileQual; LdaDS.OutMbrOpt = p_OutMbrOpt; LdaDS.ScanStrings = p_ScanStrings; out LdaDS; callp p_JCRSMLTRD(); // CHECK PREDEFINED LISTS 1b if p_Output = '* '; callp p_JCRSMLTR(); // interactive show spooled file f_System('DSPSPLF FILE(JCRSMLTP) SPLNBR(*LAST)'); 1x else; f_SbmJob( f_Pgm('JCRSMLTR ': '*LIBL '): 'QTXTSRCH '); f_SndCompMsg(f_RtvMsgApi('CPC1221':ApiErrDS.MsgReplaceVal)); 1e endif; // replace overlaid LDA LdaDs = SavLda; out LdaDS; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRSMLTRV - Validity checking program for list elements //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_SndEscapeMsg /Define f_OutFileCrtDupObj /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D Displacement s 5i 0 based(DisplacePtr) D NumOfLists s 5i 0 based(p_SrcFilesPtr) D ForCount s 3u 0 //--*DATA STRUCTURES--------------------------------------- // Get number of source files and source file/lib/Mbr names D InnerList ds based(InnerListPtr) qualified D SrcFil 10a overlay(InnerList:3) D SrcLib 10a overlay(InnerList:*next) //--*ENTRY PARMS------------------------------------------- D p_JCRSMLTRV PR extpgm('JCRSMLTRV') D 272a D 4a D 7a D 398a D 6a D 5a D 3p 0 D 3p 0 D 8a D 20a D 22a D p_JCRSMLTRV PI D p_ScanStrings 272a D p_Case 4a D p_IfContains 7a D p_SrcFiles 398a D p_Listlvl 6a D p_ScanComment 5a D p_From 3p 0 D p_To 3p 0 D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free // Use pointers to overlay input parms with DS values. // Spin down number of offsets to list entries. // Inner list pointer (start of list + displacement pointer) // moves DS through list. //--------------------------------------------------------- p_SrcFilesPtr = %addr(p_SrcFiles); DisplacePtr = p_SrcFilesPtr; 1b if NumOfLists = 0; f_SndEscapeMsg('*Must select at least one SOURCE FILE.'); 1e endif; 1b for ForCount = 1 to NumOfLists; DisplacePtr += 2; InnerListPtr = p_SrcFilesPtr + Displacement; 2b if %subst(InnerList.SrcFil: 1: 1) <> '*'; f_CheckMbr(InnerList.SrcFil + InnerList.SrcLib:'*FIRST '); 2e endif; 1e endfor; // Check OUTFILE parameter 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRSMLTF '); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSPELL - Return list of suggested words - Spelling API jcr */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Correctly Spelled Words') PARM KWD(WORD) TYPE(*CHAR) LEN(25) MIN(1) + CASE(*MIXED) PROMPT('Spelling check word:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRSPELL'.List Correctly Spelled Words (JCRSPELL) - Help .*-------------------------------------------------------------------- :P.This JCR command spell checks selected word. If word is not spelled correctly, a long text API window shows list of suggested words. Note: I am using United States dictionary from Office. You can do wrkobj *all/*all *SDADCT to see other dictionaries.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSPELL/WORD'.Spelling check word - Help :XH3.Spelling check word (WORD) :P.Word to be checked for correct spelling.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRSPELLR - spelling checker / alternate spelling suggestions // Must have as400 Office installed! // Call passing 'misspeeled' word as parameter to return list of words that it // thinks you meant to spell. // Call office API QTWAIDSP to check spelling of word and return list of suggested words. // Call long text API QUILNGTX as quick method to display results //--------------------------------------------------------- /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_RtvMsgAPI /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D xx s 3u 0 D TextString s 6800a D TextStringLen s 10i 0 inz(6800) D LineOfText s 68a dim(100) based(ptr) D ptr s * inz(%addr(TextString)) D MessageID s 7a D MessageFile s 20a //--*DATA STRUCTURES--------------------------------------- D WordEntryDS ds qualified based(ptr1) D OffSet 10i 0 overlay(WordEntryDS:1) D Length 10i 0 overlay(WordEntryDS:5) D OutDictNum 10i 0 overlay(WordEntryDS:9) D inDictDS ds qualified D OffSet 10i 0 overlay(inDictDS:1) inz(12) D Number 10i 0 overlay(inDictDS:5) inz(1) D Reserved 10i 0 overlay(inDictDS:9) inz D Name 20a overlay(inDictDS:13) D OutDictDS ds qualified D BytesReturned 10i 0 overlay(OutDictDS:1) D BytesAvail 10i 0 overlay(OutDictDS:5) D Name 10a overlay(OutDictDS:9) D Lib 10a overlay(OutDictDS:19) // header for spelling aid API D AIDW0100DS ds 4000 qualified inz D BytesReturned 10i 0 overlay(AIDW0100DS:1) D BytesAvail 10i 0 overlay(AIDW0100DS:5) D NumWordsReturn 10i 0 overlay(AIDW0100DS:9) D NumWordsAvail 10i 0 overlay(AIDW0100DS:13) D OffsetToInput 10i 0 overlay(AIDW0100DS:17) D LenofInput 10i 0 overlay(AIDW0100DS:21) D MisSpelled 1a overlay(AIDW0100DS:25) D Reserved1 3a overlay(AIDW0100DS:26) D OffsetToWords 10i 0 overlay(AIDW0100DS:29) D LenOfWordEntry 10i 0 overlay(AIDW0100DS:33) D Reserved2 10i 0 overlay(AIDW0100DS:37) D Reserved3 4000a overlay(AIDW0100DS:1) //--*CALL PROTOTYPES--------------------------------------- D Qtwaidsp PR extpgm('QTWAIDSP') Spelling Aid API Db like(AIDW0100DS) D 10i 0 const D 8a const Api Format D 50a const word D 10i 0 const Length Of word Db like(InDictDS) input dictionary D 10i 0 const length Db like(OutDictDS) output dictionary D 10i 0 const length Db like(ApiErrDS) Error Parm D QUILNGTX PR extpgm('QUILNGTX') Long Text D 6800a options(*varsize) Text D 10i 0 Text Length D 7a Message ID D 20a Message File Name Db like(ApiErrDS) Error Parm //--*ENTRY PARMS------------------------------------------- D p_JCRSPELLR PR EXTPGM('JCRSPELLR') D 25a D p_JCRSPELLR PI D p_Word 25a //--------------------------------------------------------- /free inDictDS.Name = 'US QDCT '; callp QTWAIDSP( AIDW0100DS: %size(AIDW0100DS): 'AIDW0100' : p_Word: %len(%trimr(p_Word)): InDictDS: 172: OutDictDS: 28: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; //error occurred LineOfText(1) = ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal)); 1x else; LineOfText(1) = 'Original Word: ' + p_word; 2b if AIDW0100DS.MisSpelled = x'01'; ptr1 = %addr(AIDW0100DS) + AIDW0100DS.OffsetToWords; 3b for xx = 1 to AIDW0100DS.NumWordsReturn; LineOfText(xx+1) = %subst(AIDW0100DS: WordEntryDS.Offset+1: WordEntryDS.Length); ptr1 += AIDW0100DS.LenOfWordEntry; 3e endfor; 2x elseif AIDW0100DS.MisSpelled = x'00'; LineOfText(1) = %trimr(LineOfText(1))+' is spelled correctly.'; 2e endif; 1e endif; //--------------------------------------------------------- // execute long text API QUILNGTX( TextString: TextStringLen: MessageID: MessageFile: ApiErrDS); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSPLF - List spool files with Options - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Spool Files with Options') PARM KWD(SPLFNAME) TYPE(*GENERIC) LEN(10) + RSTD(*NO) DFT(*ALL) SPCVAL((*ALL)) PROMPT('Spooled File Name:') PARM KWD(USERDATA) TYPE(*CHAR) LEN(10) RSTD(*NO) + DFT(*ALL) SPCVAL((*ALL)) PROMPT('User data:') PARM KWD(OUTQ) TYPE(OUTQ) MIN(0) PROMPT('Outq name:') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(*ALL) SPCVAL((*ALL)) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(USER) TYPE(*NAME) LEN(10) RSTD(*NO) + DFT(*CURRENT) SPCVAL((*CURRENT) (*ALL)) PROMPT('User:') PARM KWD(FORMTYPE) TYPE(*NAME) LEN(10) RSTD(*NO) + DFT(*ALL) SPCVAL((*STD) (*ALL)) PROMPT('Form type:') ]]> v5r4 *---------------------------------------------------------------- * JCRSPLFD - List spool files with Options - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA11 CA12 CF13 A PRINT INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SHEADER OVERLAY A 1 2'JCRSPLF' COLOR(BLU) A 1 23'List Spool Files with Options' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Type options, press Enter.' A COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 4'1=SndNet' COLOR(BLU) A SCOPTIONS 63A O 3 15COLOR(BLU) A 4 4'6=Release' COLOR(BLU) A 4 15'7=Duplicate' COLOR(BLU) A 4 28'8=Attributes' COLOR(BLU) A 4 49'9=Copy to PF' COLOR(BLU) *---------------------------------------------------------------- A R SBFDTA1 SFL A 11 SFLNXTCHG A AOPTIONS1 1A P A SCSPLNO 6S 0H A SCJOBNAME 10A H A SCJOBNO 6A H A INTJOBID 16A H A INTSPLFID 16A H A SBFOPTION 1A B 7 3DSPATR(&AOPTIONS1) A SCSPLFNAME 10A O 7 7 A SCUSERID 10A O 7 19 A SCOUTQ 10A O 7 31 A SCUSRDTA 10A O 7 42 A SCSTATUS 10A O 7 54 A SCNUMPAGES 5Y 0O 7 65EDTCDE(4) A SCCURPAGE 5Y 0O 7 71EDTCDE(4) A SCCOPIES 3Y 0O 7 77EDTCDE(4) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(15) SFLSIZ(495) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 5 31'Device or' DSPATR(HI) A 5 66'Total' DSPATR(HI) A 5 73'Cur' DSPATR(HI) A 6 2'Opt' DSPATR(HI) A 6 7'File' DSPATR(HI) A 6 19'User' DSPATR(HI) A 6 31'Queue' DSPATR(HI) A 6 42'User Data' DSPATR(HI) A 6 54'Sts' DSPATR(HI) A 6 66'Pages' DSPATR(HI) A 6 72'Page' DSPATR(HI) A 6 77'Cpy' DSPATR(HI) *---------------------------------------------------------------- A R SBFDTA2 SFL A 11 SFLNXTCHG A AOPTIONS2 1A P A SCSPLNO 6S 0H A SCJOBNAME 10A H A SCJOBNO 6A H A INTJOBID 16A H A INTSPLFID 16A H A SBFOPTION 1A B 7 3DSPATR(&AOPTIONS2) A SCSPLFNAME 10A O 7 7 A SCUSERID 10A O 7 19 A SCFORMTYPE 10A O 7 31 A SCPRIORITY 2A O 7 43 A SCSPLFDATE 8A O 7 48 A SCSPLFTIME 8A O 7 58 *---------------------------------------------------------------- A R SBFCTL2 SFLCTL(SBFDTA2) OVERLAY A SFLPAG(15) SFLSIZ(495) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 5 48'Creation' DSPATR(HI) A 5 58'Creation' DSPATR(HI) A 6 2'Opt' DSPATR(HI) A 6 7'File' DSPATR(HI) A 6 19'User' DSPATR(HI) A 6 31'Form Type' DSPATR(HI) A 6 43'Pty' DSPATR(HI) A 6 48'Date' DSPATR(HI) A 6 58'Time' DSPATR(HI) *---------------------------------------------------------------- A R SBFDTA3 SFL A 11 SFLNXTCHG A AOPTIONS3 1A P A INTJOBID 16A H A INTSPLFID 16A H A SBFOPTION 1A B 7 3DSPATR(&AOPTIONS3) A SCSPLFNAME 10A O 7 7 A SCSPLNO 6Y 0O 7 19EDTCDE(4) A SCJOBNAME 10A O 7 27 A SCUSERID 10A O 7 38 A SCJOBNO 6A O 7 50 *---------------------------------------------------------------- A R SBFCTL3 SFLCTL(SBFDTA3) OVERLAY A SFLPAG(15) SFLSIZ(0495) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 5 19'File' DSPATR(HI) A 6 2'Opt' DSPATR(HI) A 6 7'File' DSPATR(HI) A 6 19'Nbr' DSPATR(HI) A 6 27'Job' DSPATR(HI) A 6 38'User' DSPATR(HI) A 6 50'Number' DSPATR(HI) *---------------------------------------------------------------- A R SBFDTA4 SFL A 11 SFLNXTCHG A AOPTIONS4 1A P A INTJOBID 16A H A INTSPLFID 16A H A SBFOPTION 1A B 7 3DSPATR(&AOPTIONS4) A SCSPLFNAME 10A O 7 7 A SCOUTQ 10A O 7 19 A SCOUTQLIB 10A O 7 30 A SCASP 3Y 0O 7 46EDTCDE(4) A SCLASTUSED 8A O 7 51 A SCFILESIZE 9Y 0O 7 60EDTCDE(4) *---------------------------------------------------------------- A R SBFCTL4 SFLCTL(SBFDTA4) OVERLAY A SFLPAG(15) SFLSIZ(0495) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 5 51'Last' DSPATR(HI) A 5 63'File' DSPATR(HI) A 6 2'Opt' DSPATR(HI) A 6 7'File' DSPATR(HI) A 6 19'Queue' DSPATR(HI) A 6 30'Library' DSPATR(HI) A 6 46'ASP' DSPATR(HI) A 6 51'Used' DSPATR(HI) A 6 63'Size(K)' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 20'F5=Refresh' COLOR(BLU) A 23 34'F11=View' COLOR(BLU) A NEXTVIEW 1S 0O 23 43COLOR(BLU) A 23 49'F13=Repeat' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 *---------------------------------------------------------------- * JCRSPLFD2 - List spool files with Options-duplicate splf - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A 1 2'JCRSPLFR2' COLOR(BLU) A 1 23'Duplicate Spooled File with Change- A s' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 27'Device or' DSPATR(HI) A 3 52'Total' DSPATR(HI) A 4 3'File' DSPATR(HI) A 4 15'User' DSPATR(HI) A 4 27'Queue' DSPATR(HI) A 4 39'User Data' DSPATR(HI) A 4 52'Pages' DSPATR(HI) A 4 59'Copy' DSPATR(HI) A SCSPLNAM 10A O 5 3 A SCUSRID 10A O 5 15 A SCQUEUE 10A O 5 27 A SCUSERDTA 10A O 5 39 A SCPAGNBR 5Y 0O 5 52EDTCDE(4) A SCCOPIES 3Y 0O 5 60EDTCDE(4) A 7 3'OverRide Spooled File Attributes f- A or Duplicate Spooled File:' A DSPATR(HI) A 9 3'Page Rotation:' DSPATR(HI) A SCPAGEROT 3Y 0B 9 18EDTCDE(N) A 9 25'-1=*Auto fit to paper' A 10 25'-2=*Devd device default' A 11 25'-3=*Cor should auto rotate to potr- A ait' A 12 26'0=No Rotation' A 13 25'90, 180, 270 = degrees clockwise r- A otation' A 15 10'Duplex:' DSPATR(HI) A SCDUPLEX 1A B 15 18 A 15 24'Hold:' DSPATR(HI) A SCHOLD 1A B 15 30 A 15 34'Save:' DSPATR(HI) A SCSAVE 1A B 15 40 A 15 43'(Y or N)' A 16 2'Lines per Inch:' DSPATR(HI) A SCLPI 3Y 0B 16 18EDTCDE(4) A 16 24'Characters per inch:' DSPATR(HI) A SCCPI 3Y 0B 16 45EDTCDE(4) A 17 3'Number Copies:' DSPATR(HI) A SCNUMCOPYS 3Y 0B 17 18EDTCDE(4) A 18 12'Outq:' DSPATR(HI) A SCOUTQ 10A B 18 18 A 19 7'User Data:' DSPATR(HI) A SCUSRDTA 10A B 19 18 A 21 3'Front Overlay:' DSPATR(HI) A SCFOVERLAY 10A B 21 18 A 21 34'Front Overlay Library:' DSPATR(HI) A SCFOVERLIB 10A B 21 57 A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRSPLF'.List Spool Files with Options (JCRSPLF) - Help .*-------------------------------------------------------------------- :P.This JCR command loads subfile with list of spooled files that meet your selection criteria. From the subfile, you can select various options to perform. Program uses SPLF0030 format which is like millions of times faster than WRKSPLF for large sets of files.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSPLF/SPLFNAME'.Spooled File Name - Help :XH3.Spooled File Name (SPLFNAME) :P.Spooled file name/generic*/*ALL to use as list filter.:EHELP. :HELP name='JCRSPLF/USERDATA'.User Data - Help :XH3.User Data (USERDATA) :P.Spooled file user data filter. :PARML.:PT.:PK def.*ALL:EPK.:PD.Do not filter on user data. :PT.user-data-name :PD.Enter user data string to select.:EPARML.:EHELP. :HELP name='JCRSPLF/OUTQ'.Outq - Help :XH3.Outq (OUTQ) :P.Specify name of outq to search for selected spooled files.:EHELP. :HELP name='JCRSPLF/USER'.User - Help :XH3.User (USER) :P.Select spooled files for this user profile. :PARML.:PT.:PK def.*CURRENT:EPK.:PD.Select from spooled files of signed-on user. :PT.:PK.*ALL:EPK.:PD.Select from spooled files of all users. :PT.user-profile-name :PD.Enter name of user profile to select. :EPARML.:EHELP. :HELP name='JCRSPLF/FORMTYPE'.Form Type - Help :XH3.Form Type (FORMTYPE) :P.Spooled file form type filter. :PARML.:PT.:PK def.*ALL:EPK.:PD.Do not use form type as filter. :PT.:PK.*STD:EPK.:PD.Select only *STD form types. :PT.form-type-name :PD.Enter name of form type to select.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRSPLFR - List spool files with Options // call Quslspl API to load selected spooled files to user space. // display subfile of selected spooled files. // process options selected from subfile. // Changed presentation to match v6 wrksplf. Except for f10 key, which is the most // ridiculous button I have ever seen. // Uses SPLF0300 format which is way faster than WRKSPLF //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRSPLFD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F sfile(SBFDTA2: rrn) indds(Ind) F sfile(SBFDTA3: rrn) F sfile(SBFDTA4: rrn) //--*STAND ALONE------------------------------------------- D UsrPrf s 10a inz(*user) D OptionSav s like(sbfOption) D SflRcdNbrSav s like(SflRcdNbr) D NextViewSav s 1s 0 D rrnx s 5u 0 D LastRrn s 5u 0 D IsView1 s n D IsView2 s n D IsView3 s n D IsView4 s n D IsOption4 s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Infds /Define f_IsValidObj /Define FunctionKeys /Define Ind /Define Dspatr /Define Quslspl /Define Sds /Define UserSpaceHeaderDS /Define f_RunOptionSplf /Define f_Quscrtus /Define f_GetDayName /Define f_RmvSflMsg /Define f_SndSflMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D SpoolAlpha ds inz D scSplno 6s 0 D aOptions ds control no display D aOptions1 overlay(aOptions:1) D aOptions2 overlay(aOptions:1) D aOptions3 overlay(aOptions:1) D aOptions4 overlay(aOptions:1) //--*ENTRY PARMS------------------------------------------- D p_JCRSPLFR PR extpgm('JCRSPLFR') D 10a D 10a D 20a D 10a D 10a D p_JCRSPLFR PI D p_SplfName 10a D p_UsrDta 10a D p_OutqQual 20a D p_Usrprf 10a D p_Formtyp 10a //--------------------------------------------------------- /free evalr scDow = %trimr(f_GetDayName()); 1b if %subst(p_OutqQual: 1: 4) = '*ALL'; p_OutqQual = '*ALL '; 1e endif; // If generic spooled file name, get length of non-generic name aa = %scan('*':p_SplfName); // create user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); // line up option headings depending on your system IsSndSplf = f_IsValidObj('SNDSPLF ': '*LIBL ': '*CMD'); IsEsend = f_IsValidObj('ESNDMAIL ': 'ESEND ': '*CMD'); 1b if IsSndSplf and IsEsend; scOptions = oE + oS + o2 + o3 + o4 + o5; 1x elseif IsESend; scOptions = oE + o2 +' '+ o3 + o4 + ' ' +o5; 1x elseif IsSndSplf; scOptions = oS + ' '+ o2 +' '+ o3 + o4 + o5; 1x else; scOptions = o2 +' '+ o3 + ' '+ o4 + o5; 1e endif; //--------------------------------------------------------- // Set looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // call API to load user space with spooled file attributes. begsr srRefreshScreen; callp QUSLSPL( UserSpaceName: 'SPLF0300': p_Usrprf: p_OutqQual: p_Formtyp: p_UsrDta: ApiErrDS); //--------------------------------------------------------- // Move through user space to get spooled file attributes. splf0300Ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; 2b if p_SplfName = '*ALL ' or p_SplfName = splf0300DS.SplfName or (aa>0 and %subst(p_SplfName:1:aa-1) = %subst(splf0300DS.SplfName: 1: aa-1)); 3b if splf0300DS.Status = 1; scStatus = 'RDY'; 3x elseif splf0300DS.Status = 2; scStatus = 'OPN'; 3x elseif splf0300DS.Status = 3; scStatus = 'CLO'; 3x elseif splf0300DS.Status = 4; scStatus = 'SAV'; 3x elseif splf0300DS.Status = 5; scStatus = 'WTR'; 3x elseif splf0300DS.Status = 6; scStatus = 'HLD'; 3x elseif splf0300DS.Status = 7; scStatus = 'MSGW'; 3x elseif splf0300DS.Status = 8; scStatus = 'PND'; 3x elseif splf0300DS.Status = 9; scStatus = 'PRT'; 3x elseif splf0300DS.Status = 10; scStatus = 'FIN'; 3x elseif splf0300DS.Status = 11; scStatus = 'SND'; 3x elseif splf0300DS.Status = 12; scStatus = 'DFR'; 3e endif; scSplfName = splf0300DS.SplfName; scNumPages = splf0300DS.PageNum; scCurPage = 0; scCopies = splf0300DS.Copies; scPriority = splf0300DS.Priority; scOutq = splf0300DS.Outq; scOutqLib = splf0300DS.OutqLib; scSplno = splf0300DS.SplfNum; scJobName = splf0300DS.JobName; scUserID = splf0300DS.UserID; scJobNo = splf0300DS.JobNo; scFormType = splf0300DS.FormType; scUsrDta = splf0300DS.UsrDta; scSplfDate = %Char(%Date(splf0300DS.CreateYYMMDD:*YMD0):*MDY/); scLastUsed = scSplfDate; scSplfTime = %Char(%time(splf0300DS.CreateHHMMSS: *HMS0)); scASP = splf0300DS.ASP; scFileSize = (splf0300DS.SplfSize * splf0300DS.MultiplySize) / 1024; clear sbfOption; rrn += 1; if rrn = 9999; leave; endif; write SBFDTA1; write SBFDTA2; write SBFDTA3; write SBFDTA4; 2e endif; splf0300Ptr += GenericHeader.ListEntrySize; 1e endfor; Lastrrn = rrn; //--------------------------------------------------------- // allow user to make selection from subfile. NextView = 2; SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No spooled files match your selections.'); 1e endif; Ind.sfldspctl = *on; //--------------------------------------------------------- 1b if IsRefresh and Ind.sfldsp; 2b if SflRcdNbrSav > rrn; SflRcdNbr = rrn; 2x else; 3b if SflRcdNbrSav = 0; SflRcdNbr = 1; 3x else; SflRcdNbr = SflRcdNbrSav; 3e endif; 2e endif; NextView = NextViewSav; IsRefresh = *off; 1e endif; //--------------------------------------------------------- 1b dow not (InfdsFkey = f03); 2b if InfdsFkey = f11; //CHANGE VIEW NextView += 1; 3b if NextView > 4; NextView = 1; 3e endif; 2e endif; write MSGCTL; write SHEADER; write SFOOTER1; //--------------------------------------------------------- // display various views 1-4. IsView1 = *off; IsView2 = *off; IsView3 = *off; IsView4 = *off; 2b if NextView = 2; exfmt SBFCTL1; IsView1 = *on; 2x elseif NextView = 3; exfmt SBFCTL2; IsView2 = *on; 2x elseif NextView = 4; exfmt SBFCTL3; IsView3 = *on; 2x elseif NextView = 1; exfmt SBFCTL4; IsView4 = *on; 2e endif; 2b if InfdsFkey = f03 or InfdsFkey = f12; IsExitPgm = *on; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); // refresh SflRcdNbr = SflRecNbr; 2b if InfdsFkey = f05; IsRefresh = *on; SflRcdNbrSav = SflRcdNbr; NextViewsav = NextView; Ind.sfldsp = *off; Ind.sfldspctl = *off; aOptions = %bitor(Green:UL); Ind.sflnxtchg = *off; write SBFCTL1; write SBFCTL2; write SBFCTL3; write SBFCTL4; rrn = 0; LV leavesr; 2e endif; // no records 2b if not Ind.sfldsp; 1i iter; 2e endif; // process user requests 2b if IsView1; readc SBFDTA1; 2x elseif IsView2; readc SBFDTA2; 2x elseif IsView3; readc SBFDTA3; 2x elseif IsView4; readc SBFDTA4; 2e endif; 2b dow not %eof; 3b if sbfOption > ' '; IsOption4 = (sbfOption = '4'); //--------------------------------------------------------- 4b if InfdsFkey = f13; exsr srRepeat_Option; 2v leave; 4x else; f_RunOptionSplf( sbfOption: scSplfName : SpoolAlpha: scJobName : scUserID : scJobNo: EmailAddr: ProgId); // update subfile to reflect selected change. aOptions = %bitor(Green:UL); 5b if sbfOption = '3'; scStatus = 'HLD'; 5x elseif sbfOption = '6'; scStatus = 'RLS'; 5e endif; clear sbfOption; 5b if IsView1; update SBFDTA1; 5x elseif IsView2; update SBFDTA2; 5x elseif IsView3; update SBFDTA3; 5x elseif IsView4; update SBFDTA4; 5e endif; // If spooled file is deleted, flag it as deleted in all views. 5b if IsOption4; chain rrn SBFDTA1; clear SBFDTA1; scSplfName = '*deleted'; aOptions = ND; update SBFDTA1; chain rrn SBFDTA2; clear SBFDTA2; scSplfName = '*deleted'; aOptions = ND; update SBFDTA2; chain rrn SBFDTA3; clear SBFDTA3; scSplfName = '*deleted'; aOptions = ND; update SBFDTA3; chain rrn SBFDTA4; clear SBFDTA4; scSplfName = '*deleted'; aOptions = ND; update SBFDTA4; 5e endif; SflRcdNbr = rrn; 4e endif; 3e endif; 3b if IsView1; readc SBFDTA1; 3x elseif IsView2; readc SBFDTA2; 3x elseif IsView3; readc SBFDTA3; 3x elseif IsView4; readc SBFDTA4; 3e endif; 2e enddo; 1e enddo; endsr; //--------------------------------------------------------- // Idea is to make 'repeat' option work same way // it does in PDM. User can select option, then press // f13 to have it repeat to end of subfile. //--------------------------------------------------------- begsr srRepeat_Option; SflRcdNbr = rrn; OptionSav = sbfOption; 1b for rrnx = SflRcdNbr to LastRrn; 2b if IsView1; chain rrnx SBFDTA1; 2x elseif IsView2; chain rrnx SBFDTA2; 2x elseif IsView3; chain rrnx SBFDTA3; 2x elseif IsView4; chain rrnx SBFDTA4; 2e endif; 2b if not %found; 1v leave; 2e endif; Ind.sflnxtchg = *on; sbfOption = OptionSav; 2b if IsView1; update SBFDTA1; 2x elseif IsView2; update SBFDTA2; 2x elseif IsView3; update SBFDTA3; 2x elseif IsView4; update SBFDTA4; 2e endif; 1e endfor; Ind.sflnxtchg = *off; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRSPLFRV - Validity checking program for object //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRSPLFRV PR extpgm('JCRSPLFRV') D 10a D 10a D 20a D 10a D 10a D p_JCRSPLFRV PI D p_SplfName 10a D p_UsrDta 10a D p_OutqQual 20a D p_Usrprf 10a D p_Formtyp 10a //--------------------------------------------------------- /free 1b if not(%subst(p_OutqQual: 1: 10) = '*ALL ' or %subst(p_OutqQual: 1: 10) = *blanks); f_CheckObj(p_OutqQual : '*OUTQ '); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRSPLFR2 - duplicate spooled file with overrides // open existing spooled file. // retrieve attributes from existing spooled file. // create new spooled file from existing spooled file attributes. // write old spooled file data into newly created spooled file. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRSPLFD2 cf e workstn //--*STAND ALONE------------------------------------------- D BufferOrdinal s 10i 0 inz(-1) D p_Splfbin s 10i 0 D SplfHandle1 s 10i 0 D SplfHandle2 s 10i 0 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define UserSpaceHeaderDS /Define Qspclosp /Define Qspgetsp /Define Qspopnsp /Define f_Quscrtus /Define Qusdltus /Define f_SndCompMsg /Define f_GetDayName /Define f_SndStatMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Create spooled file API requires this set of parms D xQusrsplaDS ds 4000 inz D xIntJobId 16a overlay(xQusrsplaDS:17) D xIntSplfId 16a overlay(xQusrsplaDS:33) D xSpflNum 10i 0 overlay(xQusrsplaDS:85) D xFrmType 10a overlay(xQusrsplaDS:89) D xUsrDta 10a overlay(xQusrsplaDS:99) D xHold 10a overlay(xQusrsplaDS:129) D xSave 10a overlay(xQusrsplaDS:139) D xTotPages 10i 0 overlay(xQusrsplaDS:149) D xTotCopy 10i 0 overlay(xQusrsplaDS:173) D xLPI 10i 0 overlay(xQusrsplaDS:181) D xCPI 10i 0 overlay(xQusrsplaDS:185) D xOutq 10a overlay(xQusrsplaDS:191) D xOutqLib 10a overlay(xQusrsplaDS:201) D xPageRotate 10i 0 overlay(xQusrsplaDS:553) D xDuplex 10a overlay(xQusrsplaDS:561) D xFrontOverlay 10a overlay(xQusrsplaDS:737) D xFrontOverLib 10a overlay(xQusrsplaDS:747) //--*CALL PROTOTYPES--------------------------------------- D Qspcrtsp PR extpgm('QSPCRTSP') create spooled file D 10i 0 splf handle Db like(QusrsplaDS) attributes Db like(ApiErrDS) D Qspputsp PR extpgm('QSPPUTSP') put splf data D 10i 0 splf handle D 20a user space Db like(ApiErrDS) D Qusrspla PR extpgm('QUSRSPLA') get splf attributes Db like(QusrsplaDS) receiver D 10i 0 const receiver length D 8a const api format D 26a const qualified job D 16a const internal job id D 16a const internal spool id D 10a const spool file name D 10i 0 const spool file Num Db like(ApiErrDS) //--------------------------------------------------------- // DS of spooled file attributes return variable. D QusrsplaDS DS qualified inz D IntJobId 16a overlay(QusrsplaDS:17) D IntSplfId 16a overlay(QusrsplaDS:33) D JobName 10a overlay(QusrsplaDS:49) D UserID 10a overlay(QusrsplaDS:59) D JobNo 6a overlay(QusrsplaDS:69) D SplfName 10a overlay(QusrsplaDS:75) D SplfNum 10i 0 overlay(QusrsplaDS:85) D FormType 10a overlay(QusrsplaDS:89) D UsrDta 10a overlay(QusrsplaDS:99) D Status 10a overlay(QusrsplaDS:109) D Hold 10a overlay(QusrsplaDS:129) D Save 10a overlay(QusrsplaDS:139) D PageNum 10i 0 overlay(QusrsplaDS:149) D CurPage 10i 0 overlay(QusrsplaDS:153) D Copies 10i 0 overlay(QusrsplaDS:173) D LinesPerInch 10i 0 overlay(QusrsplaDS:181) D CharPerInch 10i 0 overlay(QusrsplaDS:185) D Priority 2a overlay(QusrsplaDS:189) D Outq 10a overlay(QusrsplaDS:191) D OutqLib 10a overlay(QusrsplaDS:201) D CreateYY 2a overlay(QusrsplaDS:212) D CreateMM 2a overlay(QusrsplaDS:214) D CreateDD 2a overlay(QusrsplaDS:216) D CreateTimeHH 2a overlay(QusrsplaDS:218) D CreateTimeMM 2a overlay(QusrsplaDS:220) D CreateTimeSS 2a overlay(QusrsplaDS:222) D PageRotate 10i 0 overlay(QusrsplaDS:553) D Duplex 10a overlay(QusrsplaDS:561) D FrontOverlay 10a overlay(QusrsplaDS:737) D FrontOverLib 10a overlay(QusrsplaDS:747) D LastUsedYY 2a overlay(QusrsplaDS:2871) D LastUSedMM 2a overlay(QusrsplaDS:2873) D LastUsedDD 2a overlay(QusrsplaDS:2875) D ASP 10i 0 overlay(QusrsplaDS:3773) D SplfSize 10i 0 overlay(QusrsplaDS:3777) D MultiplySize 10i 0 overlay(QusrsplaDS:3781) //--*ENTRY PARMS------------------------------------------- D p_JCRSPLFR2 PR extpgm('JCRSPLFR2') D 10a D 10a D 6a D 10a D 6s 0 D p_JCRSPLFR2 PI D p_JobName 10a D p_JobUser 10a D p_JobNumber 6a D p_SplfName 10a D p_SplfNumber 6s 0 //--------------------------------------------------------- /free p_SplfBin = p_SplfNumber; //get into proper format f_SndStatMsg('Processing spooled file ' + %trimr(p_SplfName) + ' ' + %char(p_SplfBin) + ' - in progress'); evalr scDow = %trimr(f_GetDayName()); // load spooled file attributes callp QUSRSPLA( xQusrsplaDS: %size(xQusrsplaDS): 'SPLA0200': p_JobName + p_JobUser + p_JobNumber: ' ': ' ': p_SplfName: p_SplfBin: ApiErrDS); // load spooled file attributes to screen fields. scSplNam = p_SplfName; scUsrid = p_JobUser; scQueue = xoutq; scUserDta = xUsrDta; scUsrDta = xUsrDta; scPagNbr = xTotPages; scCopies = xTotCopy; scNumCopys = xTotCopy; scOutq = xoutq; scPageRot = xPageRotate; scDuplex = %subst(xDuplex: 2: 1); scHold = %subst(xHold: 2: 1); scSave = %subst(xSave: 2: 1); scfOverLay = xFrontOverlay; scfOverLib = xFrontOverLib; scLPI = xLPI; scCPI = xCPI/10; exfmt SCREEN; 1b if *inka or *inkc; callp QUSDLTUS(UserSpaceName : ApiErrDS); *inlr = *on; return; 1e endif; // overlay attributes with screen fields. xUsrDta = scUsrDta; xTotCopy = scNumCopys; xOutq = scOutq; xPageRotate = scPageRot; xFrontOverlay = scfOverLay; xFrontOverLib = scfOverLib; xLPI = scLPI; xCPI = scCPI*10; 1b if scDuplex = 'N'; xDuplex = '*NO '; 1x else; xDuplex = '*YES '; 1e endif; 1b if scHold = 'N'; xHold = '*NO '; 1x else; xHold = '*YES '; 1e endif; 1b if scSave = 'N'; xSave = '*NO '; 1x else; xSave = '*YES '; 1e endif; // create new spooled file callp QSPCRTSP( SplfHandle2: xQusrsplaDS: ApiErrDS); // create user space f_Quscrtus(UserSpaceName); // open input spooled file callp QSPOPNSP( SplfHandle1: '*INT ': xIntJobId: xIntSplfId: '*INT ': 0: -1: ApiErrDS); // get input spooled data callp QSPGETSP( SplfHandle1: UserSpaceName: 'SPFR0200': BufferOrdinal: '*ERROR ': ApiErrDS); // close input spooled file callp QSPCLOSP( SplfHandle1: ApiErrDS); // put spooled file data callp QSPPUTSP( SplfHandle2: UserSpaceName : ApiErrDS); // close output spooled file callp QSPCLOSP( SplfHandle2: ApiErrDS); // delete user space and send completion message callp QUSDLTUS(UserSpaceName : ApiErrDS); f_SndCompMsg('Duplicate spooled file ' + %trimr(p_SplfName) + ' ' + %char(p_SplfBin) + ' - completed'); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSSQL - Scan strsql sessions for sql statements - CMD */ /* */ /* You must be authorized to the DMPSYSOBJ command!! */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Scan Interactive SQL sessions') PARM KWD(USERID) TYPE(*CHAR) LEN(10) + DFT(*CURRENT) MIN(0) MAX(1) PROMPT('User + ID:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSSQLC - Scan strsql sessions for sql statements - CMDPGM */ /* Create PF in qtemp */ /* Dump the system object to print. */ /* Copy spooled file into previously created PF */ /* Call RPG program to extract and display the entries */ /* */ /* You must be authorized to the DMPSYSOBJ command on your system. */ /*--------------------------------------------------------------------------*/ PGM PARM(&I_USERID) DCL VAR(&I_USERID) TYPE(*CHAR) LEN(10) DCL VAR(&OBJECT) TYPE(*CHAR) LEN(17) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Dump + system object SQL session statements - in + progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) IF COND(&I_USERID *EQ '*CURRENT ') + THEN(RTVJOBA USER(&I_USERID)) OVRPRTF FILE(QPSRVDMP) + PRTTXT(' ') + HOLD(*YES) USRDFNOPT(*NONE) USRDFNDTA(*NONE) CRTPF FILE(QTEMP/JCRSSQL) RCDLEN(264) IGCDTA(*YES) + TEXT('JCRSSQL dump object data') SIZE(*NOMAX) MONMSG MSGID(CPF0000) CLRPFM FILE(QTEMP/JCRSSQL) /*--------------------------------------------------------------------------*/ /* DMPSYSOBJ OBJ(ISQLSTxxxxxxxxx*) CONTEXT(QRECOVERY) + */ /* TYPE(19) SUBTYPE(EE) */ /*--------------------------------------------------------------------------*/ CHGVAR VAR(&OBJECT) VALUE('ISQLST' *TCAT &I_USERID + *TCAT '*') DMPSYSOBJ OBJ(&OBJECT) CONTEXT(QRECOVERY) TYPE(19) + SUBTYPE(EE) MONMSG MSGID(CPF3502) EXEC(DO) SNDPGMMSG MSG('No system object for user ' *CAT + &I_USERID *TCAT ' found.') RETURN ENDDO CPYSPLF FILE(QPSRVDMP) TOFILE(QTEMP/JCRSSQL) + SPLNBR(*LAST) MBROPT(*REPLACE) /*--------------------------------------------------------------------------*/ CALL PGM(JCRSSQLR) DLTSPLF FILE(QPSRVDMP) SPLNBR(*LAST) DLTOVR FILE(QPSRVDMP) ENDPGM ]]> v5r4 *---------------------------------------------------------------- * JCRSSQLD - Scan strsql sessions for sql statements - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT A CA03 CA12 INDARA A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) *---------------------------------------------- A R DATA1 SFL A AOPTIONS 1A P A SQLHID 2500 H A SBFOPTION 1A B 5 3 A DSPATR(&AOPTIONS) A VDATA 68A O 5 5 *---------------------------------------------- A R CONTRL1 SFLCTL(DATA1) A SFLSIZ(1717) A SFLPAG(0017) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A CSRLOC(CSRROW CSRCOL) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR *TOP) A CSRROW 3S 0H A CSRCOL 3S 0H A ASCVAL1 1A P A ASCRELAT 1A P A 1 3'JCRSSQL' A COLOR(BLU) A 1 15'Scan STRSQL sessions for SQL state- A ments' A DSPATR(HI) A DSPATR(UL) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 5'Scan for:' A DSPATR(HI) A SCVAL1 15A B 2 15 A DSPATR(&ASCVAL1) A SCRELATION 3A B 2 32 A DSPATR(&ASCRELAT) A SCVAL2 15A B 2 37 A 2 72SYSNAME COLOR(BLU) A 3 5'Statements AND/OR - A ' A DSPATR(HI) A DSPATR(UL) A 4 3'T=Position to Top' A COLOR(BLU) A 4 22'X=eXecute SQL' A COLOR(BLU) *---------------------------------------------- A R KEYS A BLINK A OVERLAY A 23 2'F3=Exit' A COLOR(BLU) A 23 69'F12=Cancel' A COLOR(BLU) *---------------------------------------------- A R MSGSFL SFL A SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) *---------------------------------------------- A R MSGCTL SFLCTL(MSGSFL) A SFLDSP A SFLDSPCTL A SFLINZ A N14 SFLEND A SFLSIZ(0002) A SFLPAG(0001) A PROGID SFLPGMQ(10) ]]> v5r4 //--------------------------------------------------------- // JCRSSQLE - execute selected SQL statements // NOTE: uses *SYS naming convention of LIBRARY/FILE. // // Execute QSQCHKS sql API to verify sql statement syntax. // If error return message with substitution values to caller. // Execute non-select SQL statements via SQL CLI direct interface. // // MJR Martin Rowe - srSELECT subroutine to execute // user utility EXCSQL for SELECT statements. // You can get the EXCSQL utility from www.dbg400.net . //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define SqlCLI /Define System /Define f_RtvMsgAPI /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D Select6 s 6a D Sql_Request s 2500a inz varying //--------------------------------------------------------- // Execute QSQCHKS sql API to verify sql statement syntax. D qsQchks PR extpgm('QSQCHKS') D i_SqlStmt 32767a Const options(*varsize) D i_SqlStmtLen 10i 0 Const D i_NumRcds 10i 0 Const D i_Language 10a Const D i_Options 32767a Const options(*varsize) D o_stmtInf 32767a options(*varsize) D i_StmtInfLen 10i 0 Const D o_numRcdsPrc 10i 0 Db like(ApiErrDS) D SqlOptionDS ds Qualified D NumberOfKeys 10i 0 inz(1) D KeyValue 10i 0 inz(1) D LengthOfData 10i 0 inz(10) D Data 10a inz('*SYS') D SqlStmtInfoDS ds Qualified inz D MsgFile 10a D MsgFileLib 10a D NumberOfStmt 10i 0 D BytesReturned 10i 0 DFirstByteRecNum 10i 0 DFirstByteColNum 10i 0 D LastByteRecNum 10i 0 D LastByteColNum 10i 0 D ErrorRecNum 10i 0 D ErrorColNum 10i 0 D MessageID 7a D SqlState 5a D LenMsgRplTxt 10i 0 D MsgReplaceText 128a //--*ENTRY PARMS------------------------------------------- D p_JCRSSQLE PR extpgm('JCRSSQLE') D 2500a from subfile D 75a return message D p_JCRSSQLE PI D i_ParmSql 2500a D i_ParmRtnMsg 75a //--------------------------------------------------------- /free clear i_ParmRtnMsg; Select6 = %subst(i_ParmSql: 1: 6); Select6 = %xlate(lo: up: Select6); 1b if Select6 = 'SELECT'; exsr srSELECT; 1x else; //--------------------------------------------------------- // Check for valid sql statement. callp Qsqchks( i_ParmSql : %size(i_ParmSql) : 1 : '*NONE' : SqlOptionDS : SqlStmtInfoDS : %size(SqlStmtInfoDS) : sqlNumRcd : ApiErrDS ); 2b if SqlStmtInfoDS.MessageID > *blanks; // load return error message, exit program i_ParmRtnMsg = SqlStmtInfoDS.MessageID + ': ' + f_RtvMsgApi( SqlStmtInfoDS.MessageID: ApiErrDS.MsgReplaceVal: SqlStmtInfoDS.MsgFile + SqlStmtInfoDS.MsgFileLib); *inlr = *on; return; 2e endif; exsr srAllocateSql; // Execute SQL Statement retCode = SQLExecDirect(hstmt : i_ParmSql: SQLNTS ); 2b If retCode <> 0; retCode = SQLError(henv : hdbc : hstmt : %addr(sqlState) : %addr(pfNativeErr) : %addr(szErrMsg) : %size(szErrMsg) : %addr(cbErrMsg) ); i_ParmRtnMsg = %subst(szErrMsg: 1: cbErrMsg); 2e Endif; exsr srDisconnect; 2b if i_ParmRtnMsg = *blanks; i_ParmRtnMsg = 'SQL completed normally.'; 2e endif; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Allocate SQL Environment Handle and ... begsr srAllocateSql; retCode = SQLAllocEnv(%addr(henv)); // Set Environment Attribute envAttr = SQLTRUE; retCOde = SQLSetEnvAttr( henv: SysNaming : %addr(envAttr): 0); // Allocate SQL Connection Handle retCode = SQLAllocConnect( henv : %addr(hdbc) ); retCode = SQLConnect(hdbc : server : SQLNTS : *null : SQLNTS : *null : SQLNTS ); // Set Connection Attribute cOptVal = CommitNone; retCode = SQLSetConnectOption( hdbc : AttrCommit: %addr(cOptVal) ); // Allocate Statement Handle retCode = SQLAllocStmt( hdbc : %addr(hstmt) ); endsr; //--------------------------------------------------------- begsr srDisconnect; retCode = SQLFreeStmt(hstmt : SQLDROP); retCode = SQLDisconnect(hdbc); retCode = SQLFreeConnect(hdbc); retCode = SQLFreeEnv(henv); endsr; //--------------------------------------------------------- // Check if the EXCSQL command is on board, // if so use it to run the SELECT statement // If you do not have EXCSQL, select statements cannot be run. // The EXCSQL utility can be downloaded at www.dbg400.net // This subroutine by Martin Rowe. //--------------------------------------------------------- begsr srSELECT; aa = system('CHKOBJ excsql *cmd'); 1b if aa = 0; // format statement for EXCSQL. double up single quotes inside string Sql_Request = qs + %trimr(i_ParmSql) + ' '; aa = %scan(qs: Sql_Request: 2); 2b dow aa > 0; Sql_Request = %replace(qs + qs: Sql_Request: aa: 1); aa = %scan(qs: Sql_Request: aa + 2); 2e enddo; Sql_Request = Sql_Request + qs; // Allow prompt if small enough to be prompted 2b if %len(Sql_Request) < 513; aa = system('?excsql sql(' + %trim(Sql_Request) + ')'); 3b if aa > 0; i_ParmRtnMsg = 'Error occurred on EXCSQL + command. Please see joblog.'; 3e endif; 2x else; i_ParmRtnMsg = 'SELECT statement too long + to prompt with EXCSQL. 512 char max.'; 2e endif; 1x else; i_ParmRtnMsg = 'SELECT cannot be processed + without EXCSQL.'; 1e endif; endsr; ]]> v5r4 * .*-------------------------------------------------------------------* .* JCRSSQLH - Scan strsql sessions for sql statements - HELP * .*-------------------------------------------------------------------* :PNLGRP. :HELP NAME='JCRSSQL'. Scan Interactive SQL sessions (JCRSSQL) - Help :P.This JCR command searches through your interactive SQL sessions for selected criteria! :P.I have found this utility extremely useful to cut/paste from the subfile into a STRSQL session, or just to see how I previously did something. Choosing option X (eXecute) will attempt to run the SQL. All UPDATE, DELETE, INSERT sqls can be run directly from this utility. See program JCRSSQLE for sql cli interface. :P.To process SELECT statements, you will first need to download the utility EXCSQL from Martin Rowe's website www.dbg400.net . JCRSSQL will detect if EXCSQL is installed on your system. :NT.You must have authority to execute the DMPSYSOBJ command.:ENT. :NT.Due to this utility using a system dump file, it may be operating system sensitive. IBM has been known to change the format of dumps on different release levels. This version works correctly on v5r4 and v6r1.:ENT. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSSQL/USERID'. User ID - Help :XH3.User ID (USERID) :P.Specifies user ID for which the interactive SQL sessions will be retrieved. :PARML. :PT.:PK def.*CURRENT:EPK. :PD.Retrieve interactive SQL sessions for user ID signed on to this session. :PT.user-name :PD.This is cool if you have *ALLOBJ authority. You can pull up other user ID interactive SQL sessions. :EPARML. :EHELP. :EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRSSQLR - Scan strsql sessions for sql statements // // Process the dmpsysobj of your interactive sql commands. The dump consists of your STRSQL // sessions broken in 32 character blocks per record with IBM control characters ALL through // those blocks. The goal here is reconstruct all those short blocks into a single sql // statement. It is going to be deep and very ugly code to extract this. // // End result will be a subfile of sql statements that meet your selection criteria. // // I have found this utility useful to cut/paste from the subfile into a STRSQL session, or // just to see how I previously did something. Choosing option X (eXecute) will attempt to // run the SQL. All UPDATE, DELETE, INSERT sqls can be run directly from this utility. See // program JCRSSQLE for sql cli interface. // // To process SELECT statements, you will first need to download the utility EXCSQL from // Martin Rowe's website www.dbg400.net . JCRSSQL will detect if Martin's utility is // installed on your system. // // Final note: Due to this utility using a system dump file, it may be operating system // sensitive. Meaning IBM has been known to change the format of dumps on different release // levels. This version works correctly on v5r4 and v6r1. Modify code to recognize IGCDTA of // input file and extract depending. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRSSQLD cf e workstn sfile(data1: rrn1) F infds(Infds) indds(Ind) FJCRSSQL if f 264 disk Infds(infds2) F extfile('QTEMP/JCRSSQL') //--*STAND ALONE------------------------------------------- D savScRelation s like(screlation) D savScVal1 s like(scval1) D savScVal2 s like(scval2) D WrkSC s like(sc) D Asterisk s 1a D ConstantPeriod s 50a inz(*all'.') D InPrgVary s 50a inz varying D InProgressMsg s 50a D KeysMsg s 75a D LastStatement s 69a inz('A ')last statement D LongString s 32767a inz varying D RawDumpData s 32a D ScanStart s 64a inz varying D Sql s 2500a inz varying D Sql_and_Msg s 2500a inz varying D SqlKeyWord s 5a D SqlMsg s 67a D SqlWrk s 2500a inz varying D StatementStart s 12a inz('TH') statement begin D UpperCased s 2500a inz varying D NextSc s 10u 0 D PercentComp s 10u 0 D RecordCnt s 10u 0 D rrn1 s 5u 0 D sc s 10u 0 D TestLen s 10u 0 D TwoPercent s 10u 0 D xm s 5u 0 D xx s 5u 0 D IsAllRead s n inz(*off) D IsDoubleByte s n inz(*off) D IsStarted s n inz(*off) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Dspatr /Define Infds /Define FunctionKeys /Define Ind /Define Sds /Define Tstbts /Define f_RmvSflMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_GetRowColumn /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D Infds2 ds D NbrOfRcds 10i 0 overlay(Infds2:156) D MiscFlags 1a overlay(Infds2:196) // Double Byte Character Set - IO data structure D DoubleByteChar ds 264 Qualified inz D NotAuthorized 20a overlay(DoubleByteChar:2) D Asterisk 1a overlay(DoubleByteChar:88) D DumpText 32a overlay(DoubleByteChar:89) // Single Byte Character Set - IO data structure D SingleByteChar ds 264 qualified inz D NotAuthorized 20a overlay(SingleByteChar:1) D Asterisk 1a overlay(SingleByteChar:87) D DumpText 32a overlay(SingleByteChar:88) //--*CALL PROTOTYPES--------------------------------------- D p_JCRSSQLE PR extpgm('JCRSSQLE') RUN SQL D 2500a sql statement D 75a return message //--*ENTRY PARMS------------------------------------------- // *none //--------------------------------------------------------- /free 1b if tstbts(MiscFlags: 6) = 1; IsDoubleByte = *on; 1x else; IsDoubleByte = *off; 1e endif; eval(h) TwoPercent = NbrOfRcds/50; evalr scDow = %trimr(f_GetDayName()); //--------------------------------------------------------- // Prompt user for scan values. //--------------------------------------------------------- 1b dou 1 = 2; /end-free C Showfull tag /free exsr srShowSubfile; 1e enddo; //--------------------------------------------------------- // show subfile / edit check scan requests //--------------------------------------------------------- begsr srShowSubfile; 1b dow not (InfdsFkey = f03); savScVal1 = scval1; savScRelation = screlation; savScVal2 = scval2; Ind.sfldsp = (rrn1 > 0); 2b if not (Ind.sfldsp or isFirstTime); f_SndSflMsg(ProgId: 'No SQL Statements match your selection.'); 2e endif; isFirstTime = *off; Ind.sfldspctl = *on; write msgctl; write keys; exfmt contrl1; 2b if InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; f_RmvSflMsg(ProgId); ascVal1 = %bitor(Green: UL); ascRelat = %bitor(Green: UL); SflRcdNbr = 1; //--------------------------------------------------------- // 1) at least value1 must be entered. // 2) if value2 entered, // relationship must be 'AND' or 'OR ' // 3) if relationship eq 'AND' or 'OR', // value2 must be entered. //--------------------------------------------------------- 2b if scval1 = *blanks; CsrRowColDS = f_GetRowColumn('SCVAL1 ':InfdsFile:InfdsLib:InfdsRcdfmt); ascval1 = %bitor(White: RI); f_SndSflMsg(ProgId: 'Must enter Scan For string'); 1i iter; 2e endif; // and or relationship 2b if scval2 <> *blanks and not (screlation = 'AND' or screlation = 'OR '); CsrRowColDS = f_GetRowColumn('SCRELATION':InfdsFile:InfdsLib:InfdsRcdfmt); ASCRELAT = %bitor(White: RI); f_SndSflMsg(ProgId: 'And/Or must = AND or OR .'); 1i iter; 2e endif; // do not need relationship if factor2 = *blanks 2b if scval2 = *blanks; screlation = *blanks; 2e endif; 2b if not (savScVal1 = scval1 and savScRelation = screlation and savScVal2 = scval2); exsr srReadDumpData; 1i iter; 2e endif; //--------------------------------------------------------- 2b if not Ind.sfldsp; //no records 1i iter; 2e endif; //--------------------------------------------------------- // Process record in the subfile the user has selected. //--------------------------------------------------------- readc data1; 2b dow not %eof; 3b if sbfOption > ' '; SflRcdNbr = rrn1; 4b if sbfOption = 'X'; callp p_JCRSSQLE(SqlHid: KeysMsg); 5b if KeysMsg > *blanks; f_SndSflMsg(ProgId: KeysMsg); 5e endif; 4e endif; clear sbfOption; aOptions = %bitor(Green:UL); update data1; aOptions = ND; 3e endif; readc data1; 2e enddo; 1e enddo; *inlr = *on; return; endsr; //--------------------------------------------------------- // Read down to 1st StatementStart characters. The problem is StatementStart // can be split across 2 two records in the input. // Read 1st record, load into ScanStart // Read Next record, it into ScanStart // Scan for StatementStart. // If NOT found, shift cur RawDumpData to begin of ScanStart and repeat. //--------------------------------------------------------- begsr srReadDumpData; %len(InPrgVary) = 0; %len(LongString) = 0; %len(Sql) = 0; %len(Sql_and_Msg) = 0; %len(SqlWrk) = 0; RecordCnt = 8; PercentComp = 0; SqlMsg = *blanks; vdata = *blanks; SflRcdNbr = 1; IsStarted = *off; IsAllRead = *off; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn1 = 0; write contrl1; 1b if IsDoubleByte; chain 8 JCRSSQL DoubleByteChar; 1x else; chain 8 JCRSSQL SingleByteChar; 1e endif; 1b if DoubleByteChar.NotAuthorized = 'USER NOT AUTHORIZED ' or SingleByteChar.NotAuthorized = 'USER NOT AUTHORIZED '; vdata = 'USER NOT AUTHORIZED TO DUMP OBJECT'; f_SndSflMsg(ProgId: 'USER NOT AUTHORIZED TO DUMP OBJECT'); rrn1 += 1; write data1; 1x else; exsr srGetData; ScanStart = RawDumpData; 2b dou IsStarted; 3b if IsDoubleByte; read JCRSSQL DoubleByteChar; 3x else; read JCRSSQL SingleByteChar; 3e endif; exsr srGetData; exsr srInProgress; 3b if %eof; 2v leave; 3e endif; ScanStart = ScanStart + RawDumpData; sc = %scan(StatementStart: ScanStart); //--------------------------------------------------------- // note: 'TH' and 10 blanks and an SQL keyword is // ONLY reliable way to determine start of sql statement // So if I find 'TH ' and is not followed by a // keyword, then set scan value to zero 3b if sc > 0; 4b if (sc + 14 + 5) > %len(ScanStart); sc = 0; 4x else; SqlKeyWord = %subst(Scanstart: Sc + 14: 5); SqlKeyWord = %xlate(lo: up: SqlKeyWord); 5b if NOT (SqlKeyWord = 'SELEC' or SqlKeyWord = 'UPDAT' or SqlKeyWord = 'DELET' or SqlKeyWord = 'INSER' or SqlKeyWord = 'CALL ' or SqlKeyWord = 'COMME' or SqlKeyWord = 'COMMI' or SqlKeyWord = 'CONNE' or SqlKeyWord = 'CREAT' or SqlKeyWord = 'DISCO' or SqlKeyWord = 'DROP ' or SqlKeyWord = 'GRANT' or SqlKeyWord = 'LABEL' or SqlKeyWord = 'LOCK ' or SqlKeyWord = 'RENAM' or SqlKeyWord = 'RELEA' or SqlKeyWord = 'REVOK' or SqlKeyWord = 'ROLLB' or SqlKeyWord = 'ALTER' or SqlKeyWord = 'SET C' or SqlKeyWord = 'SET T'); sc = 0; 5e endif; 4e endif; 3e endif; //--------------------------------------------------------- 3b if sc = 0; ScanStart = RawDumpData; 3x else; IsStarted = *on; 3e endif; 2e enddo; //--------------------------------------------------------- // Load 1000 records into LongString. //--------------------------------------------------------- 2b if IsStarted; LongString = %subst(ScanStart: Sc); /end-free C Next1000 tag /free xx = 0; 3b dou 1 = 2; 4b if IsDoubleByte; read JCRSSQL DoubleByteChar; 4x else; read JCRSSQL SingleByteChar; 4e endif; exsr srGetData; exsr srInProgress; 4b if %eof; IsAllRead = *on; 3v leave; 4e endif; 4b if Asterisk = '*'; xx += 1; LongString = LongString + RawDumpData; 5b if xx = 1000; 3v leave; 5e endif; 4e endif; 3e enddo; //--------------------------------------------------------- sc = 1; 3b dou nextsc = 0; 4b if %len(LongString) > (sc + 12 + 14); wrksc = sc; /end-free C NotTrueTH tag /free nextsc = %scan(StatementStart: LongString: wrksc + 12); //--------------------------------------------------------- // note: 'TH' and 10 blanks and an SQL keyword is the // ONLY reliable way to determine start of sql statement // So if I find 'TH ' and it is not followed by a // keyword, then set the scan value to zero //--------------------------------------------------------- 5b if nextsc > 0 and (nextsc + 18) < %len(longString); SqlKeyWord = %subst(LongString: nextsc + 14: 5); SqlKeyWord = %xlate(lo: up: SqlKeyWord); 6b if NOT (SqlKeyWord = 'SELEC' or SqlKeyWord = 'UPDAT' or SqlKeyWord = 'DELET' or SqlKeyWord = 'INSER' or SqlKeyWord = 'CALL ' or SqlKeyWord = 'COMME' or SqlKeyWord = 'COMMI' or SqlKeyWord = 'CONNE' or SqlKeyWord = 'CREAT' or SqlKeyWord = 'DISCO' or SqlKeyWord = 'DROP ' or SqlKeyWord = 'GRANT' or SqlKeyWord = 'LABEL' or SqlKeyWord = 'LOCK ' or SqlKeyWord = 'RENAM' or SqlKeyWord = 'RELEA' or SqlKeyWord = 'REVOK' or SqlKeyWord = 'ROLLB' or SqlKeyWord = 'ALTER' or SqlKeyWord = 'SET C' or SqlKeyWord = 'SET T'); wrksc = nextsc - 10; /end-free GO C goto NotTrueTH /free 6e endif; 5e endif; //--------------------------------------------------------- // (LastStatement) // If nextsc = 0 then there are no more begin statements in file, // there is however the last statement I have to process. // Looking at the dump output, it appears an 'A' followed by // 69 spaces should be a safe event to monitor. 5b if nextsc = 0 and %len(LongString) > (sc + 12 + 69); nextsc = %scan(LastStatement: LongString: Sc + 12); 5e endif; 4x else; nextsc = 0; 4e endif; 4b if nextsc > 0; SqlWrk = %subst(LongString: Sc + 12: + ((nextsc - 1) - (sc + 12) + 1)); //--------------------------------------------------------- // All statements end in with SQLnnnn and a message. // I only want to include the 1st sql message in our output. //--------------------------------------------------------- TestLen = %len(SqlWrk); 5b for xm = 71 to TestLen by 82; 6b if %subst(SqlWrk: xm: 1) <> 'T'; 7b if TestLen > (xm + 14 + 68); SqlMsg = %subst(SqlWrk: xm + 14: 68); 7x else; if testlen <= xm + 14 + 1; SqlMsg = *blanks; else; SqlMsg = %subst(SqlWrk: xm + 14: (TestLen - (xm + 14) + 1)); endif; 7e endif; %len(SqlWrk) = xm - 1; 5v leave; 6e endif; 5e endfor; xm = %scan('not': SqlMsg); 5b if xm = 0; //--------------------------------------------------------- // Now that all messages are stripped out, // reconstruct SQL statement. //--------------------------------------------------------- TestLen = %len(SqlWrk); // Allow for shorter strings 6b if TestLen > 70; TestLen = 70; 6e Endif; Sql = (%subst(SqlWrk: 1:TestLen)); TestLen = %len(SqlWrk); 6b for xm = 71 to TestLen by 82; 7b if %subst(SqlWrk: xm: 1) = 'T'; 8b if TestLen > (xm + 14 + 68); Sql = Sql + (%subst(SqlWrk: xm + 14: 68)); 8x else; Sql = Sql + (%subst(SqlWrk: xm + 14: (TestLen - (xm + 14) + 1))); 8e endif; 7e endif; 6e endfor; // some common errors I can filter. 6b if not (Sql = 'select ' or Sql = 'SELECT ' or Sql = 'delete ' or Sql = 'DELETE ' or Sql = 'strsql ' or Sql = 'UPDATE ' or Sql = 'update ' or Sql = 'wrksplf' or Sql = *blanks or %subst(SqlMsg: 1: 9) = 'Prompting' or %subst(SqlMsg: 1: 22) = 'Session ended abnormal'); // determine if completion message should be included 7b if SqlMsg > *blanks and SqlMsg <> 'SELECT statement run complete. '; Sql_and_Msg = Sql + ' ' + SqlMsg; 7x else; Sql_and_Msg = Sql; 7e endif; // upper case sql statement then apply selected scans %len(UpperCased) = %len(Sql_and_Msg); UpperCased = %xlate(lo: up: Sql_and_Msg); 7b if (%scan(%trimr(ScVal1): UpperCased: 1) > 0 and (scRelation = *blanks or scRelation = 'OR ')) OR (scRelation = 'OR ' and %scan(%trimr(ScVal2): UpperCased: 1) > 0) OR (%scan(%trimr(ScVal1): UpperCased: 1) > 0 and scRelation = 'AND' and %scan(%trimr(ScVal2): UpperCased: 1) > 0 ); exsr srWriteSubfile; 7e endif; 6e endif; 5e endif; sc = nextsc; 4e endif; 3e enddo; // load left over and loop back 3b if IsAllRead = *off; LongString = %subst(LongString: Sc); /end-free GO C goto Next1000 /free 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srGetData; 1b if IsDoubleByte; Asterisk = DoubleByteChar.Asterisk; RawDumpData = DoubleByteChar.DumpText; 1x else; Asterisk = SingleByteChar.Asterisk; RawDumpData = SingleByteChar.DumpText; 1e endif; endsr; //--------------------------------------------------------- begsr srInProgress; RecordCnt += 1; 1b if TwoPercent > 0 and %rem(RecordCnt: TwoPercent) = 0; InPrgVary = InPrgVary + '>'; InProgressMsg = InPrgVary + ConstantPeriod; PercentComp += 2; // Send status message f_SndStatMsg(%char(PercentComp) + '% completed: ' + InProgressMsg); 1e endif; endsr; //--------------------------------------------------------- begsr srWriteSubfile; 1b if rrn1 < 1699; aOptions = %bitor(Green:UL); xx = 1; Sql = %triml(Sql); SqlHid = %triml(Sql); 2b if %len(Sql) > 0; 3b dou xx > %len(Sql); vdata = %subst(Sql: xx); rrn1 += 1; write data1; xx += %size(vdata); clear SqlHid; aOptions = ND; 3e enddo; 2e endif; 2b if SqlMsg > *blanks and SqlMsg <> 'SELECT statement run complete. '; vdata = ' Msg: ' + SqlMsg; rrn1 += 1; write data1; 2e endif; clear vdata; rrn1 += 1; write data1; 1x else; f_SndSflMsg(ProgId: '100++ pages returned. Narrow your search.'); /end-free GO C goto ShowFull /free 1e endif; endsr; /end-free ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSUBR - List subroutine structure - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print Subroutine Structure') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('RPG program name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRSUBR'.Print Subroutine Structure (JCRSUBR) - Help .*-------------------------------------------------------------------- :P.This JCR command prints listing showing subroutine execution structure for selected source.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRSUBR/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Program for which subroutine list is to be printed.:EHELP. :HELP name='JCRSUBR/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP name='JCRSUBR/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRSUBRPF - List subroutine structure report workfile - PF *---------------------------------------------------------------- A R JCRSUBRPFR TEXT('List Subroutines') A SRUPPERCAS 100A COLHDG('Parent Key') A SRPARENT 100A COLHDG('Parent Subroutines') A SRCHILD 100A COLHDG('Child Subroutines') A K SRUPPERCAS ]]> v5r4 //--------------------------------------------------------- // JCRSUBRR1 - List subroutine structure-build work file // Read through RPG4 source either /free or columnar and load work // file with Parent subroutine / Child subroutine names. Subroutines executed // from main line code (ie not in subroutine) will have *** as subsr name. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FRPGSRC if f 112 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn FJCRSUBRPF o e disk usropn //--*STAND ALONE------------------------------------------- D UpperSrc s like(SrcDS.Src80) D WrkA s like(SrcDS.OpCode) D OpcodeExtract s like(SrcDS.OpCode) D IsCalcSpec s n D IsFree s n D IsInsideSubroutine... D s n //--*COPY DEFINES------------------------------------------ /Define Constants /Define f_GetQual /Define SrcDS /Define f_System /Define f_DspLastSplf /Define p_JCRSUBRR2 /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRSUBRR1 PR extpgm('JCRSUBRR1') D 10a D 20a D 8a D p_JCRSUBRR1 PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_Output 8a //--*INPUT SPECS------------------------------------------- IRPGSRC ns I a 1 112 SrcDS //--------------------------------------------------------- /free f_System('CLRPFM JCRSUBRPF'); extIfile = f_GetQual(p_SrcFilQual); open JCRSUBRPF; open RPGSRC; read RPGSRC; 1b dow not %eof; // do not process compile time arrays 2b if SrcDS.CompileArray = '** ' or SrcDS.CompileArray = '**C' or SrcDS.CompileArray = '**c'; 1v leave; 2e endif; // spin through until I get into C specs proper. // if C or c or /free, I am in C specs. 2b if SrcDS.SpecType = 'C' or SrcDS.SpecType = 'c'; IsCalcSpec = *on; 2e endif; 2b if SrcDS.SpecType = 'O' or SrcDS.SpecType = 'o' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'd' or SrcDS.SpecType = 'F' or SrcDS.SpecType = 'f'; IsCalcSpec = *off; 2e endif; // see if inside /free section 2b if SrcDS.Asterisk = '/'; SrcDS.FreeForm = %xlate(lo: up: SrcDS.FreeForm); 3b if SrcDS.FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 3x elseif SrcDS.FreeForm = '/END-FREE'; IsFree = *off; 3e endif; 2e endif; // see if // free comment line IsComment = *off; 2b if IsFree; 3b if %len(%triml(SrcDS.Src80)) > 1 and %subst((%triml(SrcDS.Src80)): 1: 2) = '//'; IsComment = *on; 3e endif; 2x else; 3b if SrcDS.SlashComment = '//'; IsComment = *on; 3e endif; 3b if SrcDS.Asterisk = '*'; IsComment = *on; 3e endif; 2e endif; //--------------------------------------------------------- // Finally! 2b if IsCalcSpec and not IsComment; 3b if SrcDS.Asterisk = '/' //skip SQL stuff or SrcDS.Asterisk = '+'; 3x else; //--------------------------------------------------------- // For /free code, do a little work to get opcode // into OpCodeExtract field. // Look for first ' ' and first ';' , which ever not // zero and lowest value is end of opcode OpCodeExtract = SrcDS.OpCode; 4b if IsFree and SrcDS.Src80 > *blanks; WrkA = %triml(SrcDS.Src80); aa = %scan(' ': WrkA: 1); bb = %scan(';': WrkA: 1); clear OpCodeExtract; 5b if aa > 0 and (aa < bb or bb = 0); OpCodeExtract = %subst(WrkA: 1: aa - 1); 5x elseif bb > 0 and (bb < aa or aa = 0); OpCodeExtract = %subst(WrkA: 1: bb - 1); 5e endif; 4e endif; OpCodeExtract = %xlate(lo: up: OpCodeExtract); // Extract Parent subroutine name 4b if OpCodeExtract = 'BEGSR '; IsInsideSubroutine = *on; // /free subroutine will be // following 'begsr' and before ';' 5b if IsFree; UpperSrc = %xlate(lo: up: SrcDS.Src80); aa = %scan('BEGSR ': UpperSrc: 1); bb = %scan(';': SrcDS.Src80: aa + 6); srParent = %triml( %subst(SrcDS.Src80: aa + 6: bb - (aa + 6))); 5x else; srParent = SrcDS.Factor1; 5e endif; srUpperCas = %xlate(lo: up: SrParent); srChild = '**'; write JCRSUBRPFR; // Extract Child name 4x elseif OpCodeExtract = 'EXSR '; // /free subroutine will be // following 'begsr' and before ';' 5b if not IsInsideSubroutine; srParent = '***'; 5e endif; 5b if IsFree; UpperSrc = %xlate(lo: up: SrcDS.Src80); aa = %scan('EXSR ': UpperSrc: 1); bb = %scan(';': SrcDS.Src80: aa + 5); srChild = %triml( %subst(SrcDS.Src80: aa + 5: bb - (aa + 5))); 5x else; srChild = SrcDS.Factor2; 5e endif; write JCRSUBRPFR; 4x elseif %subst(OpCodeExtract: 1: 3) = 'CAS' and not IsFree; 5b if not IsInsideSubroutine; srParent = '***'; 5e endif; srChild = SrcDS.ResultField; write JCRSUBRPFR; 4e endif; 3e endif; 2e endif; read RPGSRC; 1e enddo; close RPGSRC; close JCRSUBRPF; callp p_JCRSUBRR2(p_SrcMbr: p_SrcFilQual); f_DspLastSplf('JCRSUBRR2 ': p_Output); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRSUBRR2 - List subroutine structure-print report // to compile: OVRDBF FILE(JCRSUBRLF) TOFILE(JCRSUBRPF) //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /unDefine ProgramHeaderSpecs FJCRSUBRLF if e k disk extfile('JCRSUBRPF') F rename(JCRSUBRPFR:BYKEYR) F prefix(x) usropn FJCRSUBRPF if e disk usropn FQSYSPRT O f 132 printer Oflind(IsOverFlow) usropn //--*STAND ALONE------------------------------------------- D Alpha100 s 100a D Alpha132 s 132a D scDow s 9a D LevelCnt s 3u 0 D scObjHead s 100a //--*COPY DEFINES------------------------------------------ /Define f_System /Define f_OvrPrtf /Define f_DltOvr /Define f_Qusrmbrd /Define f_BuildString /Define f_GetDayName /Define p_JCRSUBRR2 /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- // recursive subroutine blown downs D Run_Down_SR_Stack... D PR D 100a subroutines names D 3u 0 level count //--*ENTRY PARMS------------------------------------------- D p_JCRSUBRR2 PI D p_SrcMbr 10a D p_SrcFilQual 20a //--------------------------------------------------------- /free open JCRSUBRPF; open JCRSUBRLF; f_OvrPrtf('QSYSPRT ': *OMIT: p_SrcMbr); open qsysprt; evalr scDow = %trimr(f_GetDayName()); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); scObjHead = f_BuildString('Mbr: & & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); clear Alpha100; except PrtHead; //--------------------------------------------------------- // read back through work file, // generate begsr print line when SR name changes. // Call function to run down SR execution stack. read JCRSUBRPFR; 1b dow not %eof; 2b if srParent <> Alpha100; Alpha100 = srParent; except PrtBegSR; 3b if IsOverFlow; except PrtHead; IsOverFlow = *off; 3e endif; 2e endif; LevelCnt = 1; 2b if srChild <> '**'; Run_Down_SR_Stack(srChild: LevelCnt); 2e endif; read JCRSUBRPFR; 1e enddo; close JCRSUBRPF; close JCRSUBRLF; f_System('CLRPFM JCRSUBRPF'); close QSYSPRT; f_DltOvr('QSYSPRT '); *inlr = *on; return; /end-free Oqsysprt e PrtHead 2 1 O 8 'JCRSUBR' O 50 'Subroutine Stack Listing' O scDow 85 O udate y 95 O 111 'Page' O PAGE1 117 O e PrtHead 2 O scObjHead 101 O e PrtBegSR 1 1 O Alpha100 101 O e PrtChild 1 O Alpha132 132 //--------------------------------------------------------- // Print indented executed-from subroutine stack. // This function can execute itself recursively to // follow parent-child subroutine chain down to end-of-chain. //--------------------------------------------------------- P Run_Down_SR_Stack... P B D PI D p_ChildSR 100a D p_LevelCnt 3u 0 D Key100 s 100a D NextLevelCnt s 3u 0 D lo c const('abcdefghijklmnopqrstuvwxyz') D up c const('ABCDEFGHIJKLMNOPQRSTUVWXYZ') /free Key100 = %xlate(lo: up: p_ChildSR); // indent over 5 spaces for each level clear Alpha132; %subst(Alpha132: p_LevelCnt*5) = %char(p_LevelCnt) + ' ' + p_ChildSR; except PrtChild; 1b if IsOverFlow; except PrtHead; IsOverFlow = *off; 1e endif; NextLevelCnt = p_LevelCnt + 1; // now execute function recursively for each record. setll key100 BYKEYR; reade key100 BYKEYR; 1b dow not %eof; 2b if xsrChild <> '**'; callp Run_Down_SR_Stack(xsrChild: NextLevelCnt); 2e endif; reade key100 BYKEYR; 1e enddo; return; /end-free P Run_Down_SR_Stack... P E ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSUNDRY - Sundry programs selection menu - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('SUNDRY programs Selection Menu') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRSUNDRYC - Sundry programs selection menu - CMDPGM */ /* Several of this utilities generate spooled files so I thought it nice */ /* to use v5r4 data structure capabilities to call 'get last spooled */ /* file information' API. */ /* Note: executing QCMDEXC allows this program to compile even if commands */ /* being executed do not exists on system */ /*--------------------------------------------------------------------------*/ PGM DCLF FILE(JCRSUNDRYD) DCL VAR(&PGM) TYPE(*CHAR) STG(*AUTO) LEN(10) /* Define parms for call to QSPRILSP API -----------------------------------*/ DCL VAR(&LENRCVR) TYPE(*INT) LEN(4) VALUE(70) DCL VAR(&FORMAT) TYPE(*CHAR) LEN(8) VALUE('SPRL0100') /* Define Qsprilsp list entry data structure -------------------------------*/ DCL VAR(&QSPRILSPDS) TYPE(*CHAR) STG(*AUTO) LEN(70) DCL VAR(&SPLFNAME) TYPE(*CHAR) STG(*DEFINED) LEN(10) DEFVAR(&QSPRILSPDS 9) /* Error return code parameter for APIs-------------------------------------*/ DCL VAR(&APIERRDS) TYPE(*CHAR) LEN(256) DCL VAR(&APROVIDED) TYPE(*INT) STG(*DEFINED) LEN(4) DEFVAR(&APIERRDS) DCL VAR(&AAVAIL) TYPE(*INT) STG(*DEFINED) LEN(4) DEFVAR(&APIERRDS 5) DCL VAR(&AMSGID) TYPE(*CHAR) STG(*DEFINED) LEN(7) DEFVAR(&APIERRDS 9) DCL VAR(&ARESERVED) TYPE(*CHAR) STG(*DEFINED) LEN(1) DEFVAR(&APIERRDS 16) DCL VAR(&AMSGDTA) TYPE(*CHAR) STG(*DEFINED) LEN(112) DEFVAR(&APIERRDS 17) CHGVAR VAR(&PROGID) VALUE('JCRSUNDRYC') MONMSG MSGID(CPF0000) RMVMSG CLEAR(*ALL) CALL PGM(JCRDAYNAMR) PARM(&SCDOW) SNDF RCDFMT(SCREEN) DOUNTIL COND(1 *EQ 2) SNDF RCDFMT(MSGCTL) SNDRCVF RCDFMT(SCREEN) WAIT(*YES) RMVMSG CLEAR(*ALL) SELECT WHEN COND((&IN03) *OR (&IN12)) THEN(DO) LEAVE ENDDO WHEN COND(&SCOPTION = '1') THEN(DO) CALL PGM(JCRSBSDR) CHGVAR VAR(&PGM) VALUE('JCRSBSDR') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '2') THEN(DO) CALL PGM(QCMDEXC) PARM('? JCRJRNA' 20) MONMSG MSGID(CPF6801) EXEC(DO) SNDPGMMSG MSG('JCRJRNA journaled files canceled') TOPGMQ(*SAME) ITERATE ENDDO SNDPGMMSG MSG('JCRJRNA journaled files completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '3') THEN(DO) CALL PGM(QCMDEXC) PARM('? JCRMRBIG' 20) MONMSG MSGID(CPF6801) EXEC(DO) SNDPGMMSG MSG('JCRMRBIG print BIG characters canceled') TOPGMQ(*SAME) ITERATE ENDDO CHGVAR VAR(&PGM) VALUE('JCRMRBIG') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '4') THEN(DO) CALL PGM(JCRAMORT) CHGVAR VAR(&PGM) VALUE('JCRAMORT') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '5') THEN(DO) CALL PGM(JCRHEXCHR) SNDPGMMSG MSG('JCRHEXCHR hex characters completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '6') THEN(DO) CALL PGM(JCRLICUSE) SNDPGMMSG MSG('JCRLICUSE List license locks completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '7') THEN(DO) CALL PGM(JCRLSTCNN) CHGVAR VAR(&PGM) VALUE('JCRLSTCNN') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '8') THEN(DO) CALL PGM(JCRLSTIFC) CHGVAR VAR(&PGM) VALUE('JCRLSTIFC') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '9') THEN(DO) CALL PGM(JCRUSRPRFR) CHGVAR VAR(&PGM) VALUE('JCRUSRPRFR') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '10') THEN(DO) CALL PGM(QCMDEXC) PARM('? JCRUSRAUT' 20) MONMSG MSGID(CPF6801) EXEC(DO) SNDPGMMSG MSG('JCRUSRAUT List profile class/authorities canceled') TOPGMQ(*SAME) ITERATE ENDDO CHGVAR VAR(&PGM) VALUE('JCRUSRAUT') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '11') THEN(DO) CALL PGM(JCRZANIM0) SNDPGMMSG MSG('JCRZANIM0 Binary clock completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '12') THEN(DO) CALL PGM(JCRZANIM1) SNDPGMMSG MSG('JCRZANIM1 boxes going around completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '13') THEN(DO) CALL PGM(JCRZANIM2) SNDPGMMSG MSG('JCRZANIM2 warp speed completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '14') THEN(DO) CALL PGM(JCRZANIM3) SNDPGMMSG MSG('JCRZANIM3 raise the flag completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '15') THEN(DO) CALL PGM(JCRZANIM4) SNDPGMMSG MSG('JCRZANIM4 I am with stupid completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '16') THEN(DO) CALL PGM(JCRZANIM5) SNDPGMMSG MSG('JCRZANIM5 To Boldly Go completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '17') THEN(DO) CALL PGM(JCRZANIM6) SNDPGMMSG MSG('JCRZANIM6 Racquetball Server completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '18') THEN(DO) CALL PGM(QCMDEXC) PARM('? JCRSPELL' 20) MONMSG MSGID(CPF6801) EXEC(DO) SNDPGMMSG MSG('JCRSPELL - Spelling Aid canceled') TOPGMQ(*SAME) ITERATE ENDDO SNDPGMMSG MSG('JCRSPELL - Spelling Aid completed') TOPGMQ(*SAME) ENDDO OTHERWISE CMD(SNDPGMMSG MSG('Please select valid option') TOPGMQ(*SAME)) ENDSELECT CHGVAR VAR(&SCOPTION) VALUE(' ') ENDDO /*--------------------------------------------------------------------------*/ /* return name of last spooled file generated */ /*--------------------------------------------------------------------------*/ SUBR SUBR(SRLASTSPLF) CALL PGM(QSPRILSP) PARM(&QSPRILSPDS &LENRCVR &FORMAT &APIERRDS) SNDPGMMSG MSG(&PGM *TCAT ' spooled file ' *CAT + &SPLFNAME *TCAT ' generated.') TOPGMQ(*SAME) ENDSUBR ENDPGM ]]> v5r4 *---------------------------------------------------------------- * JCRSUNDRYD - Sundry programs selection menu - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT CA03(03) CA12(12) A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A 1 2'JCRSUNDRY' COLOR(BLU) A 1 23'Various and Sundry' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 2'1) JCRSBSDR - List subsystem memor- A y pools' A 4 2'2) JCRJRNA - List PFs in selected - A *JRN' A 5 2'3) JCRMRBIG - Example print BIG ch- A aracters' A 6 2'4) JCRAMORT - Amortization schedul- A e' A 7 2'5) JCRHEXCHR - Display all valid h- A ex/biton characters' A 8 2'6) JCRLICUSE - Locks on a license' A 9 2'7) JCRLSTCNN - List network connec- A tions' A 10 2'8) JCRLSTIFC - List tcp/ip connect- A ions' A 11 1' 9) JCRUSRPRFR - List enabled user- A profiles/last signon date' A 12 1'10) JCRUSRAUT - List user profile - A class/ special authorities' A 13 1'11) JCRZANIM0 - Animation- Binary - A Clock' A 14 1'12) JCRZANIM1 - Animation- boxes g- A oing around the screen' A 15 1'13) JCRZANIM2 - Animation- warp sp- A eed effect' A 16 1'14) JCRZANIM3 - Animation- raise t- A he flag' A 17 1'15) JCRZANIM4 - Animation- I am wi- A th stupid' A 18 1'16) JCRZANIM5 - Animation- To Bold- A ly Go' A 19 1'17) JCRZANIM6 - Animation- Racquet- A ball Server Rotation' A 20 1'18) JCRSPELL - Spelling Aid' A SCOPTION 2A B 21 1 A 21 5'Option' A 21 25'F3=Exit' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(21) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 //--------------------------------------------------------- // JCRSYSID - Return system name to calling program // Call API to retrieve network attributes. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs //--*DATA STRUCTURES--------------------------------------- // Error return code parm for APIs. D ApiErrDS ds qualified D BytesProvided 10i 0 inz(%len(ApiErrDS)) D BytesReturned 10i 0 D ErrMsgId 7a D ReservedSpace 1a D MsgReplaceVal 112a // Network Attribute Information Table returned D NetworkInfoDS ds qualified based(NetWorkInfoPtr) D Attribute 10a overlay(NetworkInfoDS:1) D TypeOfData 1a overlay(NetworkInfoDS:11) D InfoStatus 1a overlay(NetworkInfoDS:12) D LengthOfData 10i 0 overlay(NetworkInfoDS:13) D LocalSysName 8a overlay(NetworkInfoDS:17) D QwcrnetaDS ds 200 qualified inz D NumberKeys 10i 0 D OffsetToTable 10i 0 //--*CALL PROTOTYPES--------------------------------------- D Qwcrneta PR extpgm('QWCRNETA') Network Attributes D 200a options(*varsize) Receiver Variable D 10i 0 const Receiver Length D 10i 0 const Number Of Keys D 20a const Constant Db like(ApiErrDS) Error Parm //--*ENTRY PARMS------------------------------------------- D p_JCRSYSID PR extpgm('JCRSYSID') D 8a D p_JCRSYSID PI D p_ReturnName 8a //--------------------------------------------------------- /free callp QWCRNETA( QwcrnetaDS : %size(QwcrnetaDS): 1: 'LCLCPNAME ': ApiErrDS); NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.OffsetToTable; p_ReturnName = NetworkInfoDS.LocalSysName; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRUFIND- Find string in user spaces - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find String in User Spaces') PARM KWD(USERSPACE) TYPE(USERSPACE) MIN(1) PROMPT('User Space:') USERSPACE: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) MIN(1) QUAL TYPE(*NAME) LEN(10) PROMPT('Library:') PARM KWD(STRING1) TYPE(*CHAR) LEN(25) MIN(1) PROMPT('Scan string 1:') PARM KWD(RELATION) TYPE(*CHAR) LEN(4) RSTD(*YES) + VALUES(*AND *OR ' ') PROMPT('Relationship: (Optional)') PARM KWD(STRING2) TYPE(*CHAR) LEN(25) PROMPT('Scan string 2: (Optional)') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *OUTFILE) PROMPT('Output:') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) PROMPT('Outfile:') OUTFILE: QUAL TYPE(*NAME) LEN(10) MIN(0) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library:') PARM KWD(OUTMBR) TYPE(OUTMBR) PMTCTL(PMTCTL1) PROMPT('Output member options') OUTMBR: ELEM TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST)) PROMPT('Member to receive output') ELEM TYPE(*CHAR) LEN(10) RSTD(*YES) DFT(*REPLACE) + VALUES(*REPLACE *ADD) PROMPT('Replace or add records') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE')) NBRTRUE(*EQ 1) ]]> v5r4 *---------------------------------------------------------------- * JCRUFINDD - Find string in user spaces - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA A CA03 CA05 CA12 CA13 CA14 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A SBFNAME 10A O 7 4 A SBFSTRING 61A O 7 16 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(15) SFLSIZ(100) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A ASCVAL1 1A P A ASCRELAT 1A P A ASCNAME 1A P A ASCLIB 1A P A 1 2'JCRUFIND' COLOR(BLU) A 1 23'Find String in User Space' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 31'AND/OR' A 2 72SYSNAME COLOR(BLU) A 3 5'Scan for:' DSPATR(HI) A SCVAL1 15A B 3 15DSPATR(&ASCVAL1) A SCRELATION 3A B 3 32DSPATR(&ASCRELAT) A SCVAL2 15A B 3 37 A 4 5'Space Names:' DSPATR(HI) A SCNAME 10A B 4 18DSPATR(&ASCNAME) A 4 32'Library:' DSPATR(HI) A SCLIB 10A B 4 41DSPATR(&ASCLIB) A 6 4'View' DSPATR(HI) A 6 16'String' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 *---------------------------------------------------------------- * JCRUFINDF- Find string in user spaces outfile support - PF *---------------------------------------------------------------- A R JCRUFINDFR TEXT('User Space Find String') A SBFNAME 10A COLHDG('Space Name') A CREATEDBY 10A COLHDG('Created By') A LASTUSED 10A COLHDG('Last Used') A SBFSTRING 61A COLHDG('String Where Found') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRUFIND'.Find String In User Space (JCRUFIND) - Help .*-------------------------------------------------------------------- :P.This JCR command searches for string(s) through selected user spaces in selected library. A subfile of user space names with selected string is displayed. :NT.Note: this utility is great for searching through ASC Sequel views to find where files where used.:ENT. :P.Performance problem was 16Meg user spaces that did not contain requested string. This program was spinning through all 16 million bytes. Arbitrarily, I am going to say a string of 1000 X'00' is end of data in user space. If your user spaces have longer strings of nulls, change value OneThousand00 to a higher value.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRUFIND/USERSPACE'.User Space - Help :XH3.User Space (USERSPACE) :P.Name/*All/Generic* and library of user spaces to be scanned.:EHELP. :HELP name='JCRUFIND/STRING1'.Scan string 1 - Help :XH3.Scan string 1 (STRING1) :P.String that you want to search for in user spaces you specify.:EHELP. :HELP name='JCRUFIND/RELATION'.Relationship: (Optional) - Help :XH3.Relationship: (Optional) (RELATION) :P.If String2 is entered, this keyword specifies relationship between String1 and String2. :PARML.:PT.:PK def.*AND:EPK. :PD.Both String1 and String2 have to be present in user space :PT.*OR :PD.Either String1 or String2 can be present in user space.:EPARML.:EHELP. :HELP name='JCRUFIND/STRING2'.Scan string 2 - Help :XH3.Scan string 2: (Optional) (STRING2) :P.Second string that you want to search for in user spaces you specify.:EHELP. :HELP name='JCRUFIND/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.Output to Display or Data File. :PARML.:PT.:PK def.*:EPK.:PD.Show subfile of user spaces with selected string(s). :PT.*OUTFILE :PD.Output is redirected to selected data file. (see OUTFILE help).:EPARML.:EHELP. :HELP name='JCRUFIND/OUTFILE'.File to receive output - Help :XH3.File to receive output (OUTFILE) :P.Name and library of database file to which output of command is directed. If file does not exist, this command creates file in specified library. :P.:NT.If new file is created, text describing that file is "Outfile for JCRUFIND utility". The database format (JCRUFINDFR) of output file is same as that used in supplied file database JCRUFINDF.:ENT. :P.JCRUFINDF cannot be specified as outfile to receive output. :P.The possible library values are: :P.:PARML.:PT.:PK def.*LIBL:EPK.:PD.All libraries in job's library list are searched until first match is found. :PT.*CURLIB :PD.The current library for job is used to locate file. If no library is specified as current library for job, QGPL is used. :PT.library-name :PD.Specify library where file is located.:EPARML.:EHELP. :HELP name='JCRUFIND/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.Database file member that receives output of command.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRUFINDR - Find string in user spaces // call APIs to retrieve list of User Spaces // Use pointer to search user space for string // if found, display or outfile view name // // Note: Will work for all user spaces, but original intent was to search // through ASC Sequel views to find where files where used. ASC data is always in // first 5K or so bytes of user space. // Performance problem was 16Meg user spaces that did not contain requested string. // Program was spinning through all 16 million bytes. Arbitrarily, I am going to // say string of 1000 X'00' is end of scannable data in user space. If your user // spaces have longer strings of nulls then change value OneThousand00 to a higher value. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUFINDD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F usropn indds(Ind) FJCRUFINDF o e disk extfile(extOfile) extmbr(ExtOMbr) out file F usropn //--*STAND ALONE------------------------------------------- D OneThousand00 s 5u 0 inz(1000) D savscLib s like(scLib) D savscName s like(scName) D savscRelation s like(scRelation) D savscVal1 s like(scVal1) D savscVal2 s like(scVal2) D Alpha20 s 20a D EndOfSpace s 10u 0 D Hex00Count s 5u 0 D xx s 20i 0 D yy s 20i 0 D IsAnd1 s n D IsAnd2 s n D VarySearch1 s 25a varying D VarySearchLen1 s 3u 0 D Upper1 s 25a varying D VarySearch2 s 25a varying D VarySearchLen2 s 3u 0 D Upper2 s 25a varying D uSpaceSlice s 25a based(SlicePtr) D uSpaceChar s 1a based(uCharPtr) D LastChar s 1a D ExtOMbr s 10a //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Constants /Define Dspatr /Define Infds /Define FunctionKeys /Define Ind /Define Quslobj /Define Qusptrus /Define Qusrusat /Define Sds /Define UserSpaceHeaderDS /Define f_BuildString /Define f_GetQual /Define f_Qusrobjd /Define f_RmvSflMsg /Define f_SndCompMsg /Define f_SndSflMsg /Define f_SndStatMsg /Define f_GetRowColumn /Define f_GetApiISO /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRUFINDR PR extpgm('JCRUFINDR') D 20a D 25a D 4a D 25a D 8a D 20a D 22a D p_JCRUFINDR PI D p_ScanSpaces 20a D p_ScanString1 25a D p_Relations 4a D p_ScanString2 25a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free // Get pointer to user space created in validity checking program callp QUSPTRUS(UserSpaceName: GenericHeaderPtr: ApiErrDS); // open either display file or outfile depending. 1b if p_Output = '* '; open JCRUFINDD; evalr scDow = %trimr(f_GetDayName()); 1x elseif p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRUFINDF; 1e endif; SCVAL1 = p_ScanString1; SCRELATION = %subst(p_Relations: 2: 3); SCVAL2 = p_ScanString2; SCNAME = %subst(p_ScanSpaces: 1: 10); SCLIB = %subst(p_ScanSpaces: 11: 10); exsr srLoadOutput; //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen //--------------------------------------------------------- 1b if p_Output = '* '; 2b dou IsExitPgm; exsr srRefreshScreen; 2e enddo; close JCRUFINDD; f_SndCompMsg(f_BuildString('JCRUFIND for & - completed': f_GetQual(scname + scLib))); 1x elseif p_Output = '*OUTFILE'; close JCRUFINDF; f_SndCompMsg('File ' +%trimr(extOfile) + ' member ' + %trimr(ExtOmbr) + ' generated by MHUFIND.'); 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Call API to load object name list. begsr srRefreshScreen; 1b dow not (InfdsFkey = f03); savscVal1 = scVal1; savscRelation = scRelation; savscVal2 = scVal2; savScName = scName; savScLib = scLib; Ind.sfldsp = (rrn > 0); 2b if not Ind.sfldsp; f_SndSflMsg(ProgId: 'No strings match your selection.'); 2e endif; Ind.sfldspctl = *on; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; isExitPgm = *on; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); ascVal1 = %bitor(Green: UL); ascRelat = %bitor(Green: UL); ascName = %bitor(Green: UL); ascLib = %bitor(Green: UL); //--------------------------------------------------------- // 1) at least value1 must be entered. // 2) if value2 entered, // relationship must be 'AND' or 'OR ' // 3) if relationship eq 'AND' or 'OR', // 4) value2 must be entered. // 5) object name must be entered // 6) valid library name must be entered //--------------------------------------------------------- 2b if scVal1 = *blanks; CsrRowColDS = f_GetRowColumn('SCVAL1 ':InfdsFile:InfdsLib:InfdsRcdfmt); ascval1 = %bitor(White: RI); f_SndSflMsg(ProgId: 'Must enter Scan For string'); 1i iter; 2e endif; // and or relationship 2b if scVal2 > *blanks and not (scRelation = 'AND' or scRelation = 'OR '); CsrRowColDS = f_GetRowColumn('SCRELATION':InfdsFile:InfdsLib:InfdsRcdfmt); ASCRELAT = %bitor(White: RI); f_SndSflMsg(ProgId: 'And/Or must = AND or OR .'); 1i iter; 2e endif; // do not need relationship if factor2 = *blanks 2b if scVal2 = *blanks; scRelation = *blanks; 2e endif; 2b if scName = *blanks; CsrRowColDS = f_GetRowColumn('SCNAME ':InfdsFile:InfdsLib:InfdsRcdfmt); ascname = %bitor(White: RI); f_SndSflMsg(ProgId: 'Must enter Name Filter.'); 1i iter; 2e endif; 2b if scLib = *blanks; CsrRowColDS = f_GetRowColumn('SCLIB ':InfdsFile:InfdsLib:InfdsRcdfmt); asclib = %bitor(White: RI); f_SndSflMsg(ProgId: 'Must enter Library.'); 1i iter; 2x else; f_QUSROBJD(scLib + 'QSYS': '*LIB ': 'OBJD0100'); 3b if ApiErrDS.BytesReturned > 0; CsrRowColDS = f_GetRowColumn('SCLIB ':InfdsFile:InfdsLib:InfdsRcdfmt); asclib = %bitor(White: RI); f_SndSflMsg(ProgId: 'Library ' + %trimr(scLib) + ' not found.'); 1i iter; 3e endif; 2e endif; 2b if not (savscVal1 = scVal1 and savscRelation = scRelation and savscVal2 = scVal2 and savscName = scName and savscLib = sclib); exsr srLoadOutput; 1i iter; 2e endif; //--------------------------------------------------------- 2b if not Ind.sfldsp; //no records 1i iter; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- begsr srLoadOutput; VarySearch1 = %trim(scVal1); VarySearchLen1 = %len(VarySearch1); %len(Upper1) = VarySearchLen1; VarySearch2 = %trim(scVal2); VarySearchLen2 = %len(VarySearch2); %len(Upper2) = VarySearchLen2; 1b if p_Output = '* '; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; write SBFCTL1; 1e endif; f_SndStatMsg(f_BuildString('Scanning & type *USRSPC - in progress': f_GetQual(scName + scLib))); // Call API to load list of user spaces in selected library callp QUSLOBJ( UserSpaceName: 'OBJL0100': scName + scLib: '*USRSPC': ApiErrDS); // spin through list by moving QuslobjPtr pointer. QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; sbfName = QuslobjDS.ObjNam; Alpha20 = sbfName + QuslobjDS.ObjLib; // I have to get last used date here, before I scan user space // as scanning alters last used date 2b if p_OutPut = '*OUTFILE'; QusrObjDS = f_QUSROBJD( Alpha20: '*USRSPC' : 'OBJD0400'); CREATEDBY = QusrObjDS.CreatedByUser; LastUsed = f_GetApiISO(QusrObjDS.LastUsedDate + ' '); 2e endif; // Get pointer to user space callp QUSPTRUS( Alpha20: SlicePtr: ApiErrDS); 2b if ApiErrDS.BytesReturned = 0; // Get user space size so I don't move pointer past that point. callp QUSRUSAT( QusrusatDS: %size(QusrusatDS): 'SPCA0100': Alpha20: ApiErrDS); 3b if VarySearchLen1 > VarySearchLen2; QusrusatDS.SpaceSize -= VarySearchLen1; 3x else; QusrusatDS.SpaceSize -= VarySearchLen2; 3e endif; Hex00Count = 0; IsAnd1 = *off; IsAnd2 = *off; 3b for xx = 1 to QusrusatDS.SpaceSize; // if thousand x00 are found, assume end of data and leave uCharPtr = SlicePtr; 4b if uSpaceChar = x'00'; Hex00Count += 1; 5b if Hex00Count = OneThousand00; 3v leave; 5e endif; 4x else; Hex00Count = 0; 4e endif; Upper1 = %xlate(lo:up:%subst(uSpaceSlice:1:VarySearchLen1)); Upper2 = %xlate(lo:up:%subst(uSpaceSlice:1:VarySearchLen2)); 4b if scRelation = *blanks; 5b if Upper1 = VarySearch1; exsr srCompressAndWrite; 3v leave; 5e endif; 4x elseif scRelation = 'OR'; 5b if ( Upper1 = VarySearch1 or Upper2 = VarySearch2); exsr srCompressAndWrite; 3v leave; 5e endif; 4x elseif scRelation = 'AND'; 5b if Upper1 = VarySearch1; IsAnd1 = *on; 5e endif; 5b if Upper2 = VarySearch2; IsAnd2 = *on; 5e endif; 5b if IsAnd1 and IsAnd2; exsr srCompressAndWrite; 3v leave; 5e endif; 4e endif; SlicePtr += 1; 3e endfor; 2e endif; QuslobjPtr += GenericHeader.ListEntrySize; 1e endfor; endsr; //--------------------------------------------------------- // load from 30 spaces before xx into display // filter out anything less than x'40 as it will not display. // be careful if scan was found before 30 spaces into string // And finally, there can be a lot of spaces in the user space, // it will serve my purposes better if I compress multiple spaces // down to one single space to display more. // // Note: There are some 16M user spaces out there and my scan // value may be last data in space at position 100. Instead // of spinning through 16 million blanks, I will stop loading after // 1000 x00s //--------------------------------------------------------- begsr srCompressAndWrite; LastChar = *blanks; sbfString = *blanks; Hex00Count = 0; yy = 0; // where to start loading from 1b if (xx - 30) > 1; uCharPtr = SlicePtr - 30; EndOfSpace = xx - 30; 1x else; uCharPtr = SlicePtr; EndOfSpace = xx ; 1e endif; 1b dou yy = 60; // fill subfile field 2b if uSpaceChar <= x'40'; Hex00Count += 1; 3b if Hex00Count = OneThousand00; 1v leave; 3e endif; 3b if LastChar > *blanks; yy += 1; %subst(sbfString:yy:1) = ' '; LastChar = *blanks; 3e endif; 2x else; Hex00Count = 0; yy += 1; %subst(sbfString:yy:1) = uSpaceChar; LastChar = uSpaceChar; 2e endif; EndOfSpace += 1; 2b if EndOfSpace > QusrusatDS.SpaceSize; 1v leave; 2e endif; uCharPtr += 1; 1e enddo; 1b if p_Output = '* '; rrn += 1; write SBFDTA1; // if outfile, get created by user and last used date 1x elseif p_OutPut = '*OUTFILE'; write JCRUFINDFR; 1e endif; endsr; ]]> v5r4 //--------------------------------------------------------- // JCRUFINDRV - Validity checking program // call function to validate library name. // call API to see if any selected user spaces exist in library //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_CheckObj /Define f_Quscrtus /Define Quslobj /Define UserSpaceHeaderDS /Define f_RtvMsgAPI /Define f_SndEscapeMsg /Define f_GetQual /Define f_BuildString /Define f_OutFileCrtDupObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRUFINDRV PR extpgm('JCRUFINDRV') D 20a D 25a D 4a D 25a D 8a D 20a D 22a D p_JCRUFINDRV PI D p_ScanSpaces 20a D p_ScanString1 25a D p_Relations 4a D p_ScanString2 25a D p_Output 8a D p_OutFileQual 20a D p_OutMbrOpt 22a //--------------------------------------------------------- /free f_CheckObj(%subst(p_ScanSpaces: 11: 10) + 'QSYS ':'*LIB '); GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0100': p_ScanSpaces: '*USRSPC': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId : ApiErrDS.MsgReplaceVal))); 1e endif; QuslobjPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b if GenericHeader.ListEntryCount = 0; f_SndEscapeMsg( f_BuildString('Selected user space & was not found.': f_GetQual(p_ScanSpaces))); 1e endif; 1b if p_ScanString1 = *blanks; f_SndEscapeMsg('Scan String 1 must have a value.'); 1e endif; 1b if p_Relations > *blanks and p_ScanString2 = *blanks; f_SndEscapeMsg('Scan String 2 must have a value.'); 1e endif; 1b if p_Relations = *blanks and p_ScanString2 > *blanks; f_SndEscapeMsg('Relationship must have a value.'); 1e endif; 1b if p_Output = '*OUTFILE '; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRUFINDF '); 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRUSPACE - Show contents of selected user space - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Show User Space Contents') PARM KWD(USERSPACE) TYPE(USERSPACE) MIN(1) PROMPT('User Space Name:') USERSPACE: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library name:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*USRSPC ') ]]> v5r4 *---------------------------------------------------------------- * JCRUSPACED - Show contents of selected user space - DSPF *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A AOFFSET 1A P A ARECDATA 1A P A SBFOFFSET 9Y 0O 4 2EDTCDE(3) DSPATR(&AOFFSET) A 4 12'|' A SBFRECDATA 100A O 4 15DSPATR(&ARECDATA) A 4117'|' *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(21) SFLSIZ(22) A PAGEDOWN PAGEUP CA04 CA08 CF16 A SFLCSRRRN(&CSRRRN) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A CSRRRN 5S 0H A SFLRCDNBR 4S 0H SFLRCDNBR A 1 3'JCRUSPACE' COLOR(BLU) A 1 23'Show User Space Contents' A DSPATR(HI) A 1 51'Space:' A SCSPACE 10A O 1 58 A 1 71'Library:' A SCLIB 10A O 1 80 A SCDOW 9A O 1 96COLOR(BLU) A 1106DATE EDTWRD('0 / / ') COLOR(BLU) A 1116SYSNAME COLOR(BLU) A SCPOSTO 9Y 0B 2 2EDTCDE(4) DSPATR(HI) A 2 12'Position to' A 2 26'-or-' A 2 35'Search:' A SCSEARCH 40A B 2 43DSPATR(HI) CHECK(LC) A 2 87'Size:' A SCSIZE 9Y 0O 2 93EDTCDE(1) DSPATR(UL) A 3 2'Offset ' DSPATR(HI UL) A 3 15'*...+....1....+....2....+....3....- A +....4....+....5....+....6....+....- A 7....+....8....+....9....+....0' A DSPATR(HI) COLOR(RED) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 26 2'F3=Exit' COLOR(BLU) A 26 12'F4=Subfile record detail where cur- A sor is placed.' COLOR(BLU) A 26 63'F8=Toggle Hex/Char' COLOR(BLU) A 26 84'F16=Search Again' COLOR(BLU) A 26105'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R SBFDTA2 SFL A SBFOFFSET2 9Y 0O 3 2EDTCDE(3) A 3 12'|' A SBFRECCHAR 1A O 3 15DSPATR(HI) *---------------------------------------------------------------- A R SBFCTL2 SFLCTL(SBFDTA2) OVERLAY A SFLPAG(100) SFLSIZ(100) A 41 SFLDSP A 42 SFLDSPCTL A N42 SFLCLR A SFLLIN(10) A 1 3'JCRUSPACE' COLOR(BLU) A 1 23'Show User Space Contents' A DSPATR(HI) A 1 51'Space:' A SCSPACE 10A O 1 58 A 1 71'Library:' A SCLIB 10A O 1 80 A SCDOW 9A O 1 96COLOR(BLU) A 1106DATE EDTWRD('0 / / ') COLOR(BLU) A 1116SYSNAME COLOR(BLU) A 2 2' ' DSPATR(UL) A 2 15'Character' *---------------------------------------------------------------- A R SFOOTER2 A 27 2'F3=Exit' COLOR(BLU) A 27 69'F12=Cancel' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(27) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRUSPACE'.Show User Space Contents (JCRUSPACE) - Help .*-------------------------------------------------------------------- :P.This JCR command views character contents of selected user space. Any values below hex 40 are not shown. Position To by offset or search by character string is provided. Note: Pressing Enter starts search from beginning of space, pressing F16 continues search from present point. :EHELP. .*-------------------------------------------------------------------- :HELP name='JCRUSPACE/USERSPACE'.User Space - Help :XH3.User Space (USERSPACE) :P.Name and library of User Space to be selected.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCRUSPACER - Show contents of selected user space // Note: 27x132 display size is required to use this utility. // Note2: Search is case sensitive. Also, if you have large user space size, search // function could take a few moments as it does a %SCAN bif for each BYTE in user space. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUSPACEDcf e workstn sfile(SBFDTA1: rrn) infds(Infds) F sfile(SBFDTA2: rrn2) indds(Ind) //--*STAND ALONE------------------------------------------- D ByteFromSpace s 1a based(Ptr1) D ByteToSubfile s 1a based(Ptr2) D SpaceString s 40a based(SearchPtr) D DeepInSpace s 10i 0 inz(1) D LastFoundCnt s 10i 0 D SaveDeep s 10i 0 inz(1) D RcdsToWrite s 3u 0 inz(1) D rrn s 5u 0 D rrnsav s 5u 0 D rrn2 s 3u 0 D SflPag s 3u 0 inz(21) D WriteCount s 3u 0 inz(1) D xx s 3u 0 D zz s 3u 0 D SavePtr1 s * inz(*null) D uSpacePtr s * inz(*null) D IsFound s n D IsLastScan s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Cvthc /Define Infds /Define Dspatr /Define Sds /Define FunctionKeys /Define Ind /Define Qusptrus /Define Qusrusat /Define f_GetDayName /Define f_RmvSflMsg /Define f_SndSflMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D HexVal ds qualified D TopRowHex 1a D BotRowHex 1a //--*ENTRY PARMS------------------------------------------- D p_JCRUSPACER PR extpgm('JCRUSPACER') D 20a D p_JCRUSPACER PI D p_uSpaceName 20a //--------------------------------------------------------- /free f_RmvSflMsg(ProgId); evalr scDow = %trimr(f_GetDayName()); // Get pointer to user space callp QUSPTRUS(p_uSpaceName: uSpacePtr: ApiErrDS); Ptr1 = uSpacePtr; // Get user space size so I don't move pointer past that point. callp QUSRUSAT( QusrusatDS: %size(QusrusatDS): 'SPCA0100': p_uSpaceName: ApiErrDS); scSpace = %subst(p_uSpaceName: 1: 10); scLib = QusrusatDS.SpaceLibrary; scSize = QusrusatDS.SpaceSize; SflRcdNbr = 1; exsr srLoadSubfilePage; //--------------------------------------------------------- // Show subfile 1b dou 1 = 2; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; //--------------------------------------------------------- // fPageUp and fPageDown are controlled by offset of 1st subfile record. // To fPageDown add SflPag*100 to offset & start loading. // To fPageUp sub SflPag*100 from offset & continue. 2x elseif InfdsFkey = fPageDown; chain 1 SBFDTA1; DeepInSpace = sbfOffset + (SflPag/RcdsToWrite*100); Ptr1 = uSpacePtr + (DeepInSpace - 1); exsr srLoadSubfilePage; 2x elseif InfdsFkey = fPageUp; chain 1 SBFDTA1; DeepInSpace = sbfOffset - (SflPag/RcdsToWrite * 100); 3b if DeepInSpace < 1; DeepInSpace = 1; 3e endif; Ptr1 = uSpacePtr + (DeepInSpace - 1); exsr srLoadSubfilePage; //--------------------------------------------------------- // Show subfile of individual characters // from subfile1 where cursor was placed. 2x elseif InfdsFkey = f04; Ind.sfldsp2 = *off; Ind.sfldspctl2 = *off; rrn2 = 0; write SBFCTL2; write SFOOTER2; rrnsav = rrn; //save 1st subfile rrn CsrRRN = (CsrRRN - 1) / RcdsToWrite; CsrRRN = (CsrRRN * RcdsToWrite) + 1; chain csrRrn SBFDTA1; 3b if %found; SflRcdNbr = rrn; sbfOffset2 = sbfOffset; 4b for xx = 1 to 100; sbfRecChar = %subst(sbfRecData: xx: 1); rrn2 += 1; write SBFDTA2; sbfOffset2 += 1; 4e endfor; 3e endif; Ind.sfldsp2 = (rrn2 > 0); Ind.sfldspctl2 = *on; exfmt SBFCTL2; rrn = rrnsav; //restore subfile rrn //--------------------------------------------------------- 2x elseif InfdsFkey = f08; DeepInSpace = sbfOffset + 100 - (SflPag/RcdsToWrite * 100); 3b if DeepInSpace < 1; DeepInSpace = 1; 3e endif; Ptr1 = uSpacePtr + (DeepInSpace - 1); 3b if RcdsToWrite = 1; RcdsToWrite = 3; 3x else; RcdsToWrite = 1; 3e endif; exsr srLoadSubfilePage; //--------------------------------------------------------- // F16 = continue search from last instances was found. 2x elseif InfdsFkey = F16; 3b if scsearch > *blanks; DeepInSpace = LastFoundCnt + 1; SearchPtr = uSpacePtr + LastFoundCnt; exsr srFindSearchString; 4b if IsFound; exsr srLoadSubfilePage; 4x else; f_SndSflMsg(ProgId: 'Search string not found again in user space.'); 4e endif; 3e endif; 2x else; //--------------------------------------------------------- // If ENTER was pressed 3b if scPosTo > 0; 4b if scPosTo > scsize; // avoid Ptr error! f_SndSflMsg(ProgId: 'Position To is past end of space size'); 4x else; //--------------------------------------------------------- // Idea on PositionTo is to load a full subfile record at that position. DeepInSpace = scPosTo; Ptr1 = uSpacePtr + (DeepInSpace - 1); exsr srLoadSubfilePage; 4e endif; 3x else; //--------------------------------------------------------- // Enter starts search from beginning of userspace, F16 continues search. 4b if scsearch > *blanks; DeepInSpace = 1; SearchPtr = uSpacePtr; exsr srFindSearchString; 5b if IsFound; exsr srLoadSubfilePage; 5x else; f_SndSflMsg(ProgId: 'Search string not found in user space.'); 5e endif; 4e endif; 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- // Load user space data to subfile records begsr srLoadSubfilePage; reset WriteCount; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; write SBFCTL1; 1b dow (WriteCount <= SflPag) and DeepInSpace <= QusrusatDS.SpaceSize; SavePtr1 = Ptr1; SaveDeep = DeepInSpace; 2b for zz = 1 to RcdsToWrite; DeepInSpace = SaveDeep; Ptr2 = %addr(sbfRecData); clear sbfRecData; 3b for xx = 1 to 100; 4b if zz = 1; ByteToSubfile = ByteFromSpace; 4x elseif zz = 2; callp cvthc(%addr(HexVal):Ptr1:2); ByteToSubfile = Hexval.TopRowHex; 4x else; callp cvthc(%addr(HexVal):Ptr1:2); ByteToSubfile = Hexval.BotRowHex; 4e endif; 4b if ByteToSubfile < x'40' And ByteToSubfile > x'00'; //not displayable ByteToSubfile = x'1F'; 4e endif; 4b if ByteToSubfile = x'00'; //not displayable ByteToSubfile = x'41'; 4e endif; Ptr1 += 1; //next space pointer Ptr2 += 1; //next subfile data pointer DeepInSpace += 1; //do not go too far 4b if DeepInSpace > QusrusatDS.SpaceSize; DeepInSpace = sbfOffset + 200; 3v Leave; 4e endif; 3e endfor; 3b if zz <> RcdsToWrite; Ptr1 = SavePtr1; 3e endif; 3b if zz <> 1; aOffset = ND; aRecData = Green; 3x else; aOffset = Green; aRecData = White; 3e endif; // Load counter down side of subfile sbfOffset = DeepInSpace - 100; rrn += 1; write SBFDTA1; WriteCount += 1; 2e endfor; 1e enddo; // position to subfile record 1b if rrn > 2; SflRcdNbr = rrn - 1; 1x else; SflRcdNbr = 1; 1e endif; endsr; //--------------------------------------------------------- // Use Ptrs to run down user space searching, // If match was found, set to full subfile record. begsr srFindSearchString; IsFound = *off; IsLastScan = *off; LastFoundCnt = 0; 1b dow DeepInSpace < scsize; //avoid Ptr error! xx = %scan(%trimr(scSearch): SpaceString: 1); 2b if xx > 0; IsFound = *on; DeepInSpace = DeepInSpace + xx - 1; LastFoundCnt = DeepInSpace; //--------------------------------------------------------- Ptr1 = uSpacePtr + (DeepInSpace - 1); 1v leave; 2e endif; 2b if IsLastScan; 1v leave; 2e endif; SearchPtr = SearchPtr + %Size(SpaceString) + 1 - %len(%trimr(scSearch)); DeepInSpace = DeepInSpace + %Size(SpaceString) + 1 - %len(%trimr(scSearch)); 2b if DeepInSpace + %Size(SpaceString) > Scsize; DeepInSpace = Scsize - %Size(SpaceString) + 1; SearchPtr = uSpacePtr + DeepInSpace - 1; IsLastScan = *on; 2e endif; 1e enddo; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRUSRAUT - List user profile class/special authorities */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List User Class/Authorities') PARM KWD(USERCLASS) TYPE(*CHAR) LEN(7) RSTD(*YES) + DFT(*ALL) VALUES(*SECOFR *SECADM *PGMR + *SYSOPR *USER *ALL) PROMPT('User Class:') PARM KWD(SPECIALAUT) TYPE(*CHAR) LEN(9) + RSTD(*YES) DFT(*ALL) VALUES(*ALLOBJ + *SECADM *JOBCTL *SPLCTL *SAVSYS *SERVICE + *AUDIT *IOSYSCFG *ALL) MAX(8) PROMPT('Special Authorities:') PARM KWD(STATUS) TYPE(*CHAR) LEN(9) RSTD(*YES) + DFT(*ENABLED) VALUES(*ENABLED *DISABLED *ALL) PROMPT('Status:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRUSRAUT'.List User Class/Authorities (JCRUSRAUT) Help .*-------------------------------------------------------------------- :P.This JCR command generates report showing users with selected user class and special authorities.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRUSRAUT/USERCLASS'.User Class - Help :XH3.User Class (USERCLASS) :P.User class of profiles to be selected.:EHELP. :HELP name='JCRUSRAUT/SPECIALAUT'.Special Authorities - Help :XH3.Special Authorities (SPECIALAUT) :P.Up to eight authorities to select.:EHELP. :HELP name='JCRUSRAUT/STATUS'.Status - Help :XH3.Status (STATUS) :P.Select status of user profile to be selected.:EHELP. :HELP name='JCRUSRAUT/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRUSRAUT - List user profile class/special authorities - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSRAUT' A 20'User Profiles with select Class/Au- A thorities' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 3'Class:' A PCLASS 7A 10SPACEA(1) *--- A 3'Authorities:' A PAUTH1 9A 16 A PAUTH2 9A 26 A PAUTH3 9A 36 A PAUTH4 9A 46 A PAUTH5 9A 56 A PAUTH6 9A 66 A PAUTH7 9A 76 A PAUTH8 9A 86 A PAUTH9 9A 96SPACEA(1) *--- A 3'Status:' A ISTATUS 9A 11 A 29'Special Authorities' SPACEA(1) *--- A 2'User Profile' A 16'User' A 21'Class' A 28'ALLOBJ' A 35'SECADM' A 42'JOBCTL' A 49'SPLCTL' A 56'SAVSYS' A 63'SERVICE' A 71'AUDIT' A 77'IOSYSCFG' A 87'LAST USED' A 99'TEXT' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A USRPRF 10A O 2 A PDCLASS 7A O 16 A PALLOBJ 1A O 30 A PSECADM 1A O 37 A PJOBCTL 1A O 44 A PSPLCTL 1A O 51 A PSAVSYS 1A O 58 A PSERVICE 1A O 65 A PAUDIT 1A O 73 A PIOSYSCH 1A O 80 A LASTUSED 10A O 87 A USRPRFTXT 33A O 99 ]]> v5r4 //--------------------------------------------------------- // JCRUSRAUTR - List user profile class/special authorities //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUSRAUTPo e printer oflind(IsOverFlow) usropn //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetApiISO /Define f_DspLastSplf /Define f_GetDayName /Define f_ParmListCount /Define UserProfiles /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D NumOfAuth s 3u 0 D AuthArry s 9a dim(8) based(AuthArryPtr) D SelectArry s 1a dim(8) D xx s 3u 0 D IsOneWeWant s n //--*DATA STRUCTURES--------------------------------------- D PrtfHeading ds D pAuth1 D pAuth2 D pAuth3 D pAuth4 D pAuth5 D pAuth6 D pAuth7 D pAuth8 D pAuth9 D pHeadArry 9a dim(8) overlay(PrtfHeading:1) D PrtfDetail ds D PALLOBJ D PSECADM D PJOBCTL D PSPLCTL D PSAVSYS D PSERVICE D PAUDIT D PIOSYSCH D pDetailArry 1a dim(8) overlay(PrtfDetail:1) //--*ENTRY PARMS------------------------------------------- D p_JCRUSRAUTR PR extpgm('JCRUSRAUTR') D 7a D 74a D 9a D 8a D p_JCRUSRAUTR PI D p_Class 7a D p_AuthList 74a D p_Status 9a D p_Output 8a //--------------------------------------------------------- /free // load input parms into print fields open JCRUSRAUTP; pClass = p_Class; evalr scDow = %trimr(f_GetDayName()); // it will be easier to load a validation array with Y in appropriate // elements when I have to do compares in selection criteria. SelectArry(*) = x'00'; NumOfAuth = f_ParmListCount(p_AuthList); AuthArryPtr = %addr(p_AuthList) + 2; 1b for xx = 1 to NumOfAuth; pHeadArry(xx) = AuthArry(xx); 2b if pHeadArry(xx) = '*ALLOBJ '; SelectArry(1) = 'Y'; 2x elseif pHeadArry(xx) = '*SECADM '; SelectArry(2) = 'Y'; 2x elseif pHeadArry(xx) = '*JOBCTL '; SelectArry(3) = 'Y'; 2x elseif pHeadArry(xx) = '*SPLCTL '; SelectArry(4) = 'Y'; 2x elseif pHeadArry(xx) = '*SAVSYS '; SelectArry(5) = 'Y'; 2x elseif pHeadArry(xx) = '*SERVICE '; SelectArry(6) = 'Y'; 2x elseif pHeadArry(xx) = '*AUDIT '; SelectArry(7) = 'Y'; 2x elseif pHeadArry(xx) = '*IOSYSCFG'; SelectArry(8) = 'Y'; 2e endif; 1e endfor; write PrtHead; // load user profile names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QSYLAUTU( UserSpaceName: 'AUTU0200': ApiErrDS); // process data from user space. Autu0200ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // retrieve values from user profile. callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0300': UsrPrf: ApiErrDS); // Check selection conditions IsOneWeWant = *off; 2b if p_Status = '*ALL ' or Usri0300DS.Status = p_Status; 3b if p_Class = '*ALL ' or Usri0300DS.UserClass = p_Class; 4b if pHeadArry(1) = '*ALL '; IsOneWeWant = *on; 4x else; 5b for xx = 1 to 8; 6b if Usri0300DS.ApiAuthArry(xx) = SelectArry(xx); IsOneWeWant = *on; 5v leave; 6e endif; 5e endfor; 4e endif; 3e endif; 2e endif; 2b if IsOneWeWant; LastUsed = f_GetApiISO(Usri0300DS.PrvSignDatTim); 3b for xx = 1 to 8; 4b if Usri0300DS.ApiAuthArry(xx) = 'Y'; pDetailArry(xx) = 'Y'; 4x else; pDetailArry(xx) = '.'; 4e endif; 3e endfor; pdClass = Usri0300DS.UserClass; write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; Autu0200Ptr += GenericHeader.ListEntrySize; 1e endfor; close JCRUSRAUTP; f_DspLastSplf('JCRUSRAUTR': p_Output); *inlr = *on; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRUSRJOBD - List user profiles with selected jobd - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List User Profile with JOBD') PARM KWD(JOBD) TYPE(JOBD) MIN(1) PGM(*YES) + PROMPT('Job Description:') JOBD: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*JOBD ') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRUSRJOBD'.List user profiles with selected jobd (JCRUSRJOBD) Help .*-------------------------------------------------------------------- :P.This JCR command generates report showing user profiles with selected job description.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRUSRJOBD/JOBD'.Job Description - Help :XH3.Job Description (JOBD) :P.Job description to search user profiles.:EHELP. :HELP name='JCRUSRJOBD/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRUSRJOB - List user profiles with selected jobd - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSRJOBD' A 20'User Profiles with selected JOBD' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'JOBD:' A SCOBJHEAD 105A 8SPACEA(2) *--- A 2'User Profile' A 16'LAST USED' A 28'TEXT' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A USRPRF 10A O 2 A LASTUSED 10A O 16 A USRPRFTXT 33A O 28 ]]> v5r4 //--------------------------------------------------------- // JCRUSRJOBR - List user profiles with selected jobd //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUSRJOBPo e printer oflind(IsOverFlow) usropn //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetApiISO /Define f_GetDayName /Define f_BuildString /Define f_Qusrobjd /Define UserProfiles /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRUSRJOBR PR extpgm('JCRUSRJOBR') D 20a D 10a D 8a D p_JCRUSRJOBR PI D p_JobdQual 20a D p_ObjTyp 10a D p_Output 8a //--------------------------------------------------------- /free open JCRUSRJOBP; evalr scDow = %trimr(f_GetDayName()); QusrObjDS = f_QUSROBJD(p_JobdQual: p_ObjTyp: 'OBJD0200'); %subst(p_JobdQual: 11: 10) = QusrObjDS.ReturnLib; scObjHead = f_BuildString('& & &': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: QusrObjDS.Text); write PrtHead; // load user profile names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QSYLAUTU( UserSpaceName: 'AUTU0200': ApiErrDS); // process data from user space. Autu0200ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // retrieve values from user profile. callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0300': UsrPrf: ApiErrDS); // Check selection conditions 2b if Usri0300DS.JobdQual = p_JobdQual; LastUsed = f_GetApiISO(Usri0300DS.PrvSignDatTim); write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; Autu0200Ptr += GenericHeader.ListEntrySize; 1e endfor; close JCRUSRJOBP; f_DspLastSplf('JCRUSRJOBR': p_Output); *inlr = *on; ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCRUSROUTQ'.List user profiles with selected outq (JCRUSROUTQ) Help .*-------------------------------------------------------------------- :P.This JCR command generates report showing user profiles with selected outq.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCRUSROUTQ/OUTQ'.Outq - Help :XH3.Outq (OUTQ) :P.Outq name to search user profiles.:EHELP. :HELP name='JCRUSROUTQ/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT only or * also display the print file.:EHELP.:EPNLGRP. ]]> v5r4 *---------------------------------------------------------------- * JCRUSROUT - List user profiles with selected outq - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSROUTQ' A 20'User Profiles with selected OUTQ' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'OUTQ:' A SCOBJHEAD 105A 8SPACEA(2) *--- A 2'User Profile' A 16'LAST USED' A 28'TEXT' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A USRPRF 10A O 2 A LASTUSED 10A O 16 A USRPRFTXT 33A O 28 ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCRUSROUTQ - List user profiles with selected outq - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List User Profile with OUTQ') PARM KWD(OUTQ) TYPE(OUTQ) MIN(1) PGM(*YES) + PROMPT('Outq:') OUTQ: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*OUTQ ') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(*PRINT *) PROMPT('Output:') ]]> v5r4 //--------------------------------------------------------- // JCRUSROUTR - List user profiles with selected outq //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUSROUTPo e printer oflind(IsOverFlow) usropn //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetApiISO /Define f_GetDayName /Define f_BuildString /Define f_Qusrobjd /Define UserProfiles /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRUSROUTR PR extpgm('JCRUSROUTR') D 20a D 10a D 8a D p_JCRUSROUTR PI D p_OutqQual 20a D p_ObjTyp 10a D p_Output 8a //--------------------------------------------------------- /free open JCRUSROUTP; evalr scDow = %trimr(f_GetDayName()); QusrObjDS = f_QUSROBJD(p_OutqQual: p_ObjTyp: 'OBJD0200'); %subst(p_OutqQual: 11: 10) = QusrObjDS.ReturnLib; scObjHead = f_BuildString('& & &': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: QusrObjDS.Text); write PrtHead; // load user profile names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QSYLAUTU( UserSpaceName: 'AUTU0200': ApiErrDS); // process data from user space. Autu0200ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // retrieve values from user profile. callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0300': UsrPrf: ApiErrDS); // Check selection conditions 2b if Usri0300DS.OutqQual = p_OutqQual; LastUsed = f_GetApiISO(Usri0300DS.PrvSignDatTim); write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; Autu0200Ptr += GenericHeader.ListEntrySize; 1e endfor; close JCRUSROUTP; f_DspLastSplf('JCRUSROUTR': p_Output); *inlr = *on; ]]> v5r4 *---------------------------------------------------------------- * JCRUSRPRFP - List enabled profiles and last signon date - PRTF *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSRPRF' A 21'Enabled User Profiles Last Sign-On- A Date Times' A SCDOW 9A O 72 A 82DATE EDTWRD(' / / ') A 92TIME EDTWRD(' : : ') A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) *--- A 4'User profile' A 18'Text' A 58'Last Signon Date' A 78'Time' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A USRPRF 10A O 6 A USRPRFTXT 40A O 18 A USRDATE 10A O 61 A USRTIME 8A O 77 ]]> v5r4 //--------------------------------------------------------- // JCRUSRPRFR - List enabled profiles and last signon date //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRUSRPRFPo e printer oflind(IsOverFlow) usropn //--*COPY DEFINES------------------------------------------ /Define f_Quscrtus /Define ApiErrDS /Define UserSpaceHeaderDS /Define f_GetDayName /Define f_GetApiISO /Define f_GetApiHMS /Define f_DspLastSplf /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D Autu0200DS ds based(Autu0200ptr) D UsrPrf 10a overlay(Autu0200DS:1) D UsrPrfTxt 40a overlay(Autu0200DS:21) D Usri0100DS DS 83 qualified inz D PrvSignDatTim 13a overlay(usri0100DS:19) D Status 10a overlay(usri0100DS:37) //--*CALL PROTOTYPES--------------------------------------- D qsylautu PR extpgm('QSYLAUTU') D 20a UserSpaceName D 8a const format Db like(ApiErrDS) D qsyrusri PR extpgm('QSYRUSRI') D 83a USRI0100DS D 10i 0 const receiver len D 8a const format D 10a user profile Db like(ApiErrDS) //--*ENTRY PARMS *NONE* ----------------------------------- /free open JCRUSRPRFP; evalr scDow = %trimr(f_GetDayName()); write PrtHead; // load user profile names into user space. GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QSYLAUTU( UserSpaceName: 'AUTU0200': ApiErrDS); // process data from user space. Autu0200ptr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; // retrieve values from user profile. callp QSYRUSRI( Usri0100DS: 83: 'USRI0100': UsrPrf: ApiErrDS); 2b if Usri0100DS.Status = '*ENABLED '; UsrDate = f_GetApiISO(Usri0100DS.PrvSignDatTim); UsrTime = f_GetApiHMS(Usri0100DS.PrvSignDatTim); write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; Autu0200Ptr += GenericHeader.ListEntrySize; 1e endfor; close JCRUSRPRFP; f_DspLastSplf('JCRUSRPRFR': '* '); *inlr = *on; ]]> v5r4 //--------------------------------------------------------- // JCRVALLIBV - Validity checking program for library name //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRVALLIBV PR extpgm('JCRVALLIBV') D 20a D p_JCRVALLIBV PI D p_ObjQual 20a //--------------------------------------------------------- /free 1b if not (%subst(p_ObjQual: 11: 10) = '*LIBL ' or %subst(p_ObjQual: 11: 10) = '*ALLUSR ' or %subst(p_ObjQual: 11: 10) = '*ALL '); f_CheckObj(%subst(p_ObjQual:11:10)+'QSYS ':'*LIB '); 1e endif; *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRVALMBRV - Validity checking program for lib/file/member //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRVALMBRV PR extpgm('JCRVALMBRV') D 10a D 20a D p_JCRVALMBRV PI D p_Mbr 10a D p_FileQual 20a //--------------------------------------------------------- /free f_CheckMbr(p_FileQual : p_Mbr); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCRVALOBJV - Validity checking program for lib/obj/objtype //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCRVALOBJV PR extpgm('JCRVALOBJV') D 20a const D 10a const D p_JCRVALOBJV PI D p_ObjQual 20a const D p_ObjTyp 10a const //--------------------------------------------------------- /free f_CheckObj(p_ObjQual: p_ObjTyp); *inlr = *on; return; ]]> v5r4 //---------------------------------------------------------- // JCRZANIM0 - display binary clock // Array naming is there are 3 lines of characters on screen. BitPlace correspond to bit // place holders 6 to 1 with 1 being ones place. Rows are number of rows that make up // each character // Fun to watch for about two minutes. //---------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM0Dcf e workstn //--*STAND ALONE------------------------------------------- D PreviousSecond s 3u 0 D CurrTime s t inz D BitPlace s 3u 0 //--*FUNCTION PROTOTYPES----------------------------------- D f_FillGrid PR D 3u 0 const D 2p 0 //--*COPY DEFINES------------------------------------------ /Define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- // Define 3D arrays for screen manipulations D HmsLine ds dim(3) qualified based(DspPtr) D BitPlace likeds(BitPlacex) dim(6) D BitPlacex ds qualified D Row 9a dim(5) D DspPtr s * inz(%addr(DspDs)) D HmsAtr ds dim(3) qualified based(AtrPtr) D BitPlace 1a dim(6) D AtrPtr s * inz(%addr(AtrDs)) D DspDS ds D Grid16_L1 D Grid16_L2 D Grid16_L3 D Grid16_L4 D Grid16_L5 D Grid15_L1 D Grid15_L2 D Grid15_L3 D Grid15_L4 D Grid15_L5 D Grid14_L1 D Grid14_L2 D Grid14_L3 D Grid14_L4 D Grid14_L5 D Grid13_L1 D Grid13_L2 D Grid13_L3 D Grid13_L4 D Grid13_L5 D Grid12_L1 D Grid12_L2 D Grid12_L3 D Grid12_L4 D Grid12_L5 D Grid11_L1 D Grid11_L2 D Grid11_L3 D Grid11_L4 D Grid11_L5 D Grid26_L1 D Grid26_L2 D Grid26_L3 D Grid26_L4 D Grid26_L5 D Grid25_L1 D Grid25_L2 D Grid25_L3 D Grid25_L4 D Grid25_L5 D Grid24_L1 D Grid24_L2 D Grid24_L3 D Grid24_L4 D Grid24_L5 D Grid23_L1 D Grid23_L2 D Grid23_L3 D Grid23_L4 D Grid23_L5 D Grid22_L1 D Grid22_L2 D Grid22_L3 D Grid22_L4 D Grid22_L5 D Grid21_L1 D Grid21_L2 D Grid21_L3 D Grid21_L4 D Grid21_L5 D Grid36_L1 D Grid36_L2 D Grid36_L3 D Grid36_L4 D Grid36_L5 D Grid35_L1 D Grid35_L2 D Grid35_L3 D Grid35_L4 D Grid35_L5 D Grid34_L1 D Grid34_L2 D Grid34_L3 D Grid34_L4 D Grid34_L5 D Grid33_L1 D Grid33_L2 D Grid33_L3 D Grid33_L4 D Grid33_L5 D Grid32_L1 D Grid32_L2 D Grid32_L3 D Grid32_L4 D Grid32_L5 D Grid31_L1 D Grid31_L2 D Grid31_L3 D Grid31_L4 D Grid31_L5 D ATRDS ds D atr16 D atr15 D atr14 D atr13 D atr12 D atr11 D atr26 D atr25 D atr24 D atr23 D atr22 D atr21 D atr36 D atr35 D atr34 D atr33 D atr32 D atr31 //--*ENTRY PARMS *NONE* ----------------------------------- /free evalr scDow = %trimr(f_GetDayName()); 1b dou 1 = 2; 2b dou eSecond <> PreviousSecond; CurrTime = %time(); eSecond = %subdt(CurrTime:*S); 2e enddo; PreviousSecond = eSecond; f_FillGrid(3:eSecond); eMinute = %subdt(CurrTime:*MN); f_FillGrid(2:eMinute); eHour = %subdt(CurrTime:*H); f_FillGrid(1:eHour); write clockd; 1e enddo; *inlr = *on; /end-free //--------------------------------------------------------- // Load characters and attributes for binary values // the idea is, as first 0 is set to 1, every thing before that position = 0 // works slick. P f_FillGrid b D f_FillGrid PI D pLine 3u 0 const D pValue 2p 0 D binary s 3u 0 inz dim(6) D xx s 3u 0 D yy s 3u 0 D zz s 3u 0 D White c const(x'22') D Pink c const(x'38') /free binary(*) = 0; 1b for xx = 1 to pValue; yy = %lookup(0:binary); binary(yy) = 1; 2b for zz = 1 to (yy-1); binary(zz) = 0; 2e endfor; 1e endfor; 1b for BitPlace = 6 downto 1; 2b if binary(BitPlace) = 1; //binary bit on HmsAtr(pLine).BitPlace(BitPlace) = Pink; HmsLine(pLine).BitPlace(BitPlace).Row(1) = ' 1111 '; HmsLine(pLine).BitPlace(BitPlace).Row(2) = ' 111 '; HmsLine(pLine).BitPlace(BitPlace).Row(3) = ' 111 '; HmsLine(pLine).BitPlace(BitPlace).Row(4) = ' 111 '; HmsLine(pLine).BitPlace(BitPlace).Row(5) = ' 1111111 '; 2x else; HmsAtr(pLine).BitPlace(BitPlace) = White; HmsLine(pLine).BitPlace(BitPlace).Row(1) = ' 00000 '; HmsLine(pLine).BitPlace(BitPlace).Row(2) = ' 00 00 '; HmsLine(pLine).BitPlace(BitPlace).Row(3) = '00 00'; HmsLine(pLine).BitPlace(BitPlace).Row(4) = ' 00 00 '; HmsLine(pLine).BitPlace(BitPlace).Row(5) = ' 00000 '; 2e endif; 1e endfor; /end-free P f_FillGrid e ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM0D - Animation- Binary Clock - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R CLOCKD FRCDTA A ATR11 1A P A ATR12 1A P A ATR13 1A P A ATR21 1A P A ATR22 1A P A ATR23 1A P A ATR31 1A P A ATR32 1A P A ATR33 1A P A ATR14 1A P A ATR15 1A P A ATR16 1A P A ATR24 1A P A ATR25 1A P A ATR26 1A P A ATR34 1A P A ATR35 1A P A ATR36 1A P A 1 3'JCRZANIM0' COLOR(BLU) A 1 25'Binary Clock' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 3'Hour' COLOR(BLU) A GRID11_L1 9A O 4 3DSPATR(&ATR11) A GRID12_L1 9A O 4 15DSPATR(&ATR12) A GRID13_L1 9A O 4 27DSPATR(&ATR13) A GRID14_L1 9A O 4 39DSPATR(&ATR14) A GRID15_L1 9A O 4 51DSPATR(&ATR15) A GRID16_L1 9A O 4 63DSPATR(&ATR16) A GRID11_L2 9A O 5 3DSPATR(&ATR11) A GRID12_L2 9A O 5 15DSPATR(&ATR12) A GRID13_L2 9A O 5 27DSPATR(&ATR13) A GRID14_L2 9A O 5 39DSPATR(&ATR14) A GRID15_L2 9A O 5 51DSPATR(&ATR15) A GRID16_L2 9A O 5 63DSPATR(&ATR16) A GRID11_L3 9A O 6 3DSPATR(&ATR11) A GRID12_L3 9A O 6 15DSPATR(&ATR12) A GRID13_L3 9A O 6 27DSPATR(&ATR13) A GRID14_L3 9A O 6 39DSPATR(&ATR14) A GRID15_L3 9A O 6 51DSPATR(&ATR15) A GRID16_L3 9A O 6 63DSPATR(&ATR16) A EHOUR 2 0O 6 76DSPATR(HI) A GRID11_L4 9A O 7 3DSPATR(&ATR11) A GRID12_L4 9A O 7 15DSPATR(&ATR12) A GRID13_L4 9A O 7 27DSPATR(&ATR13) A GRID14_L4 9A O 7 39DSPATR(&ATR14) A GRID15_L4 9A O 7 51DSPATR(&ATR15) A GRID16_L4 9A O 7 63DSPATR(&ATR16) A GRID11_L5 9A O 8 3DSPATR(&ATR11) A GRID12_L5 9A O 8 15DSPATR(&ATR12) A GRID13_L5 9A O 8 27DSPATR(&ATR13) A GRID14_L5 9A O 8 39DSPATR(&ATR14) A GRID15_L5 9A O 8 51DSPATR(&ATR15) A GRID16_L5 9A O 8 63DSPATR(&ATR16) A 10 3'Minute' COLOR(BLU) A GRID21_L1 9A O 11 3DSPATR(&ATR21) A GRID22_L1 9A O 11 15DSPATR(&ATR22) A GRID23_L1 9A O 11 27DSPATR(&ATR23) A GRID24_L1 9A O 11 39DSPATR(&ATR24) A GRID25_L1 9A O 11 51DSPATR(&ATR25) A GRID26_L1 9A O 11 63DSPATR(&ATR26) A GRID21_L2 9A O 12 3DSPATR(&ATR21) A GRID22_L2 9A O 12 15DSPATR(&ATR22) A GRID23_L2 9A O 12 27DSPATR(&ATR23) A GRID24_L2 9A O 12 39DSPATR(&ATR24) A GRID25_L2 9A O 12 51DSPATR(&ATR25) A GRID26_L2 9A O 12 63DSPATR(&ATR26) A GRID21_L3 9A O 13 3DSPATR(&ATR21) A GRID22_L3 9A O 13 15DSPATR(&ATR22) A GRID23_L3 9A O 13 27DSPATR(&ATR23) A GRID24_L3 9A O 13 39DSPATR(&ATR24) A GRID25_L3 9A O 13 51DSPATR(&ATR25) A GRID26_L3 9A O 13 63DSPATR(&ATR26) A EMINUTE 2 0O 13 76DSPATR(HI) A GRID21_L4 9A O 14 3DSPATR(&ATR21) A GRID22_L4 9A O 14 15DSPATR(&ATR22) A GRID23_L4 9A O 14 27DSPATR(&ATR23) A GRID24_L4 9A O 14 39DSPATR(&ATR24) A GRID25_L4 9A O 14 51DSPATR(&ATR25) A GRID26_L4 9A O 14 63DSPATR(&ATR26) A GRID21_L5 9A O 15 3DSPATR(&ATR21) A GRID22_L5 9A O 15 15DSPATR(&ATR22) A GRID23_L5 9A O 15 27DSPATR(&ATR23) A GRID24_L5 9A O 15 39DSPATR(&ATR24) A GRID25_L5 9A O 15 51DSPATR(&ATR25) A GRID26_L5 9A O 15 63DSPATR(&ATR26) A 17 3'Second' COLOR(BLU) A GRID31_L1 9A O 18 3DSPATR(&ATR31) A GRID32_L1 9A O 18 15DSPATR(&ATR32) A GRID33_L1 9A O 18 27DSPATR(&ATR33) A GRID34_L1 9A O 18 39DSPATR(&ATR34) A GRID35_L1 9A O 18 51DSPATR(&ATR35) A GRID36_L1 9A O 18 63DSPATR(&ATR36) A GRID31_L2 9A O 19 3DSPATR(&ATR31) A GRID32_L2 9A O 19 15DSPATR(&ATR32) A GRID33_L2 9A O 19 27DSPATR(&ATR33) A GRID34_L2 9A O 19 39DSPATR(&ATR34) A GRID35_L2 9A O 19 51DSPATR(&ATR35) A GRID36_L2 9A O 19 63DSPATR(&ATR36) A GRID31_L3 9A O 20 3DSPATR(&ATR31) A GRID32_L3 9A O 20 15DSPATR(&ATR32) A GRID33_L3 9A O 20 27DSPATR(&ATR33) A GRID34_L3 9A O 20 39DSPATR(&ATR34) A GRID35_L3 9A O 20 51DSPATR(&ATR35) A GRID36_L3 9A O 20 63DSPATR(&ATR36) A ESECOND 2 0O 20 76DSPATR(HI) A GRID31_L4 9A O 21 3DSPATR(&ATR31) A GRID32_L4 9A O 21 15DSPATR(&ATR32) A GRID33_L4 9A O 21 27DSPATR(&ATR33) A GRID34_L4 9A O 21 39DSPATR(&ATR34) A GRID35_L4 9A O 21 51DSPATR(&ATR35) A GRID36_L4 9A O 21 63DSPATR(&ATR36) A GRID31_L5 9A O 22 3DSPATR(&ATR31) A GRID32_L5 9A O 22 15DSPATR(&ATR32) A GRID33_L5 9A O 22 27DSPATR(&ATR33) A GRID34_L5 9A O 22 39DSPATR(&ATR34) A GRID35_L5 9A O 22 51DSPATR(&ATR35) A GRID36_L5 9A O 22 63DSPATR(&ATR36) A 24 45'Sysreq 2 to Exit' ]]> v5r4 //--------------------------------------------------------- // JCRZANIM1 - show boxes going around screen having fun with window positioning //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM1Dcf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D f03 c const(X'33') D RI c const(x'01') D ND c const(x'27') D xx s 3u 0 D Spatial s 3u 0 D RepeatCount s 3u 0 D ColorCnt s 3u 0 D StartStamp s z inz //--*DATA STRUCTURES--------------------------------------- D Infds ds D fkey 1a overlay(infds:369) D ColorDs ds D Green 1a inz(x'20') D White 1a inz(x'22') D Red 1a inz(x'28') D Turq 1a inz(x'30') D Yellow 1a inz(x'32') D Pink 1a inz(x'38') D Blue 1a inz(x'3A') D ColorArry 1a dim(7) overlay(ColorDs:1) //--*ENTRY PARMS *NONE* ----------------------------------- /free // SPIN CLOCKWISE AtrCol = ND; ColorCnt = 1; 1b for RepeatCount = 1 to 3; Spatial = 63; 2b for xx = 7 by 7 to 63; AtrRow = %bitor(ColorArry(ColorCnt): RI); wRow = 3; // top wCol = xx; write BlockS; wRow = 19; // bottom wCol = Spatial; write BlockS; exsr srWaitForTimer; write exitscreen; Spatial -= 7; exsr srColorCount; 2e endfor; //--------------------------------------------------------- // now do the sides AtrRow = ND; Spatial = 18; 2b for xx = 4 by 2 to 18; AtrRow = %bitor(ColorArry(ColorCnt): RI); wRow = Spatial; // left wCol = 7; write BlockS; wRow = xx; // right wCol = 67; write BlockS; exsr srWaitForTimer; write exitscreen; Spatial -= 2; exsr srColorCount; 2e endfor; 1e endfor; exfmt EXITSCREEN; 1b if fkey = f03; *inlr = *on; return; 1e endif; //--------------------------------------------------------- // SPIN COUNTER-CLOCKWISE 1b for RepeatCount = 1 to 3; Spatial = 63; 2b for xx = 7 by 7 to 63; AtrRow = %bitor(ColorArry(ColorCnt): RI); wRow = 3; // top wCol = Spatial; write BlockS; wRow = 19; // bottom wCol = xx; write BlockS; exsr srWaitForTimer; write exitscreen; Spatial -= 7; exsr srColorCount; 2e endfor; //--------------------------------------------------------- // now do the sides AtrRow = ND; Spatial = 18; 2b for xx = 4 by 2 to 18; AtrRow = %bitor(ColorArry(ColorCnt): RI); wRow = xx; // left wCol = 7; write BlockS; wRow = Spatial; // right wCol = 67; write BlockS; exsr srWaitForTimer; write exitscreen; Spatial -= 2; exsr srColorCount; 2e endfor; 1e endfor; exfmt EXITSCREEN; 1b if fkey = f03; *inlr = *on; return; 1e endif; //--------------------------------------------------------- begsr srColorCount; ColorCnt += 1; 1b if ColorCnt = 8; ColorCnt = 1; 1e endif; endsr; // Wait for selected number of milliseconds. begsr srWaitForTimer; startstamp = %timestamp() + %MSECONDS(25000); 1b dou %timestamp() > StartStamp; 1e enddo; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM1D - Animation- boxes going around the screen - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CF03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R EXITSCREEN FRCDTA A 9 31'JCRZANIM1' COLOR(BLU) A 11 31'ENTER - TO CONTINUE' DSPATR(HI) A 13 31'F3 - EXIT' DSPATR(HI) *---------------------------------------------------------------- A R BLOCKS FRCDTA A WINDOW(&WROW &WCOL 2 7 *NOMSGLIN) A WDWBORDER((*COLOR BLU) (*DSPATR ND)) A ATRROW 1A P A ATRCOL 1A P A WROW 2S 0P A WCOL 2S 0P A 1 1' ' DSPATR(&ATRROW) A 1 1' ' DSPATR(&ATRCOL) A 2 1' ' DSPATR(&ATRCOL) ]]> v5r4 //--------------------------------------------------------- // JCRZANIM2 - show boxes coming out of the screen, then boxes going into the screen. // Reminds me of the old FRACINIT fractal colorings. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM2Dcf e workstn infds(Infds) //--*STAND ALONE------------------------------------------- D f01 c const(X'31') D f03 c const(X'33') D xx s 3u 0 D yy s 3u 0 D RepeatCount s 3u 0 D StartStamp s z inz D RI c const(x'01') D HI c const(x'02') D UL c const(x'04') D PR c const(x'80') D Color1to7 s 3u 0 //--*DATA STRUCTURES--------------------------------------- D ColorsDS ds D Blue 1a inz(x'3A') D White 1a inz(x'22') D Red 1a inz(x'28') D Green 1a inz(x'20') D Turq 1a inz(x'30') D Yellow 1a inz(x'32') D Pink 1a inz(x'38') D ND 1a inz(x'27') D ColorsArry 1a dim(8) overlay(colorsDS) D Infds ds D fkey 1 overlay(Infds:369) // map screen fields into DS can work with as array D AnimateDS ds inz D ring1 D ring2 D ring3 D ring4 D ring5 D ring6 D ring7 D ring8 D ring9 D AtrArray 1a dim(9) overlay(AnimateDS) //--*ENTRY PARMS *NONE* ----------------------------------- /free atrarray(*) = x'00'; Color1to7 = 1; 1b dou 1 = 2; 2b for xx = 1 to 9; exfmt BATSCREEN; 3b if fkey = f03; *inlr = *on; return; 3e endif; 3b if fkey = f01; 4b for yy = 9 downto 2; AtrArray(yy) = AtrArray(yy-1); 4e endfor; AtrArray(1) = %bitor(ColorsArry(color1to7): RI); 3x else; 4b for yy = 1 to 8; AtrArray(yy) = AtrArray(yy+1); 4e endfor; AtrArray(9) = %bitor(ColorsArry(color1to7): RI); 3e endif; Color1to7 += 1; 3b if Color1to7 = 9; Color1to7 = 1; 3e endif; 2e endfor; 1e enddo; //--------------------------------------------------------- // Wait for selected number of milliseconds. begsr srWaitForTimer; startstamp = %timestamp() + %MSECONDS(25000); 1b dou %timestamp() > StartStamp; 1e enddo; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM2D - Animation- warp speed effect - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA01 CA02 CF03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R EXITSCREEN A 12 31'Cmd3 - EXIT' *---------------------------------------------------------------- A R BATSCREEN FRCDTA OVERLAY A RING1 1A P A RING2 1A P A RING3 1A P A RING4 1A P A RING5 1A P A RING6 1A P A RING7 1A P A RING8 1A P A RING9 1A P A 4 4' ' DSPATR(&RING9) A 4 9' ' DSPATR(&RING9) A 4 25' ' DSPATR(&RING9) A 4 41' ' DSPATR(&RING9) A 4 57' ' DSPATR(&RING9) A 4 73' ' DSPATR(&RING9) A 5 4' ' DSPATR(&RING9) A 5 8' ' DSPATR(&RING8) A 5 13' ' DSPATR(&RING8) A 5 27' ' DSPATR(&RING8) A 5 41' ' DSPATR(&RING8) A 5 55' ' DSPATR(&RING8) A 5 69' ' DSPATR(&RING8) A 5 75' ' DSPATR(&RING9) A 6 4' ' DSPATR(&RING9) A 6 8' ' DSPATR(&RING8) A 6 12' ' DSPATR(&RING7) A 6 17' ' DSPATR(&RING7) A 6 29' ' DSPATR(&RING7) A 6 41' ' DSPATR(&RING7) A 6 53' ' DSPATR(&RING7) A 6 65' ' DSPATR(&RING7) A 6 71' ' DSPATR(&RING8) A 6 75' ' DSPATR(&RING9) A 7 4' ' DSPATR(&RING9) A 7 8' ' DSPATR(&RING8) A 7 12' ' DSPATR(&RING7) A 7 16' ' DSPATR(&RING6) A 7 21' ' DSPATR(&RING6) A 7 31' ' DSPATR(&RING6) A 7 41' ' DSPATR(&RING6) A 7 51' ' DSPATR(&RING6) A 7 61' ' DSPATR(&RING6) A 7 67' ' DSPATR(&RING7) A 7 71' ' DSPATR(&RING8) A 7 75' ' DSPATR(&RING9) A 8 4' ' DSPATR(&RING9) A 8 8' ' DSPATR(&RING8) A 8 12' ' DSPATR(&RING7) A 8 16' ' DSPATR(&RING6) A 8 20' ' DSPATR(&RING5) A 8 25' 'DSPATR(&RING5) A 8 33' 'DSPATR(&RING5) A 8 41' 'DSPATR(&RING5) A 8 49' 'DSPATR(&RING5) A 8 57' ' DSPATR(&RING5) A 8 63' ' DSPATR(&RING6) A 8 67' ' DSPATR(&RING7) A 8 71' ' DSPATR(&RING8) A 8 75' ' DSPATR(&RING9) A 9 4' ' DSPATR(&RING9) A 9 8' ' DSPATR(&RING8) A 9 12' ' DSPATR(&RING7) A 9 16' ' DSPATR(&RING6) A 9 20' ' DSPATR(&RING5) A 9 24' ' DSPATR(&RING4) A 9 29' ' DSPATR(&RING4) A 9 35' ' DSPATR(&RING4) A 9 41' ' DSPATR(&RING4) A 9 47' ' DSPATR(&RING4) A 9 53' ' DSPATR(&RING4) A 9 59' ' DSPATR(&RING5) A 9 63' ' DSPATR(&RING6) A 9 67' ' DSPATR(&RING7) A 9 71' ' DSPATR(&RING8) A 9 75' ' DSPATR(&RING9) A 10 4' ' DSPATR(&RING9) A 10 8' ' DSPATR(&RING8) A 10 12' ' DSPATR(&RING7) A 10 16' ' DSPATR(&RING6) A 10 20' ' DSPATR(&RING5) A 10 24' ' DSPATR(&RING4) A 10 28' ' DSPATR(&RING3) A 10 33' ' DSPATR(&RING3) A 10 37' ' DSPATR(&RING3) A 10 41' ' DSPATR(&RING3) A 10 45' ' DSPATR(&RING3) A 10 49' ' DSPATR(&RING3) A 10 55' ' DSPATR(&RING4) A 10 59' ' DSPATR(&RING5) A 10 63' ' DSPATR(&RING6) A 10 67' ' DSPATR(&RING7) A 10 71' ' DSPATR(&RING8) A 10 75' ' DSPATR(&RING9) A 11 4' ' DSPATR(&RING9) A 11 8' ' DSPATR(&RING8) A 11 12' ' DSPATR(&RING7) A 11 16' ' DSPATR(&RING6) A 11 20' ' DSPATR(&RING5) A 11 24' ' DSPATR(&RING4) A 11 28' ' DSPATR(&RING3) A 11 32' ' DSPATR(&RING2) A 11 39' ' DSPATR(&RING2) A 11 41' ' DSPATR(&RING2) A 11 43' ' DSPATR(&RING2) A 11 51' ' DSPATR(&RING3) A 11 55' ' DSPATR(&RING4) A 11 59' ' DSPATR(&RING5) A 11 63' ' DSPATR(&RING6) A 11 67' ' DSPATR(&RING7) A 11 71' ' DSPATR(&RING8) A 11 75' ' DSPATR(&RING9) A 12 4' ' DSPATR(&RING9) A 12 8' ' DSPATR(&RING8) A 12 12' ' DSPATR(&RING7) A 12 16' ' DSPATR(&RING6) A 12 20' ' DSPATR(&RING5) A 12 24' ' DSPATR(&RING4) A 12 28' ' DSPATR(&RING3) A 12 32' ' DSPATR(&RING2) A 12 36' ' DSPATR(&RING1) A 12 41' ' DSPATR(&RING1) A 12 47' ' DSPATR(&RING2) A 12 51' ' DSPATR(&RING3) A 12 55' ' DSPATR(&RING4) A 12 59' ' DSPATR(&RING5) A 12 63' ' DSPATR(&RING6) A 12 67' ' DSPATR(&RING7) A 12 71' ' DSPATR(&RING8) A 12 75' ' DSPATR(&RING9) A 13 4' ' DSPATR(&RING9) A 13 8' ' DSPATR(&RING8) A 13 12' ' DSPATR(&RING7) A 13 16' ' DSPATR(&RING6) A 13 20' ' DSPATR(&RING5) A 13 24' ' DSPATR(&RING4) A 13 28' ' DSPATR(&RING3) A 13 32' ' DSPATR(&RING2) A 13 36' ' DSPATR(&RING1) A 13 41' ' DSPATR(&RING1) A 13 47' ' DSPATR(&RING2) A 13 51' ' DSPATR(&RING3) A 13 55' ' DSPATR(&RING4) A 13 59' ' DSPATR(&RING5) A 13 63' ' DSPATR(&RING6) A 13 67' ' DSPATR(&RING7) A 13 71' ' DSPATR(&RING8) A 13 75' ' DSPATR(&RING9) A 14 4' ' DSPATR(&RING9) A 14 8' ' DSPATR(&RING8) A 14 12' ' DSPATR(&RING7) A 14 16' ' DSPATR(&RING6) A 14 20' ' DSPATR(&RING5) A 14 24' ' DSPATR(&RING4) A 14 28' ' DSPATR(&RING3) A 14 32' ' DSPATR(&RING2) A 14 39' ' DSPATR(&RING2) A 14 41' ' DSPATR(&RING2) A 14 43' ' DSPATR(&RING2) A 14 51' ' DSPATR(&RING3) A 14 55' ' DSPATR(&RING4) A 14 59' ' DSPATR(&RING5) A 14 63' ' DSPATR(&RING6) A 14 67' ' DSPATR(&RING7) A 14 71' ' DSPATR(&RING8) A 14 75' ' DSPATR(&RING9) A 15 4' ' DSPATR(&RING9) A 15 8' ' DSPATR(&RING8) A 15 12' ' DSPATR(&RING7) A 15 16' ' DSPATR(&RING6) A 15 20' ' DSPATR(&RING5) A 15 24' ' DSPATR(&RING4) A 15 28' ' DSPATR(&RING3) A 15 33' ' DSPATR(&RING3) A 15 37' ' DSPATR(&RING3) A 15 41' ' DSPATR(&RING3) A 15 45' ' DSPATR(&RING3) A 15 49' ' DSPATR(&RING3) A 15 55' ' DSPATR(&RING4) A 15 59' ' DSPATR(&RING5) A 15 63' ' DSPATR(&RING6) A 15 67' ' DSPATR(&RING7) A 15 71' ' DSPATR(&RING8) A 15 75' ' DSPATR(&RING9) A 16 4' ' DSPATR(&RING9) A 16 8' ' DSPATR(&RING8) A 16 12' ' DSPATR(&RING7) A 16 16' ' DSPATR(&RING6) A 16 20' ' DSPATR(&RING5) A 16 24' ' DSPATR(&RING4) A 16 29' ' DSPATR(&RING4) A 16 35' ' DSPATR(&RING4) A 16 41' ' DSPATR(&RING4) A 16 47' ' DSPATR(&RING4) A 16 53' ' DSPATR(&RING4) A 16 59' ' DSPATR(&RING5) A 16 63' ' DSPATR(&RING6) A 16 67' ' DSPATR(&RING7) A 16 71' ' DSPATR(&RING8) A 16 75' ' DSPATR(&RING9) A 17 4' ' DSPATR(&RING9) A 17 8' ' DSPATR(&RING8) A 17 12' ' DSPATR(&RING7) A 17 16' ' DSPATR(&RING6) A 17 20' ' DSPATR(&RING5) A 17 25' ' DSPATR(&RING5) A 17 33' ' DSPATR(&RING5) A 17 41' ' DSPATR(&RING5) A 17 49' ' DSPATR(&RING5) A 17 57' ' DSPATR(&RING5) A 17 63' ' DSPATR(&RING6) A 17 67' ' DSPATR(&RING7) A 17 71' ' DSPATR(&RING8) A 17 75' ' DSPATR(&RING9) A 18 4' ' DSPATR(&RING9) A 18 8' ' DSPATR(&RING8) A 18 12' ' DSPATR(&RING7) A 18 16' ' DSPATR(&RING6) A 18 21' ' DSPATR(&RING6) A 18 31' ' DSPATR(&RING6) A 18 41' ' DSPATR(&RING6) A 18 51' ' DSPATR(&RING6) A 18 61' ' DSPATR(&RING6) A 18 67' ' DSPATR(&RING7) A 18 71' ' DSPATR(&RING8) A 18 75' ' DSPATR(&RING9) A 19 4' ' DSPATR(&RING9) A 19 8' ' DSPATR(&RING8) A 19 12' ' DSPATR(&RING7) A 19 17' ' DSPATR(&RING7) A 19 29' ' DSPATR(&RING7) A 19 41' ' DSPATR(&RING7) A 19 53' ' DSPATR(&RING7) A 19 65' ' DSPATR(&RING7) A 19 71' ' DSPATR(&RING8) A 19 75' ' DSPATR(&RING9) A 20 4' ' DSPATR(&RING9) A 20 8' ' DSPATR(&RING8) A 20 13' ' DSPATR(&RING8) A 20 27' ' DSPATR(&RING8) A 20 41' ' DSPATR(&RING8) A 20 55' ' DSPATR(&RING8) A 20 69' ' DSPATR(&RING8) A 20 75' ' DSPATR(&RING9) A 21 4' ' DSPATR(&RING9) A 21 9' ' DSPATR(&RING9) A 21 25' ' DSPATR(&RING9) A 21 41' ' DSPATR(&RING9) A 21 57' ' DSPATR(&RING9) A 21 73' ' DSPATR(&RING9) A 24 3'Hold Down F1=Forward' COLOR(BLU) A 24 27'Hold Down F2=Backward' COLOR(BLU) A 24 53'F3=Exit' COLOR(BLU) ]]> v5r4 //--------------------------------------------------------- // JCRZANIM3 - raise a USA flag //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM3Dcf e workstn D StartStamp s z inz //--*ENTRY PARMS *NONE* ----------------------------------- /free Stars01 = ' * * * * * * * * * * '; Stars02 = Stars01; Stars03 = Stars01; Stars04 = Stars01; Stars05 = Stars01; wpos = 2; 1b for wlin = 10 downto 5; write SCREEN; exsr srWaitForTimer; 1e endfor; exfmt SCREEN; *inlr = *on; return; //--------------------------------------------------------- // Wait for selected number of milliseconds. begsr srWaitForTimer; startstamp = %timestamp() + %MSECONDS(80000); 1b dou %timestamp() > StartStamp; 1e enddo; endsr; ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM3D - Animation- raise a USA flag - DSPF *---------------------------------------------------------------- A CF03 CF12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN FRCDTA A WINDOW(&WLIN &WPOS 13 65 *NOMSGLIN) A WDWBORDER((*COLOR BLU) (*DSPATR ND)) A WLIN 2S 0P A WPOS 2S 0P A STARS01 21A 1 9DSPATR(HI RI CS BL) A STRIPE01 34A 1 31DSPATR(RI BL) A STARS02 21A 2 9DSPATR(HI RI CS BL) A STRIPE02 34A 2 31DSPATR(HI RI) A STARS03 21A 3 9DSPATR(HI RI CS BL) A STRIPE03 34A 3 31DSPATR(RI BL) A STARS04 21A 4 9DSPATR(HI RI CS BL) A STRIPE04 34A 4 31DSPATR(HI RI) A STARS05 21A 5 9DSPATR(HI RI CS BL) A STRIPE05 34A 5 31DSPATR(RI BL) A STRIPE06 56A 6 9DSPATR(HI RI) A STRIPE07 56A 7 9DSPATR(RI BL) A STRIPE08 56A 8 9DSPATR(HI RI) A STRIPE09 56A 9 9DSPATR(RI BL) A STRIPE10 56A 10 9DSPATR(HI RI) A STRIPE11 56A 11 9DSPATR(RI BL) A STRIPE12 56A 12 9DSPATR(HI RI) A STRIPE13 56A 13 9DSPATR(RI BL) ]]> v5r4 //--------------------------------------------------------- // JCRZANIM4 - Animation- classic I'm With Stupid pointing finger // After going through several models of s/38, as/400 and now iSeries with each new box // making the animation run faster and faster until it was little more than a blur. I // can't find anything C,RPG,COBOL, etc. that delays less than 1 second to control exactly // how fast the animation runs, regardless of processer. // I am going to do some horrible loop processing checking the time milliseconds. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM4Dcf e workstn //--*STAND ALONE------------------------------------------- d cc s 3u 0 d col s 3u 0 d Count s 3u 0 d DoCount s 3u 0 d SpinCount s 3u 0 D aText s 16a d WriteCount s 3u 0 D ColorCnt s 3u 0 d xx s 3u 0 D StartStamp s z inz //--*DATA STRUCTURES--------------------------------------- D ColorDs ds D Green 1a inz(x'20') D White 1a inz(x'22') D Red 1a inz(x'28') D Turq 1a inz(x'30') D Yellow 1a inz(x'32') D Pink 1a inz(x'38') D Blue 1a inz(x'3A') D ColorArry 1a dim(7) overlay(ColorDs:1) D GridRow ds dim(16) qualified based(ptr) D Col 1a dim(48) D Ptr s * inz(%addr(LIN001)) D AttrArry s 1a dim(16) based(ptr2) D Ptr2 s * inz(%addr(Atr01)) D FingArry s 12a dim(14) ctdata perrcd(1) // map screen fields into DS so arrays can manipulate values D ScreenDS ds D LIN001 D LIN002 D LIN003 D LIN004 D LIN005 D LIN006 D LIN007 D LIN008 D LIN009 D LIN010 D LIN011 D LIN012 D LIN013 D LIN014 D LIN015 D LIN016 D AttrDS ds D ATR01 D ATR02 D ATR03 D ATR04 D ATR05 D ATR06 D ATR07 D ATR08 D ATR09 D ATR10 D ATR11 D ATR12 D ATR13 D ATR14 D ATR15 D ATR16 //--------------------------------------------------------- /free im = 'I''M'; 1b for xx = 1 to 48; col = xx; aText = FingArry(1); exsr srWriteScreen; SpinCount = 0; 2b for DoCount = 2 to xx; aText = FingArry(2); exsr srWriteScreen; SpinCount += 1; 3b if SpinCount = 19; 2v leave; 3e endif; 2e endfor; 2b if xx >= 21; aText = FingArry(3); exsr srWriteScreen; 2e endif; 2b if xx >= 22; aText = FingArry(4); exsr srWriteScreen; 2e endif; 2b if xx >= 23; aText = FingArry(5); exsr srWriteScreen; 2e endif; 2b if xx >= 24; aText = FingArry(6); exsr srWriteScreen; 2e endif; 2b if xx >= 25; aText = FingArry(6); exsr srWriteScreen; 2e endif; 2b if xx >= 26; aText = FingArry(6); exsr srWriteScreen; 2e endif; 2b if xx >= 27; aText = FingArry(6); exsr srWriteScreen; 2e endif; 2b if xx >= 28; aText = FingArry(6); exsr srWriteScreen; 2e endif; 2b if xx >= 29; aText = FingArry(7); exsr srWriteScreen; 2e endif; 2b if xx >= 30; aText = FingArry(8); exsr srWriteScreen; 2e endif; 2b if xx >= 31; aText = FingArry(9); exsr srWriteScreen; 2e endif; 2b if xx >= 32; aText = FingArry(10); exsr srWriteScreen; 2e endif; 2b if xx >= 33; aText = FingArry(10); exsr srWriteScreen; 2e endif; 2b if xx >= 34; aText = FingArry(11); exsr srWriteScreen; 2e endif; 2b if xx >= 35; aText = FingArry(11); exsr srWriteScreen; 2e endif; 2b if xx >= 36; aText = FingArry(12); exsr srWriteScreen; 2e endif; 2b if xx >= 37; aText = FingArry(12); exsr srWriteScreen; 2e endif; 2b if xx >= 38; aText = FingArry(13); exsr srWriteScreen; 2e endif; 2b if xx >= 39; aText = FingArry(13); exsr srWriteScreen; 2e endif; 2b if xx >= 40; aText = FingArry(14); exsr srWriteScreen; 2e endif; 1e endfor; exfmt screen; *inlr = *on; //--------------------------------------------------------- // the idea here is translate the X and blanks in the text string // into Xs at the row,col of the screen array. // Example: ' X X ' and ColCount = 2 // the first X is in position 4, so grid.row(4).col(2) = 'X' // second X is in position 6, so grid.row(6).col(2) = 'X' // so I would have X // // X on the screen //--------------------------------------------------------- begsr srWriteScreen; 1b for cc = 1 to 16; // number of lines on screen GridRow(cc).Col(Col) = %subst(aText:cc:1); ColorCnt += 1; 2b if ColorCnt = 8; ColorCnt = 1; 2e endif; AttrArry(cc) = ColorArry(ColorCnt); 1e endfor; col -= 1; write screen; //--------------------------------------------------------- // Wait for selected number of milliseconds. // If too fast on your system, uncomment this section //startstamp = %timestamp() + %MSECONDS(5000); //dou %timestamp() > StartStamp; //enddo; endsr; /end-free ** XX 1 X X 2 X XXX 3 X X X 4 X X XXXX 5 X X X X X 6 XX X X X X 7 X X X X X 8 X X X 9 X X 10 X X 11 X X 12 XXXXXX 13 X X 14 ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM4D - Animation- classic I'm with Stupid pointing finger - DSPF * MUST COMPILE RSTDSP *YES AND DEFER WRITE = *NO *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A ATR01 1A P A ATR02 1A P A ATR03 1A P A ATR04 1A P A ATR05 1A P A ATR06 1A P A ATR07 1A P A ATR08 1A P A ATR09 1A P A ATR10 1A P A ATR11 1A P A ATR12 1A P A ATR13 1A P A ATR14 1A P A ATR15 1A P A ATR16 1A P A LIN001 48A O 3 3DSPATR(&ATR01) A LIN002 48A O 4 3DSPATR(&ATR02) A IM 3A O 4 57DSPATR(HI) A LIN003 48A O 5 3DSPATR(&ATR03) A 5 57'WITH' DSPATR(HI) A LIN004 48A O 6 3DSPATR(&ATR04) A 6 57'STUPID' DSPATR(HI) A LIN005 48A O 7 3DSPATR(&ATR05) A LIN006 48A O 8 3DSPATR(&ATR06) A LIN007 48A O 9 3DSPATR(&ATR07) A LIN008 48A O 10 3DSPATR(&ATR08) A LIN009 48A O 11 3DSPATR(&ATR09) A LIN010 48A O 12 3DSPATR(&ATR10) A LIN011 48A O 13 3DSPATR(&ATR11) A LIN012 48A O 14 3DSPATR(&ATR12) A LIN013 48A O 15 3DSPATR(&ATR13) A LIN014 48A O 16 3DSPATR(&ATR14) A LIN015 48A O 17 3DSPATR(&ATR15) A LIN016 48A O 18 3DSPATR(&ATR16) ]]> v5r4 //--------------------------------------------------------- // JCRZANIM5 - scrolling text on random star field //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM5Dcf e workstn SLN(LINENO) //--*COPY DEFINES------------------------------------------ /Define f_CenterText /Define f_GetRandom /Define f_DelayJobSeconds /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D LineNo s 2p 0 D StarsPerLine s 3u 0 D Msg S 78a dim(7) ctdata perrcd(1) D xx s 3u 0 D yy s 3u 0 //--*ENTRY PARMS *NONE* ----------------------------------- /free 1b for yy = 1 to %elem(Msg); // load random star map max 6 stars per line; 2b for LineNo = 1 to 24; aText = *blanks; StarsPerLine = f_GetRandom(6); 3b for xx = 1 to StarsPerLine; %subst(aText: f_GetRandom(78): 1) = '*'; 3e endfor; write DspRow; 2e endfor; // load text from array to screen field LineNo = 11; aText = f_CenterText(Msg(yy):78); *in10 = *on; write DspRow; f_DelayJobSeconds(2); *in10 = *off; 1e endfor; *inlr = *on; /end-free ** ***************** MESSAGES Space ... The final frontier ... These are the voyages of the starship, Enterprise ... ... Its five year mission: To explore strange, new worlds ... ... To seek out new life and new civilizations ... ... To boldly go where no man has gone before ... WWW.JCRCMDS.COM ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM5D - scrolling text on random star field - DSPF * MUST COMPILE RSTDSP *YES AND DEFER WRITE = *NO *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 A R DSPROW SLNO(*VAR) OVERLAY CLRL(*NO) A ATEXT 78 1 2 A 10 DSPATR(HI) ]]> v5r4 //--------------------------------------------------------- // JCRZANIM6 - Animation- Racquetball cutthroat serve rotate // Screen showing proper rotation of players during serve changes. // Simple really, the next server always swaps places with the out server. // This ensures that all players will play all positions every other player. // Craig Rutledge V6R1 //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FJCRZANIM6Dcf e workstn Infds(Infds) //--*STAND ALONE------------------------------------------- D CheckXO s 1a D Row s 3u 0 D Col s 3u 0 D IsFirstMove s n D IsPlaced s n D IsWinner s n //--*COPY DEFINES------------------------------------------ /Define Infds /Define FunctionKeys /Define f_GetDayName /Define Dspatr /COPY JCRCMDS,JCRCMDSCPY //--*FUNCTION PROTOTYPES----------------------------------- D f_FillGrid PR 9a dim(5) D 1a const //--*DATA STRUCTURES--------------------------------------- D DspDS ds D Grid12_L1 D Grid12_L2 D Grid12_L3 D Grid12_L4 D Grid12_L5 D Grid31_L1 D Grid31_L2 D Grid31_L3 D Grid31_L4 D Grid31_L5 D Grid33_L1 D Grid33_L2 D Grid33_L3 D Grid33_L4 D Grid33_L5 D ATRDS ds D atr12 D atr31 D atr33 // Define 3D array for row, column, then 5 lines D DspCol ds likeds(DspColx) dim(3) based(DspPtr) D DspColx ds qualified D DspLine 9a dim(5) D DspPtr s * inz(%addr(DspDs)) D AtrPos s 1a dim(3) based(AtrPtr) D AtrPtr s * inz(%addr(AtrDs)) //--*ENTRY PARMS *NONE* ----------------------------------- /free evalr scDow = %trimr(f_GetDayName()); RotateCnt = 1; exsr srStartRotation; //--------------------------------------------------------- 1b dou 1 = 2; exfmt SCREEN; 2b if InfdsFkey = f03 or InfdsFkey = f12; *inlr = *on; return; 2e endif; // six rotations for all players to play all positions RotateCnt += 1; 2b if RotateCnt = 7; RotateCnt = 1; 2e endif; 2b if RotateCnt = 1; exsr srStartRotation; 2x elseif RotateCnt = 2; exsr srRotation2; 2x elseif RotateCnt = 3; exsr srRotation3; 2x elseif RotateCnt = 4; exsr srRotation4; 2x elseif RotateCnt = 5; exsr srRotation5; 2x elseif RotateCnt = 6; exsr srRotation6; 2e endif; 1e enddo; //--------------------------------------------------------- begsr srStartRotation; DspCol(1).DspLine = f_FillGrid('A'); DspCol(2).DspLine = f_FillGrid('B'); DspCol(3).DspLine = f_FillGrid('C'); AtrPos(1) = White; AtrPos(2) = Yellow; AtrPos(3) = Pink; MsgL1 = 'Now it is B turn to serve.'; MsgL2 = 'B will swap places with A.'; MsgR1 = *blanks; MsgR2 = *blanks; endsr; begsr srRotation2; DspCol(2).DspLine = f_FillGrid('A'); DspCol(1).DspLine = f_FillGrid('B'); DspCol(3).DspLine = f_FillGrid('C'); AtrPos(2) = White; AtrPos(1) = Yellow; AtrPos(3) = Pink; MsgR1 = 'Now it is C turn to serve.'; MsgR2 = 'C will swap places with B.'; MsgL1 = *blanks; MsgL2 = *blanks; endsr; begsr srRotation3; DspCol(2).DspLine = f_FillGrid('A'); DspCol(3).DspLine = f_FillGrid('B'); DspCol(1).DspLine = f_FillGrid('C'); AtrPos(2) = White; AtrPos(3) = Yellow; AtrPos(1) = Pink; MsgL1 = 'Now it is A turn to serve.'; MsgL2 = 'A will swap places with C.'; MsgR1 = *blanks; MsgR2 = *blanks; endsr; begsr srRotation4; DspCol(1).DspLine = f_FillGrid('A'); DspCol(3).DspLine = f_FillGrid('B'); DspCol(2).DspLine = f_FillGrid('C'); AtrPos(1) = White; AtrPos(3) = Yellow; AtrPos(2) = Pink; MsgR1 = 'Now it is B turn to serve.'; MsgR2 = 'B will swap places with A.'; MsgL1 = *blanks; MsgL2 = *blanks; endsr; begsr srRotation5; DspCol(3).DspLine = f_FillGrid('A'); DspCol(1).DspLine = f_FillGrid('B'); DspCol(2).DspLine = f_FillGrid('C'); AtrPos(3) = White; AtrPos(1) = Yellow; AtrPos(2) = Pink; MsgL1 = 'Now it is C turn to serve.'; MsgL2 = 'C will swap places with B.'; MsgR1 = *blanks; MsgR2 = *blanks; endsr; begsr srRotation6; DspCol(3).DspLine = f_FillGrid('A'); DspCol(2).DspLine = f_FillGrid('B'); DspCol(1).DspLine = f_FillGrid('C'); AtrPos(3) = White; AtrPos(2) = Yellow; AtrPos(1) = Pink; MsgR1 = 'Now it is A turn to serve.'; MsgR2 = 'A will swap places with C.'; MsgL1 = *blanks; MsgL2 = *blanks; endsr; /end-free //--------------------------------------------------------- // Return 5 X 9 array of selected character P f_FillGrid b D f_FillGrid PI 9a dim(5) D p_BaseChar 1a const D Line s 9a dim(5) /free 1b if p_BaseChar = 'C'; Line(1) = ' CCCCC '; Line(2) = ' CCC '; Line(3) = 'CCC '; Line(4) = ' CCC '; Line(5) = ' CCCCC '; 1x elseif p_BaseChar = 'A'; Line(1) = ' AAA '; Line(2) = ' AA AA '; Line(3) = 'AAAAAAAAA'; Line(4) = 'AA AA'; Line(5) = 'AA AA'; 1x elseif p_BaseChar = 'B'; Line(1) = 'BBBBBBB '; Line(2) = 'BB BB '; Line(3) = 'BBBBBB '; Line(4) = 'BB BB '; Line(5) = 'BBBBBBB '; 1e endif; return Line; /end-free P f_FillGrid e ]]> v5r4 *---------------------------------------------------------------- * JCRZANIM6D - Animation- racquetball cutthroat serve rotate - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A CF03 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SCREEN A ATR12 1A P A ATR31 1A P A ATR33 1A P A 1 3'JCRZANIM6' A COLOR(BLU) A 1 15'Racquetball Cutthroat Serve Rotati- A on' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 3 8'----------------------------------- A ---' A COLOR(BLU) A GRID12_L1 9A O 4 23DSPATR(&ATR12) A 4 53'Serve Count' A ROTATECNT 1S 0O 4 66 A GRID12_L2 9A O 5 23DSPATR(&ATR12) A GRID12_L3 9A O 6 23DSPATR(&ATR12) A 6 53'Server Sequence' A GRID12_L4 9A O 7 23DSPATR(&ATR12) A 7 53'A starts' A COLOR(WHT) A GRID12_L5 9A O 8 23DSPATR(&ATR12) A 8 53'B serves after A' A COLOR(YLW) A 9 53'C serves after B' A COLOR(PNK) A GRID31_L1 9A O 11 14DSPATR(&ATR31) A GRID33_L1 9A O 11 31DSPATR(&ATR33) A GRID31_L2 9A O 12 14DSPATR(&ATR31) A GRID33_L2 9A O 12 31DSPATR(&ATR33) A 12 53'Simple: The server swaps' A GRID31_L3 9A O 13 14DSPATR(&ATR31) A GRID33_L3 9A O 13 31DSPATR(&ATR33) A 13 53'places with whoever is' A GRID31_L4 9A O 14 14DSPATR(&ATR31) A GRID33_L4 9A O 14 31DSPATR(&ATR33) A 14 53'serving next.' A GRID31_L5 9A O 15 14DSPATR(&ATR31) A GRID33_L5 9A O 15 31DSPATR(&ATR33) A MSGL1 26A O 17 14 A MSGL2 26A O 18 14 A MSGR1 26A O 19 31 A MSGR2 26A O 20 31 A 24 2'F3=Exit' A COLOR(BLU) A 24 15'Press Enter to swap serves.' A DSPATR(HI) A 16 53'It helps if you watch the ' A 17 53'A player and how he relates' A 18 53'to the other two.' ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCR4MAX - Rpg4 source to full rpg4 syntax - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Maximize Conversion to RPG4') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PGM(*YES) PROMPT('RPG program name:') PARM KWD(SRCFILE) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) LEN(10) DFT(QRPGLESRC) SPCVAL((QRPGLESRC)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(STYLE) TYPE(*CHAR) LEN(12) RSTD(*YES) + DFT(*LOWALL) VALUES(*NOACTION + *UPALL *LOWALL *UPOP_LOWALL *UPOP_ONLY) + PROMPT('Case (Up/Low) for source:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCR4MAXC - Rpg4 source to full rpg4 syntax - CMDPGM */ /* Ovrdbf to point to correct RPG source code member */ /* Call RPG programs to update selected source members */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &FILE_LIB &STYLE) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&FILE_LIB) TYPE(*CHAR) LEN(20) DCL VAR(&FILE) TYPE(*CHAR) LEN(10) DCL VAR(&LIB) TYPE(*CHAR) LEN(10) DCL VAR(&DOCOPY) TYPE(*LGL) DCL VAR(&STYLE) TYPE(*CHAR) LEN(12) DCL VAR(&SEVERITY) TYPE(*CHAR) LEN(2) DCL VAR(&INDENTLVL) TYPE(*DEC) LEN(1 0) VALUE(3) CHGVAR VAR(&FILE) VALUE(%SST(&FILE_LIB 1 10)) CHGVAR VAR(&LIB) VALUE(%SST(&FILE_LIB 11 10)) IF COND(&LIB = '*LIBL') THEN(RTVMBRD FILE(&LIB/&FILE) MBR(&MBR) RTNLIB(&LIB)) /* generate D specs */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('Generate D specs for ' *CAT &MBR + *TCAT ' in source file ' *CAT &LIB *TCAT + '/' *CAT &FILE *TCAT ' - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) CRTSRCPF FILE(QTEMP/JCR4MAX) RCDLEN(112) MBR(*FILE) MONMSG MSGID(CPF0000) EXEC(CLRPFM FILE(QTEMP/JCR4MAX) MBR(JCR4MAX)) OVRDBF FILE(NEWSRC) TOFILE(QTEMP/JCR4MAX) + MBR(JCR4MAX) OVRSCOPE(*JOB) OVRDBF FILE(MODIFYSRC) TOFILE(&LIB/&FILE) MBR(&MBR) + OVRSCOPE(*JOB) CALL PGM(JCR4MAXR4) PARM(&DOCOPY) DLTOVR FILE(NEWSRC) LVL(*JOB) IF COND(&DOCOPY) THEN(CPYSRCF + FROMFILE(QTEMP/JCR4MAX) + TOFILE(&LIB/&FILE) FROMMBR(JCR4MAX) + TOMBR(&MBR) SRCOPT(*SEQNBR)) /* logic structure numbering */ CALL PGM(JCRNUMBR) PARM(&MBR &FILE_LIB '*YES' '*YES' '*NO ' &INDENTLVL) /* and or modification */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('AND/OR + modification of ' *CAT &MBR *TCAT ' in + source file ' *CAT &LIB *TCAT '/' *CAT + &FILE *TCAT ' - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) OVRDBF FILE(LOOKAHEADR) TOFILE(&LIB/&FILE) + MBR(&MBR) OVRSCOPE(*JOB) CALL PGM(JCR4MAXR1) DLTOVR FILE(LOOKAHEADR) LVL(*JOB) /* eval modification */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('EVAL + modification of ' *CAT &MBR *TCAT ' in + source file ' *CAT &LIB *TCAT '/' *CAT + &FILE *TCAT ' - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) CALL PGM(JCR4MAXR2) PARM(&MBR &FILE &LIB &SEVERITY) IF COND(&SEVERITY *GT '20') THEN(DO) SNDPGMMSG MSGID(CPD0006) MSGF(QCPFMSG) MSGDTA('0000 + *ERROR* Diagnostic severity ' *CAT + &SEVERITY *TCAT '. Please check listing + for errors.') MSGTYPE(*DIAG) SNDPGMMSG MSGID(CPF0002) MSGF(QCPFMSG) MSGTYPE(*ESCAPE) ENDDO /* upper lower case adjustments */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Case + adjustment for ' *CAT &MBR *TCAT ' in + source file ' *CAT &LIB *TCAT '/' *CAT + &FILE *TCAT ' - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) CALL PGM(JCR4MAXR3) PARM(&STYLE) DLTOVR FILE(MODIFYSRC) LVL(*JOB) SNDPGMMSG MSG('RPG4 modification for ' *CAT &MBR + *TCAT ' in ' *CAT &LIB *TCAT '/' *CAT &FILE *TCAT ' - completed') ENDPGM ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCR4MAX'.Maximize Conversion to RPG4 (JCR4MAX) - Help .*-------------------------------------------------------------------- :P.This JCR command is designed to run immediately after CVTRPGSRC command. This command does many things CVTRPGSRC command should have done. Attribute testing is done to make sure only valid conversions take place. :P.:HP2.Conversions::EHP2. :UL COMPACT. :LI.All MOVE, Z-ADD, Z-SUB, SUBST, CAT, ADD, and MULTs are converted to EVAL opcode. :LI.All IF, WHEN, DO, AND, & OR logic structures are converted to Extended Factor2 definitions. :LI.All program defined fields generate Definition specs. :LI.Allows case (Upper/Lower) selection of source code (STYLE).:EUL. :P.To complement new ability to have Upper/Lower case characters, the following options are offered by STYLE keyword. :LINES. *NoAction - Leave code as is. *UpAll - Convert all characters to UPPER case. *LowAll - Convert all characters to lower case. *UpOp_LowRest - OPCODES are upper case. All else is lower case. *UpOp_Only - OPCODES are upper case. All else is left as is.:ELINES.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCR4MAX/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Source member which is to modified.:EHELP. :HELP name='JCR4MAX/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP name='JCR4MAX/STYLE'.Case (Up/Low) for source - Help :XH3.Case (Up/Low) for source (STYLE) :P.Case specific action to be taken. :PARML.:PT.:PK def.*UPOP_LOWALL:EPK. :PD.Upper case OPCODE and lower case everything else. :PT.:PK.*NOACTION:EPK.:PD.Do not change case of any source code. :PT.:PK.*UPALL:EPK.:PD.Convert all characters to upper case. :PT.:PK.*LOWALL:EPK.:PD.Convert all characters to lower case. :PT.:PK.*UPOP_ONLY:EPK.:PD.Convert OPCODE to upper case. Do not covert any other code. :EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCR4MAXRV - Validity checking program for lib/file/member //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define ApiErrDS /Define f_GetQual /Define f_SndEscapeMsg /Define f_System /Define f_IsValidMbrType /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCR4MAXRV PR extpgm('JCR4MAXRV') D 10a D 20a D 12a D p_JCR4MAXRV PI D p_SrcMbr 10a D p_SrcFilQual 20a D p_Style 12a //--------------------------------------------------------- /free 1b if not f_IsValidMbrType(p_SrcFilQual: p_SrcMbr: 'RPGLE ': 'SQLRPGLE '); f_SndEscapeMsg('*ERROR* Member ' + %trimr(p_SrcMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; // see if source mbr can be allocated, if not send err msg f_System('ALCOBJ OBJ((' + f_GetQual(p_SrcFilQual) + ' *FILE *EXCLRD ' + %trimr(p_SrcMbr) + ')) WAIT(1)'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('Cannot allocate member ' + %trimr(p_SrcMbr) + ' in source file ' + %trimr( f_GetQual(p_SrcFilQual))); 1e endif; f_System('DLCOBJ OBJ((' + f_GetQual(p_SrcFilQual) + ' *FILE *EXCLRD ' + %trimr(p_SrcMbr) + '))'); *inlr = *on; return; ]]> v5r4 //--------------------------------------------------------- // JCR4MAXR1 - convert RPGIII style logic structures to extended F2. // Convert FACTOR1 IFxx FACTOR2s statements to IF Extended FACTOR2. // Convert *INxx = *ON to *INxx convert *INxx = *OFF to not *INxx // Convert Factor1 *ON to *INxx convert *INxx = *OFF to not *INxx //--------------------------------------------------------- // program logic: fairly bizarre! // Multifile logic was used to enable look ahead. // Look ahead was used to determine if following statement was AND or OR. // Matching record logic was used to keep update and lookahead files in sync. // Force logic was used to spin through lookahead file if required to get next // executable line of source. // I thought it real funny to use RPGII methods to update RPGIV code. // added code to ignore SQL statements //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FLOOKAHEADRip f 112 disk FMODIFYSRC us f 112 disk //--*STAND ALONE------------------------------------------- D tabrelat s 2a dim(6) ctdata perrcd(1) EQ NE GT LT GE LE D tabsymbol s 2a dim(6) alt(tabrelat) = <> > < >= <= D OldOpcode s like(NewOpcode) D and_or_flg s 3a D Extendedf2 s 45a D NewOpcode s 10a D Relations s 2a D IsForced s n nxt record is forced //--*COPY DEFINES------------------------------------------ /Define Constants /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D SrcDS ds 92 inz D SrcFactor1 24 37a D SrcOpcode 38 47a D OpWhen 4a overlay(SrcOpcode:1) D OpWhenRel 2a overlay(SrcOpcode:5) D OpDox 3a overlay(SrcOpcode:1) D OpDoxRel 2a overlay(SrcOpcode:4) D OpIf 2a overlay(SrcOpcode:1) D OpIfRel 2a overlay(SrcOpcode:3) D OpAnd 3a overlay(SrcOpcode:1) D OpAndRel 2a overlay(SrcOpcode:4) D OpOr 2a overlay(SrcOpcode:1) D OpOrRel 2a overlay(SrcOpcode:3) D SrcFactor2 48 61a D SrcResult 62 75a D SrcLength 80 80a //--*ENTRY PARMS *NONE* ----------------------------------- //--*INPUT SPECS------------------------------------------- // All lines that are comment or have eject character are // ignored, also first compile time table or array that is // found sets on LR. Record type indicators are used to // determine which section of code will be executed. //--------------------------------------------------------- Ilookaheadrns lr 13 c* 14 c* 15 c I or 13 c* 14 c* 15 cc named array I or 13 c* 14 c* 15 cC named array I ns 01 I a 1 6 look_SeqN m1 I ns ** I a 1 42 look_ahead I a 18 18 look_type I a 19 19 look_comt IModifySrc ns 02 18 cC 19nc* 19nc/ I and 19nc+ I or 18 cc 19nc* 19nc/ I and 19nc+ I a 1 6 MatchRecSeq m1 I a 1 92 SrcDS I a 24 37 updFactor1 I a 38 47 updOpcode I a 48 61 updFactor2 I a 62 75 updResult I ns 05 I a 1 6 MatchRecSeq m1 //--------------------------------------------------------- // AND or OR opcode code may follow so look-ahead is // used to determine which. If a comment or copy statement // is found, FORCE is used to check next look ahead. /free 1b if *in01; IsForced = *off; and_or_flg = *blanks; 2b if (look_type = 'C' or look_type = 'c') and (look_comt <> '*' and look_comt <> '/' and look_comt <> '+'); 3b if (%subst(look_ahead: 38: 3) = 'AND') or (%subst(look_ahead: 38: 3) = 'and'); 4b if (%subst(look_ahead: 38 + 3: 1)) > ' '; and_or_flg = 'and'; 4e endif; 3x elseif (%subst(look_ahead: 38: 2) = 'OR') or (%subst(look_ahead: 38: 2) = 'or'); 4b if (%subst(look_ahead: 38 + 2: 1)) > ' '; and_or_flg = 'or '; 4e endif; 3e endif; 2x else; FORCE lookaheadr; //read next IsForced = *on; 2e endif; 1e endif; //--------------------------------------------------------- // If calc record spec and it was not forced. 1b if *in02; SrcDS = %xlate(lo: up: SrcDS); clear NewOpcode; clear OldOpcode; *in11 = *off; // Only cat(p) with no padded spaces defined or :0 padded spaces or : 1 2b if SrcOpcode = 'CAT(P) ' and SrcLength = ' '; NewOpcode = 'eval '; 3b if updFactor1 = *blanks; updFactor1 = updResult; //load implicit 3e endif; aa = %scan(':': updFactor2); 3b if aa = 0; //append as is Extendedf2 = %trim(updResult) + ' = ' + %trim(updFactor1) + ' + ' + %trim(updFactor2); except UpdateSrc; 3x elseif %subst(updFactor2: aa: 3) = ':0 '; //no spaces Extendedf2 = %trimr(updResult) + ' = %trimr(' + %trim(updFactor1) + ') + ' + %subst(updFactor2: 1: aa - 1); except UpdateSrc; 3x elseif %subst(updFactor2: aa: 3) = ':1 '; //one space Extendedf2 = %trimr(updResult) + ' = %trimr(' + %trim(updFactor1) + ') + ' + '''' + ' ' + '''' + ' + ' + %subst(updFactor2: 1: aa - 1); except UpdateSrc; 3e endif; //--------------------------------------------------------- // Rest of structure logic 2x elseif OpWhen = 'WHEN' and OpWhenRel > *blanks; NewOpcode = %subst(updOpcode: 1: 4); Relations = OpWhenRel; exsr srCalcExtend; 2x elseif (OpDox = 'DOW' or OpDox = 'DOU') and OpDoxRel > *blanks; NewOpcode = %subst(updOpcode: 1: 3); Relations = OpDoxRel; exsr srCalcExtend; 2x elseif OpIf = 'IF' and OpIfRel > *blanks; NewOpcode = %subst(updOpcode: 1: 2); Relations = OpIfRel; exsr srCalcExtend; 2x elseif OpAnd = 'AND' and OpAndRel > *blanks; NewOpcode = *blanks; Relations = OpAndRel; *in11 = *on; exsr srCalcExtend; 2x elseif OpOr = 'OR' and OpOrRel > *blanks; NewOpcode = *blanks; Relations = OpOrRel; *in11 = *on; exsr srCalcExtend; 2e endif; 1e endif; //--------------------------------------------------------- // *in01 ifeq *on converted to if *in01. begsr srCalcExtend; 1b if Relations = 'EQ' and %subst(SrcFactor1: 1: 3) = '*IN' and (SrcFactor2 = '*ON ' or SrcFactor2 = '*OFF ' or SrcFactor2 = '''1''' or SrcFactor2 = '''0'''); 2b if SrcFactor2 = '*ON ' or SrcFactor2 = '''1'''; Extendedf2 = updFactor1; 2x elseif SrcFactor2 = '*OFF ' or SrcFactor2 = '''0'''; Extendedf2 = 'NOT ' + updFactor1; 2e endif; 1x else; //--------------------------------------------------------- // Update Relationship testing code. *in10 = %tlookup(Relations: tabrelat: tabsymbol); Extendedf2 = %trimr(updFactor1) + // FACTOR 1 ' ' + %trim(tabsymbol) + ' ' + //Relationship updFactor2; //FACTOR 2 1e endif; // Tack 'and' or 'or' to end of factor two. 1b if and_or_flg > *blanks; Extendedf2 = %trimr(Extendedf2) + ' ' + and_or_flg; 1e endif; except UpdateSrc; endsr; /end-free OModifySrc e UpdateSrc O 11 20 ' ' O 37 ' ' O NewOpcode 47 O Extendedf2 92 ** EQ= NE<> LE<= GE>= LT< GT> ]]> v5r4 //--------------------------------------------------------- // JCR4MAXR2 - convert codes to EVAL // Convert character Fields and Constant moves to EVAL // MOVE rules are: %size(Factor2) = %size(Result) CONVERT // // MOVEL rules are: %size(Factor2) = %size(Result) or CONVERT // %size(Factor2) > %size(Result) CONVERT // // Z-ADD rules are: %size(Factor2) = %size(Result) or CONVERT // %size(Factor2) > %size(Result) CONVERT // // Z-SUB rules are: same as z-add except no *zeros // // ADD rule : %size(Factor1) < %size(Result) and // %size(Factor2) < %size(Result) // // MULT rule : %size(Factor1) < %size(Result) and // %size(Factor2) < %size(Result) //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FMODIFYSRC up f 112 disk //--*STAND ALONE------------------------------------------- D ExtendedF2 s 45a D Factor1typ s 1a D Factor2typ s 1a D NewOpcode s 10a D ResultType s 1a D WorkInd s 2a D WorkTyp s 1a D ZeroBlank s 1a D Factor1dec s 2s 0 D Factor2dec s 2s 0 D ResultDec s 2s 0 D WorkDec s 2s 0 D Factor1len s 5u 0 D Factor2len s 5u 0 D nn s 5u 0 D ResultLen s 5u 0 D WorkLen s 5u 0 D xx s 5u 0 //--*COPY DEFINES------------------------------------------ /Define FieldsArry /Define f_GetQual /Define Constants /Define FieldsAttrDS /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D Work5 ds inz D fact1value 1 5s 0 D FactorxDS ds qualified D First1 1a overlay(FactorxDS:1) D First3 3a overlay(FactorxDS:1) D IsLookup 14a overlay(FactorxDS:1) D ds inz D Src 1 92a D SrcFactor1 24 37a D SrcF1p1 1a overlay(SrcFactor1:1) D SrcOpcode 38 47a D opmove 4a overlay(SrcOpcode:1) D opsub 4a overlay(SrcOpcode:1) D opz_ 2a overlay(SrcOpcode:1) D opsubst 5a overlay(SrcOpcode:1) D SrcFactor2 48 61a D SrcResult 62 75a D resltlook 14a overlay(SrcResult:1) D reslt_in 3a overlay(SrcResult:1) D SrcLength 80 80a D SrcRstind 83 88a //--*ENTRY PARMS------------------------------------------- D p_JCR4MAXR2 PR extpgm('JCR4MAXR2') D 10a D 10a D 10a D 10a D p_JCR4MAXR2 PI D p_SrcMbr 10a D p_SrcFil 10a D p_SrcLib 10a D p_DiagSeverity 10a //--*INPUT SPECS------------------------------------------- ImodifySrc ns 01 18 cC 19nc* 19nc/ I and 19nc+ I or 18 cc 19nc* 19nc/ I and 19nc+ I a 1 92 Src I a 24 37 updFactor1 I a 48 61 updFactor2 I a 62 75 updResult I a 83 84 highind I a 85 86 lowind I a 87 88 equalind I ns 05 //--------------------------------------------------------- /free // If a calc record spec. 1b if *in01 and SrcLength = *blanks; SrcOpcode = %xlate(lo: up: SrcOpcode); 2b if SrcRstind = *blanks AND (SrcOpcode = 'MOVE ' or SrcOpcode = 'MOVEL ' or SrcOpcode = 'MOVEL(P) ' or SrcOpcode = 'MOVE(P) ' or SrcOpcode = 'Z-ADD ' or SrcOpcode = 'Z-SUB ' or SrcOpcode = 'SUB ' or SrcOpcode = 'ADD ' or SrcOpcode = 'MULT ' or SrcOpcode = 'MULT(H) ' or SrcOpcode = 'SUBST ' or SrcOpcode = 'SUBST(P) '); //--------------------------------------------------------- // Determine field sizes of Factor1, 2, Result Field. ZeroBlank = *off; Src = %xlate(lo: up: Src); 3b if SrcFactor1 > *blanks; Factor1len = 0; FactorxDS = SrcFactor1; exsr srFact1Fact2; //Get size of factor 1 Factor1len = WorkLen; Factor1dec = WorkDec; Factor1typ = WorkTyp; 3e endif; 3b if SrcFactor2 = '*ON ' or SrcFactor2 = '*OFF '; Factor2len = 1; Factor2dec = 0; Factor2typ = 'A'; 3x else; FactorxDS = SrcFactor2; exsr srFact1Fact2; //Get size of factor 2 Factor2len = WorkLen; Factor2dec = WorkDec; Factor2typ = WorkTyp; 3e endif; //--------------------------------------------------------- // Get attributes of Result field 3b if reslt_in = '*IN'; Resultlen = 1; Resultdec = 0; ResultType = 'A'; 3x else; nn = %lookup(resltlook: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 4b if nn = 0; bb = %scan('(': SrcResult: 1); 5b if bb > 0; resltlook = %subst(SrcResult: 1: (bb - 1)); nn = %lookup(resltlook: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 5e endif; 4e endif; 4b if nn > 0; FieldsAttrDS = FieldsAttrArry(nn); Resultlen = FieldsAttrDS.Length; 5b if FieldsAttrDS.DecimalPos = *blanks; Resultdec = 0; 5x else; Resultdec = FieldsAttrDS.DecimalPosN; 5e endif; ResultType = FieldsAttrDS.DataType; 4e endif; 3e endif; exsr srMakeEval; 2e endif; //--------------------------------------------------------- // Convert SETON and SETOF opcodes to move *ON or move *OFF 2b if SrcOpcode = 'SETON ' or SrcOpcode = 'SETOFF '; clear WorkInd; 3b if highind > *blanks and lowind = *blanks and equalind = *blanks; WorkInd = highind; 3x elseif highind = *blanks and lowind > *blanks and equalind = *blanks; WorkInd = lowind; 3x elseif highind = *blanks and lowind = *blanks and equalind > *blanks; WorkInd = equalind; 3e endif; // Match proper constant to type opcode. 3b if WorkInd > *blanks; NewOpcode = 'EVAL '; 4b if SrcOpcode = 'SETON '; ExtendedF2 = '*in' + WorkInd + ' = *on '; 4x else; ExtendedF2 = '*in' + WorkInd + ' = *off'; 4e endif; except updateSrc; 3e endif; 2e endif; 1e endif; //--------------------------------------------------------- begsr srMakeEval; 1b if Factor2typ <> 'B' and //weird things ResultType <> 'B' and //with binary Factor2typ <> *blank; // probable *DATE or *TIME NewOpcode = 'EVAL '; // Convert MOVE BOOLEAN values to eval opcode. // Also convert '1' to *on, '0' to *off 2b if SrcOpcode = 'MOVE ' and SrcLength = ' ' and ResultType = 'A' and Resultlen = 1 and (SrcFactor2 = '*ON ' or SrcFactor2 = '*OFF ' or SrcFactor2 = '''1''' or SrcFactor2 = '''0'''); 3b if SrcFactor2 = '''1'''; ExtendedF2 = %trimr(updResult) + ' = *on'; 3x elseif SrcFactor2 = '''0'''; ExtendedF2 = %trimr(updResult) + ' = *off'; 3x else; ExtendedF2 = %trimr(updResult) + ' = ' + updFactor2; 3e endif; except updateSrc; //--------------------------------------------------------- 2x elseif ZeroBlank = *on and (opmove = 'MOVE' or SrcOpcode = 'Z-ADD'); 3b if ResultType <> 'A'; updFactor2 = '*ZEROS '; 3x elseif updFactor2 = '*BLANK '; updFactor2 = '*BLANKS '; 3x elseif updFactor2 = '*ZERO '; updFactor2 = '*ZEROS '; 3e endif; exsr srUpdateCode; //--------------------------------------------------------- 2x elseif Factor2typ = ResultType and ResultType = 'A' and Factor2len <= Resultlen and SrcOpcode = 'MOVEL(P) ' OR Factor2typ = ResultType and Factor2dec = Resultdec and Factor2len = Resultlen and (opmove = 'MOVE' or opz_ = 'Z-') OR opz_ = 'Z-' and ((Factor2len - Factor2dec) <= (Resultlen - Resultdec)); exsr srUpdateCode; //--------------------------------------------------------- 2x elseif opsub = 'SUB '; 3b if SrcFactor1 = *blanks and ((Factor2len - Factor2dec) <= (Resultlen - Resultdec)); ExtendedF2 = %trimr(updResult) + ' = ' + %trimr(updResult) + ' - ' + updFactor2; except updateSrc; 3x elseif SrcFactor1 > *blanks and ((Factor1len - Factor1dec) <= (Resultlen - Resultdec)) and ((Factor2len - Factor2dec) <= (Resultlen - Resultdec)); ExtendedF2 = %trimr(updResult) + ' = ' + %trimr(updFactor1) + ' - ' + updFactor2; except updateSrc; 3e endif; //--------------------------------------------------------- 2x elseif opsub = 'ADD ' and SrcFactor1 > *blanks; 3b if ((Factor1len - Factor1dec) < (Resultlen - Resultdec)) and ((Factor2len - Factor2dec) < (Resultlen - Resultdec)); ExtendedF2 = %trimr(updResult) + ' = ' + %trimr(updFactor1) + ' + ' + updFactor2; except updateSrc; 3e endif; 2x elseif opsub = 'MULT' and SrcFactor1 > *blanks; 3b if (((Factor1len - Factor1dec) + (Factor2len - Factor2dec)) <= (Resultlen - Resultdec)); ExtendedF2 = %trimr(updResult) + ' = ' + %trimr(updFactor1) + ' * ' + updFactor2; 4b if SrcOpcode = 'MULT(H) '; NewOpcode = 'EVAL(H) '; 4e endif; except updateSrc; 3e endif; //--------------------------------------------------------- // Convert substring (padded) opcodes to Eval 2x elseif opsubst = 'SUBST' and SrcLength = ' ' and SrcFactor1 > *blanks; 3b if SrcOpcode = 'SUBST(P)'; NewOpcode = 'eval '; // If Factor2 does not not contain starting location // signified by : then make start pos = 1. xx = %scan(':': updFactor2: 1); 4b if xx > 0; ExtendedF2 = %trimr(updResult) + ' = %subst(' + %trim(updFactor2) + ':' + %trim(updFactor1) + ')'; 4x else; ExtendedF2 = %trimr(updResult) + ' = %subst(' + %trim(updFactor2) + ': 1:' + %trim(updFactor1) + ')'; 4e endif; except updateSrc; 3x else; 4b if SrcF1p1 >= '0' and SrcF1p1 <= '9' and Factor1len < 6; Work5 = %subst('00000': 1: 5 - Factor1len) + %subst(updFactor1: 1: Factor1len); 5b if Work5 = *blanks; fact1value = 0; 5e endif; 5b if fact1value >= Resultlen; ExtendedF2 = %trimr(updResult) + ' = %subst(' + %trim(updFactor2) + ':' + %trim(updFactor1) + ')'; except updateSrc; 5e endif; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Build extended factor 2 and update source record. begsr srUpdateCode; 1b if SrcOpcode <> 'Z-SUB '; ExtendedF2 = %trimr(updResult) + ' = ' + (updFactor2); 1x else; ExtendedF2 = %trimr(updResult) + ' = -(' + %trimr(updFactor2) + ')'; 1e endif; except updateSrc; endsr; //--------------------------------------------------------- // Determine field sizes of Factor1 and Factor2. begsr srFact1Fact2; clear WorkTyp; WorkLen = 0; WorkDec = 0; 1b if FactorxDS.First1 = ''''; //CONSTANT 2b if %subst(FactorxDS: 14: 1) = ''''; WorkLen = 12; 2x elseif %subst(FactorxDS: 1: 2) = '''' and %subst(FactorxDS: 1: 3) = '''' and %subst(FactorxDS: 1: 4) = ''''; WorkLen = 1; 2x else; bb = %checkr(' ': FactorxDS); WorkLen = (bb - 2); 2e endif; WorkTyp = 'A'; WorkDec = 0; //--------------------------------------------------------- 1x elseif FactorxDS.First1 >= '0' and //NUMERIC FactorxDS.First1 <= '9' or FactorxDS.First1 = '.'; aa = %scan('.': FactorxDS); bb = %scan(' ': FactorxDS); 2b if bb > 0; //CALC NUMBER OF DECIMALS WorkLen = (bb) - 1; //ASSUME NO DECIMALS 2x else; WorkLen = 14; 2e endif; WorkDec = 0; aa = %scan('.': FactorxDS); 2b if aa > 0; //CALC NUMBER OF DECM WorkLen -= 1; WorkDec = (bb - aa) - 1; 2e endif; WorkTyp = 'P'; 1x elseif FactorxDS.First3 = '*BL' or FactorxDS.First3 = '*ZE'; ZeroBlank = *on; 1x else; //FIELD NAME nn = %lookup(FactorxDS: FieldsNameArry: 1: FieldsArry_NumberOfEntries); //--------------------------------------------------------- // if lookup not found, it could be an array or // date field with : in it. Try both 2b if nn = 0; bb = %scan('(': FactorxDS: 1); //try array 3b if bb = 0; bb = %scan(':': FactorxDS: 1); //try date 3e endif; 3b if bb > 0; FactorxDS.IsLookup = %subst(FactorxDS: 1: (bb - 1)); nn = %lookup(FactorxDS.IsLookup: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 3e endif; 2e endif; //--------------------------------------------------------- 2b if nn > 0; FieldsAttrDS = FieldsAttrArry(nn); WorkLen = FieldsAttrDS.Length; 3b if FieldsAttrDS.DecimalPos = *blanks; WorkDec = 0; 3x else; WorkDec = FieldsAttrDS.DecimalPosN; 3e endif; WorkTyp = FieldsAttrDS.DataType; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr *inzsr; // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity); 1b if DiagSeverity > '20'; p_DiagSeverity = DiagSeverity; *inlr = *on; return; 1e endif; endsr; /end-free OmodifySrc e updateSrc O 37 ' ' O NewOpcode 47 O ExtendedF2 92 ]]> v5r4 //--------------------------------------------------------- // JCR4MAXR3 - convert alpha case of source code. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FMODIFYSRC up f 112 disk //--*STAND ALONE------------------------------------------- D ApostropheCnt s 5u 0 //--*COPY DEFINES------------------------------------------ /Define Constants /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D ds inz D Src 94a D SrcArry 1a dim(94) overlay(Src) //--*ENTRY PARMS------------------------------------------- D p_JCR4MAXR3 PR extpgm('JCR4MAXR3') D 12a D p_JCR4MAXR3 PI D p_StyleType 12a //--*INPUT SPECS------------------------------------------- ImodifySrc ns lr 13 c* 14 c* 15 c I or 13 c* 14 c* 15 cc named array I or 13 c* 14 c* 15 cC named array I ns 01 19nc* 19nc/ 19nc+ I a 18 18 Srcspec I a 18 55 d_Extended I a 38 47 SrcOpcode I a 19 112 Src I ns 05 //--------------------------------------------------------- /free 1b if *in01; *in30 = *off; Srcspec = %xlate(lo: up: Srcspec); 2b if p_StyleType <> '*UPOP_ONLY '; ApostropheCnt = 0; 3b for aa = 1 to 74; 4b if SrcArry(aa) = ''''; ApostropheCnt += 1; 4e endif; //--------------------------------------------------------- // If extended D spec or record id, do not xlate. // or if first letter is L, as in L1, do not xlate 4b if (d_Extended = 'D ' or d_Extended = 'd ') or Srcspec = 'I' and (aa = 24 or aa = 32 or aa = 40) or aa = 1 and SrcArry(aa) = 'L'; 4x else; 5b if ApostropheCnt = 0 or ApostropheCnt = 2 or ApostropheCnt = 4 or ApostropheCnt = 6 or ApostropheCnt = 8; 6b if p_StyleType = '*UPALL '; SrcArry(aa) = %xlate(lo: up: SrcArry(aa)); 6x else; SrcArry(aa) = %xlate(up: lo: SrcArry(aa)); 6e endif; 5e endif; 4e endif; 3e endfor; 2e endif; 2b if Srcspec = 'C' and (p_StyleType = '*UPOP_LOWALL' or p_StyleType = '*UPOP_ONLY '); *in30 = *on; SrcOpcode = %xlate(lo: up: SrcOpcode); 2e endif; 1e endif; //--------------------------------------------------------- begsr *inzsr; 1b if p_StyleType = '*NOACTION '; *inlr = *on; return; 1e endif; endsr; /end-free OmodifySrc d 01 O Src 112 O 30 SrcOpcode 47 O Srcspec 18 ]]> v5r4 //--------------------------------------------------------- // JCR4MAXR4 - Generate D specs for program defined fields (except parms) // Also generate standard H specs in converted source. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FMODIFYSRC uf a f 112 disk FNEWSRC o f 112 disk //--*STAND ALONE------------------------------------------- D FldStorage s dim(%elem(Defined)) like(StorageDS) D DataType s 1a D Defined s 14a dim(32767) D HeaderSrc s 60a D likeDefine s 20a D DefinedCount s 10u 0 D IsAlreadyDone s n D IsDefined s n //--*COPY DEFINES------------------------------------------ /Define Constants /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D StorageDS ds inz D dsUppercas 14a D dsFactor1 14a D dsFactor2 14a D dsResult 14a D dsLength 5a D dsDecimals 2a D dsText 20a //--*ENTRY PARMS------------------------------------------- D p_JCR4MAXR4 PR extpgm('JCR4MAXR4') D n D p_JCR4MAXR4 PI D p_CreateNew n //--*INPUT SPECS------------------------------------------- ImodifySrc ns I s 1 6 2SrcSeqno I a 13 15 CompileArray I a 18 18 SpecType I a 19 19 Asterisk I a 19 33 SrcDspecs I a 24 37 SrcFactor1 I a 38 47 SrcOpcode I a 48 61 SrcFactor2 I a 62 75 SrcResult I a 76 80 SrcLength I a 81 82 SrcDecimal I a 93 112 SrcText I a 1 112 AllSrc //--------------------------------------------------------- /free p_CreateNew = *off; read modifySrc; 1b dow not %eof; // All lines that are comment or have eject character are // ignored, also first compile time table or array that is // found will exit read loop. 2b if CompileArray = '** ' or CompileArray = '**C' or CompileArray = '**c'; 1v leave; 2e endif; 2b if not (Asterisk = '*' or Asterisk = '/' or Asterisk = '+'); 3b if (SpecType = 'D' or SpecType = 'd') and SrcDspecs > *blanks; SrcDspecs = %xlate(lo: up: Srcdspecs); bb += 1; Defined(bb) = %triml(SrcDspecs); 3x elseif (SpecType = 'C' or SpecType = 'c') and SrcOpcode > *blanks and %scan('(': SrcResult: 1) = 0; //skip arrays SrcOpcode = %xlate(lo: up: SrcOpcode); 4b if (SrcOpcode <> 'IF ' and SrcOpcode <> 'WHEN ' and SrcOpcode <> 'FOR ' and SrcOpcode <> 'AND ' and SrcOpcode <> 'OR ' and SrcOpcode <> 'DOU ' and SrcOpcode <> 'DOW ' and SrcOpcode <> 'ELSEIF' and %subst(SrcOpcode: 1: 4) <> 'EVAL' and %subst(SrcOpcode: 1: 5) <> 'CALLP' and SrcLength > *blanks) or SrcOpcode = 'DEFINE '; IsDefined = *off; 5b if SrcOpcode = 'DEFINE '; SrcFactor1 = %xlate(lo: up: Srcfactor1); IsDefined = (SrcFactor1 <> '*LIKE '); 6b if IsDefined = *off; 7b if %scan('(': Srcfactor2) > 0; IsDefined = *on; 7e endif; 6e endif; 5e endif; 5b if not IsDefined; dsUppercas = %xlate(lo: up: SrcResult); cc = %lookup(dsUppercas: Defined: 1: bb); IsDefined = (cc > 0); 6b if not IsDefined; bb += 1; Defined(bb) = dsUppercas; //Set as defined // if SrcOpcode <> 'PARM '; dsFactor1 = SrcFactor1; dsFactor2 = SrcFactor2; //--------------------------------------------------------- // Caution: Some Result fields could have // :(date type) extender. // example a subdur b c:*D 3 0 // I only want to load up to ':' aa = %scan(':': SrcResult: 1); 7b if aa > 0; SrcResult = %subst(SrcResult: 1: aa - 1); 7e endif; dsResult = SrcResult; dsLength = SrcLength; dsDecimals = SrcDecimal; dsText = SrcText; DefinedCount += 1; FldStorage(DefinedCount) = StorageDS; 6e endif; 6b if SrcOpcode = 'PARM ' and not IsDefined; //leave defined 6x elseif SrcOpcode = 'DEFINE '; except deleterec; 6x else; except removelen; 6e endif; 5e endif; 4e endif; 3e endif; 2e endif; read modifySrc; 1e enddo; //--------------------------------------------------------- // To insert records into source member you have to write out new member. // Idea here is to read original source and write it to new source. // When first D, or if no D then C spec is found, // execute subroutine to write newly generated D specs. 1b if DefinedCount > 0; p_CreateNew = *on; SrcSeqno += .01; HeaderSrc = 'H DFTACTGRP(*NO) ACTGRP(*CALLER) EXPROPTS(*RESDECPOS)'; except Header; SrcSeqno += .01; /IF DEFINED(*V6R1M0) HeaderSrc = 'H DATFMT(*ISO) TIMFMT(*ISO) OPTION(*NODEBUGIO: *NOUNREF)'; /ELSE HeaderSrc = 'H DATFMT(*ISO) TIMFMT(*ISO) OPTION(*NODEBUGIO)'; /ENDIF except Header; chain 1 modifySrc; 2b dow not %eof(modifySrc); 3b if not IsAlreadyDone; 4b if SpecType = 'D' or SpecType = 'd' or SpecType = 'C' or SpecType = 'c' or SpecType = 'I' or SpecType = 'i'; IsAlreadyDone = *on; // Process back through array and write D specs. HeaderSrc = *blanks; SrcSeqno += .01; except Header; SrcSeqno += .01; HeaderSrc = ' //--*STAND ALONE-------------------------------------------'; except Header; 5b if DefinedCount > 1; sorta %subarr(FldStorage: 1: DefinedCount); 5e endif; 5b for cc = 1 to DefinedCount; SrcSeqno += .01; StorageDS = FldStorage(cc); *in11 = *off; DataType = *blanks; 6b if dsFactor1 = '*LIKE '; *in11 = *on; LikeDefine = 'like(' + %trimr(dsFactor2) + ')'; 6x else; // load data type 7b if dsLength > *blanks; 8b if dsDecimals > *blanks; DataType = 'p'; 8x else; DataType = 'a'; 8e endif; 7e endif; 6e endif; except gendefine; 5e endfor; HeaderSrc = *blanks; SrcSeqno += .01; except Header; 4e endif; 3e endif; except writeall; read modifySrc; 2e enddo; 1e endif; *inlr = *on; return; /end-free ONEWSRC e Header O SrcSeqno 6 O 12 '000000' O HeaderSrc 77 O e writeall O allSrc 112 O e gendefine O SrcSeqno 6 O 12 '000000' O 18 'D' O dsResult 33 O 36 's' O dsLength 51 O DataType 52 O dsDecimals 54 O 11 LikeDefine 75 O dsText 112 OModifySrc e removelen O 82 ' ' O edel deleterec ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCR4PROTO - Convert *entry/call parms to prototypes - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate Prototyped V4 RPGLE') PARM KWD(RPG4MBR) TYPE(*NAME) MIN(1) PROMPT('RPG4 source member:') PARM KWD(RPG4SFL) TYPE(RPG4SFL) PROMPT('Source file:') RPG4SFL: QUAL TYPE(*NAME) DFT(QRPGLESRC) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(PROTMBR) TYPE(*NAME) MIN(1) PROMPT('New source member to generate:') PARM KWD(PROTSFL) TYPE(RPG4SFL) PROMPT('Source file:') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCR4PROTO'.Generate Prototyped V4 RPGLE (JCR4PROTO) - Help .*-------------------------------------------------------------------- :P.This JCR command reads your selected RPG4 source and generates new RPG4 source member with *entry and calls converted to main procedure interface and CALLP prototypes. All call opcodes are replaced with CALLP, all parm opcodes are replaced with prototype syntax. :P.If called program objects are in your library list, utility will auto-document prototypes with object text. :P.After conversion, 1) you may need to change some of prototype definitions due to DSPF files returning Signed. 2) if fields used as parms are defined in calc specs, then you will need to define them in D specs. 3) if entry parm field was defined on D spec, then D spec will have to be deleted.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCR4PROTO/RPG4MBR'.RPG4 member name - Help :XH3.RPG4 member name (RPG4MBR) :P.Member for which source is to be used as input.:EHELP. :HELP name='JCR4PROTO/RPG4SFL'.Source file - Help :XH3.Source file (RPG4SFL) :P.Source file containing source program.:EHELP. :HELP name='JCR4PROTO/PROTMBR'.New source member to generate - Help :XH3.New source member to generate (PROTMBR) :P.Member name to be generated by utility. Do not name same as input member name!:EHELP. :HELP name='JCR4PROTO/PROTSFL'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCR4PROTOR - Convert *entry/call parms to prototypes // Get field attributes from JCRGETFLDR // OriginRPG input file is read to control writing of non-call/non-parm statements to outfile // Seek1RPG input file will be used to run through and find *ENTRY and call Opcodes. // Seek2RPG input file will be used to run through and find defined parm Lists. // RPGSRC will be generated code. // Note: this program will, reluctantly convert CALLs that have variable names as // program name. // Prototype name will be 'v_' + field name. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FORIGINRPG if f 112 disk extfile(extIfile) extmbr(p_InMbr) F usropn FSEEK1RPG if f 112 disk extfile(extIfile) extmbr(p_InMbr ) F usropn FSEEK2RPG if f 112 disk extfile(extIfile) extmbr(p_InMbr ) F usropn FRPGSRC o f 112 disk extfile(extOfile) extmbr(p_OutMbr) F usropn //--*STAND ALONE------------------------------------------- D SrcOut s like(Src112) D AlreadyProto s 15a dim(1000) D PiSrcArry s 100a dim(512) D CalledPgmName s 10a D CallExtender s 10a D CallpArry s 100a dim(512) D CallpPostArry s 100a dim(512) D CallpPreArry s 100a dim(512) D PListName s 14a D SrcCspec s 100a D Alpha50 s 50a inz(*all'-') D SrcSeq s 6s 2 D Crrn1 s 10u 0 D Crrn2 s 10u 0 D pi s 5u 0 D rr s 5u 0 D v1 s 5u 0 D v2 s 5u 0 D v3 s 5u 0 D IsArray s n D IsCompileTime s n D IsDefinePList s n //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define FieldsArry /Define Constants /Define FieldsAttrDS /Define SrcDS /Define f_GetQual /Define f_Qusrobjd /Define f_SndCompMsg /Define f_SndEscapeMsg /Define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCR4PROTOR PR extpgm('JCR4PROTOR') D 10a D 20a D 10a D 20a D p_JCR4PROTOR PI D p_InMbr 10a D p_InFileQual 20a D p_OutMbr 10a D p_OutFileQual 20a //--*INPUT SPECS------------------------------------------- IOriginRPG ns I a 13 15 CompileArry I a 13 112 Src112 I a 19 19 Asterisk I a 62 75 RF ISeek1RPG ns I a 13 15 CompileArry1 I a 13 112 Seek1Src ISeek2RPG ns I a 13 15 CompileArry2 I a 13 112 Seek2Src I a 24 37 Seek2F1 I a 48 61 Seek2F2 I a 62 75 Seek2RF //--------------------------------------------------------- /free extIfile = f_GetQual(p_InFileQual); extOfile = f_GetQual(p_OutFileQual); // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_InFileQual: p_InMbr: DiagSeverity); 1b if DiagSeverity > '20'; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; open OriginRPG; open Seek1RPG; open Seek2RPG; open RPGSRC; read OriginRPG; 1b dow not %eof; Crrn1 += 1; 2b if CompileArry = '** ' or CompileArry = '**C' or CompileArry = '**c'; IsArray = *on; 2e endif; SrcDS.Src63 = %xlate(lo: up: Src112); 2b if IsArray or Asterisk = '/' or Asterisk = '+' or SrcDS.SpecType = 'D' or SrcDS.SpecType = 'F' or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'O' or (SrcDS.SpecType = 'C' and Asterisk <> '*' and SrcDS.Opcode <> 'PARM '); IsComment = *off; 2e endif; 2b if IsArray = *off and (not(Asterisk = '/' or Asterisk = '+' or Asterisk = '*')); 3b if SrcDS.SpecType = 'C' and (SrcDS.Factor1 = '*ENTRY ' or SrcDS.Opcode = 'PLIST ' or (%subst(SrcDS.Opcode: 1: 4) = 'CALL' and %subst(SrcDS.Opcode: 1: 5) <> 'CALLP' and %subst(SrcDS.Opcode: 1: 5) <> 'CALLB')); IsComment = *on; 3e endif; 3b if (SrcDS.SpecType = 'C') or (SrcDS.SpecType = 'I'); 4b if not IsFirstTime; exsr srGenAllProtoTypes; IsFirstTime = *on; SrcDS.Src63 = %xlate(lo: up: Src112); 4e endif; 3e endif; 3b if SrcDS.SpecType = 'C' and %subst(SrcDS.Opcode: 1: 4) = 'CALL' and %subst(SrcDS.Opcode: 1: 5) <> 'CALLP' and %subst(SrcDS.Opcode: 1: 5) <> 'CALLB'; exsr srGenCallpSrc; 3e endif; 2e endif; SrcSeq += .01; SrcOut = Src112; 2b if IsComment; %subst(SrcOut: 6: 2) = ' *'; 2e endif; except OutSrc; read OriginRPG; 1e enddo; close OriginRPG; close Seek1RPG; close RPGSRC; f_SndCompMsg('Prototype mbr ' + %trimr(p_OutMbr) + ' generated.'); *inlr = *on; return; //--------------------------------------------------------- // I need three steps here. // Before CALLP, If parm has factor2 value,load values // generate CALLP and parm value statements // After CALLP, If parms had factor1, load parm values to those // // Spin through CALLP and load arrays, after // CALLP is processed, write out 3 arrays. //--------------------------------------------------------- begsr srGenCallpSrc; clear CallpPreArry; clear CallpArry; clear CallpPostArry; v1 = 0; v2 = 0; v3 = 0; // extract program name clear CalledPgmName; aa = %scan(qs: SrcDS.Factor2: 2); 1b if aa = 0; //variable program name CalledPgmName = 'v_' + SrcDS.Factor2; 1x else; CalledPgmName = %xlate(up: lo: %subst(SrcDS.Factor2: 2: aa - 2)); 1e endif; // extract CALL SrcDS.Opcode extender clear CallExtender; aa = %scan('(': SrcDS.Opcode: 5); 1b if aa > 0; CallExtender = %subst(SrcDS.Opcode: aa); 1e endif; v1 = 1; CallpPreArry(v1) = ' *'; v2 = 1; CallpArry(v2) = ' C'; %subst(CallpArry(v2): 26) = 'callp' + %xlate(up: lo: CallExtender); %subst(CallpArry(v2): 36) = 'p_' + %trimr(%xlate(lo: up: CalledPgmName)) + '('; IsDefinePList = (SrcDS.ResultField > *blanks); 1b if IsDefinePList; PListName = SrcDS.ResultField; 1e endif; //--------------------------------------------------------- // if result field plist is used, // then read through and find where plist is defined // before starting prototype generation. 1b if IsDefinePList; setll 1 Seek2RPG; 1x else; chain Crrn1 Seek2RPG; 1e endif; read Seek2RPG; 1b dow not %eof; SrcDS.Src63 = %xlate(lo: up: Seek2Src); 2b if not(SrcDS.Asterisk = '/' or SrcDS.Asterisk = '+' or SrcDS.Asterisk = '*'); 3b if CompileArry2 = '** ' or CompileArry2 = '**C' or CompileArry2 = '**c'; IsCompileTime = *on; 1v leave; 3e endif; 3b if not IsDefinePList; 4b If (SrcDS.SpecType = 'C' and SrcDS.Opcode <> 'PARM ') or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'O'; 1v leave; 4e endif; 4b if SrcDS.Opcode = 'PARM '; 5b if Seek2F2 > *blanks; v1 += 1; CallpPreArry(v1) = ' C'; %subst(CallpPreArry(v1): 26) = 'eval'; %subst(CallpPreArry(v1): 36) = %trimr(seek2RF) + '=' + seek2F2; 5e endif; v2 += 1; CallpArry(v2) = ' C'; %subst(CallpArry(v2): 36) = %trimr(seek2RF) + ':'; 5b if Seek2F1 > *blanks; v3 += 1; CallpPostArry(v3) = ' C'; %subst(CallpPostArry(v3): 26) = 'eval'; %subst(CallpPostArry(v3): 36) = %trimr(seek2F1) + '=' + seek2RF; 5e endif; 4e endif; 3x else; 4b if SrcDS.Factor1 = PListName and SrcDS.Opcode = 'PLIST '; IsDefinePList = *off; 4e endif; 3e endif; 2e endif; read Seek2RPG; 1e enddo; v3 += 1; CallpPostArry(v3) = ' *'; //--------------------------------------------------------- // go back and put closing ) on last parm // If no parms where found on this call, put closing ) on callp statement aa = %scan(':': CallpArry(v2)); 1b if aa > 1; %subst(CallpArry(v2): aa: 1) = ')'; 1x else; CallpArry(v2) = %trimr(CallpArry(v2)) + ' )'; 1e endif; //--------------------------------------------------------- // now unload arrays into source IsDefinePList = *off; 1b for aa = 1 to v1; SrcCspec = CallpPreArry(aa); SrcSeq += .01; except CSPEC; 1e endfor; 1b for aa = 1 to v2; SrcCspec = CallpArry(aa); SrcSeq += .01; except CSPEC; 1e endfor; 1b for aa = 1 to v3; SrcCspec = CallpPostArry(aa); SrcSeq += .01; except CSPEC; 1e endfor; endsr; //--------------------------------------------------------- begsr srGenAllProtoTypes; crrn2 = 0; setll 1 Seek1RPG; read Seek1RPG; 1b dow not %eof; crrn2 += 1; 2b if CompileArry1 = '** ' or CompileArry1 = '**C' or CompileArry = '**c'; LV leavesr; 2e endif; SrcDS.Src63 = %xlate(lo: up: Seek1Src); 2b if not(SrcDS.Asterisk = '/' or SrcDS.Asterisk = '+' or SrcDS.Asterisk = '*'); //--------------------------------------------------------- // Generate Main PI procedure interface and PR // Prototype for *entry parms 3b if SrcDS.SpecType = 'C'; 4b if SrcDS.Factor1 = '*ENTRY '; pi = 0; SrcCspec = ' //-*ENTRY-----------------------------'; SrcSeq += .01; except CSPEC; pi += 1; PISrcArry(pi) = ' // -----------------------------------'; SrcCspec = ' D PR'; %subst(SrcCspec: 8: 15) = 'p_' + %xlate(up: lo: p_InMbr); %subst(SrcCspec: 44) = 'extpgm(' + qs + %trimr(p_InMbr) + qs + ')'; %subst(SrcCspec: 81) = ' '; SrcSeq += .01; except CSPEC; pi += 1; PISrcArry(pi) = ' D PI'; %subst(PISrcArry(pi): 8: 15) = 'p_' + %xlate(up: lo: p_InMbr); exsr srWriteProtoypeSpecs; exsr srWriteProcedureInterfaceSpecs; //--------------------------------------------------------- 4x elseif SrcDS.Opcode = 'CALL ' or %subst(SrcDS.Opcode: 1: 5) = 'CALL('; //if already prototyped, do not repeat aa = 0; 5b if rr > 0; aa = %lookup(SrcDS.Factor2: AlreadyProto: 1: rr); 6b if aa = 0; rr += 1; AlreadyProto(rr) = SrcDS.Factor2; 6e endif; 5x else; rr = 1; AlreadyProto(1) = SrcDS.Factor2; 5e endif; 5b if aa = 0; IsDefinePList = (SrcDS.ResultField > *blanks); 6b If IsDefinePList; PListName = SrcDS.ResultField; 6e endif; exsr srWriteProgramPrototypeSpecs; IsDefinePList = *off; 5e endif; 4e endif; 3e endif; 2e endif; read Seek1RPG; 1e enddo; endsr; //--------------------------------------------------------- // Generate prototype specs for called programs begsr srWriteProgramPrototypeSpecs; pi = 0; //little work here to extract program name clear CalledPgmName; aa = %scan(qs: SrcDS.Factor2: 2); 1b if aa = 0; //variable program name CalledPgmName = 'v_' + SrcDS.Factor2; SrcCspec = ' //---variable name--------------------------------------'; 1x else; CalledPgmName = %xlate(up: lo: %subst(SrcDS.Factor2: 2: aa - 2)); QusrObjDS = f_QUSROBJD(%xlate(lo: up:CalledPgmName) + '*LIBL ':'*PGM '); 2b if ApiErrDS.BytesReturned = 0; QusrObjDS.Text = %trimr(QusrObjDS.Text) + alpha50; 2x else; QusrObjDS.Text = *all'-'; 2e endif; SrcCspec = ' //---' + QusrObjDS.Text + '-'; 1e endif; SrcSeq += .01; except CSPEC; SrcCspec = ' D PR'; %subst(SrcCspec: 8: 15) = 'p_' + %xlate(up: lo: CalledPgmName); %subst(SrcCspec: 44) = 'extpgm(' + %trimr(SrcDS.Factor2) + ')'; %subst(SrcCspec: 81) = ' '; SrcSeq += .01; except CSPEC; exsr srWriteProtoypeSpecs; endsr; //--------------------------------------------------------- // if result field plist is used, // then read through finding plist definition before starting prototype generation. begsr srWriteProtoypeSpecs; 1b If IsDefinePList; setll 1 Seek2RPG; 1x else; chain Crrn2 Seek2RPG; 1e endif; read Seek2RPG; 1b dow not %eof; SrcDS.Src63 = %xlate(lo: up: Seek2Src); 2b if not(SrcDS.Asterisk = '/' or SrcDS.Asterisk = '+' or SrcDS.Asterisk = '*'); 3b if CompileArry2 = '** ' or CompileArry2 = '**C' or CompileArry2 = '**c'; IsCompileTime = *on; 1v leave; 3e endif; 3b If not IsDefinePList; 4b If (SrcDS.SpecType = 'C' and SrcDS.Opcode <> 'PARM ') or SrcDS.SpecType = 'P' or SrcDS.SpecType = 'O'; 1v leave; 4e endif; 4b if SrcDS.Opcode = 'PARM '; // if result is indexed, // remove index before lookup aa = %scan('(': SrcDS.ResultField); 5b if aa > 0; SrcDS.ResultField = %subst(SrcDS.ResultField: 1: aa - 1); 5e endif; // get field attributes aa = %lookup(SrcDS.ResultField: FieldsNameArry: 1: FieldsArry_NumberOfEntries); 5b if aa = 0; f_SndEscapeMsg('*ERROR* Field definition for ' + %trimr(SrcDS.ResultField) + ' not found.'); 5e endif; FieldsAttrDS = FieldsAttrArry(aa); SrcCspec = ' D'; %subst(SrcCspec: 30) = %editc(FieldsAttrDS.Length:'4'); %subst(SrcCspec: 40) = %xlate(up: lo: FieldsAttrDS.DataType); %subst(SrcCspec: 41) = FieldsAttrDS.DecimalPos; %subst(SrcCspec: 81) = Seek2RF; SrcSeq += .01; except CSPEC; %subst(SrcCspec: 8: 14) = Seek2RF; %subst(SrcCspec: 81) = *blanks; pi += 1; PISrcArry(pi) = SrcCspec; 4e endif; 3x else; 4b if SrcDS.Factor1 = PListName and SrcDS.Opcode = 'PLIST '; IsDefinePList = *off; 4e endif; 3e endif; 2e endif; read Seek2RPG; 1e enddo; endsr; //--------------------------------------------------------- begsr srWriteProcedureInterfaceSpecs; 1b for aa = 1 to pi; SrcCspec = PISrcArry(aa); SrcSeq += .01; except CSPEC; 1e endfor; SrcCspec = ' // -----------------------------------'; SrcSeq += .01; except CSPEC; endsr; /end-free ORPGSRC e OutSrc O SrcSeq 6 O 12 '000000' O SrcOut 112 ORPGSRC e CSPEC O SrcSeq 6 O 12 '000000' O SrcCspec 112 ]]> v5r4 //--------------------------------------------------------- // JCR4PROTOV - Validity checking program for lib/file/member //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_OutFileAddPfm /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCR4PROTOV PR extpgm('JCR4PROTOV') D 10a D 20a D 10a D 20a D p_JCR4PROTOV PI D p_InMbr 10a D p_InFileQual 20a D p_OutMbr 10a D p_OutFileQual 20a //--------------------------------------------------------- /free f_CheckMbr(p_InFileQual: p_InMbr); f_CheckObj(p_OutFileQual : '*FILE '); f_OutFileAddPfm(p_OutFileQual: p_OutMbr: 'X ': 'X ': p_InFileQual: p_InMbr); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* JCR5FREE - Convert V4 into V5 /free format - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate v5/free from v4 RPGLE') PARM KWD(RPG4MBR) TYPE(*NAME) MIN(1) PROMPT('RPG4 source member:') PARM KWD(RPG4SFL) TYPE(SRCFILE) PROMPT('Source file:') PARM KWD(RPG5MBR) TYPE(*NAME) MIN(1) PROMPT('RPG5 member to generate:') PARM KWD(RPG5SFL) TYPE(SRCFILE) PROMPT('Source file:') SRCFILE: QUAL TYPE(*NAME) DFT(QRPGLESRC) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='JCR5FREE'.Generate v5/free from v4 RPGLE (JCR5FREE) - Help .*-------------------------------------------------------------------- :P.CAUTION::: There is NO such thing as a 100% conversion tool from V4 columnar to V5/free!! Way too many total incompatibilities between the two. I would be extremely skeptical of anyone saying they have a 100% conversion tool. :P.This JCR command will convert v4 source that has been PURPOSELY written to convert into v5. :P.I strongly recommend using JCRFREESS utility to first print listing of what will not convert. Fix those problems in original program before using this utility.:EHELP. .*-------------------------------------------------------------------- :HELP name='JCR5FREE/RPG4MBR'.RPG4 member name - Help :XH3.RPG4 member name (RPG4MBR) :P.Member for which source is to be used as input.:EHELP. :HELP name='JCR5FREE/RPG4SFL'.Source file - Help :XH3.Source file (RPG4SFL) :P.Source file containing source program.:EHELP. :HELP name='JCR5FREE/RPG5MBR'.New source member to generate - Help :XH3.New source member to generate (RPG5MBR) :P.Member name to be generated by utility. Do not name same as input member name!:EHELP. :HELP name='JCR5FREE/RPG5SFL'.Source file - Help :XH3.Source file (RPG5SFL) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // JCR5FREER - Convert V4 into V5 /free format // There is no 100% V4 columnar to V5 free conversion tool. No matter how much you pay. // Much incompatibility between the two cannot be solved programmatically. // // This program takes v4 source that has been PURPOSELY written // to convert into v5, and converts it /free format. // I would strongly recommend using JCRFREESS utility to print out and fix everything // that CAN NOT be converted, before using this utility. //--------------------------------------------------------- // Areas that will need manual modification after convert: // lookup opcodes. These will need to be scrutinized // and tested. %found and %eQual bif not set by lookup operation // It is good bet you will have to rewrite some code here. // // for every ForCountxx FOR counter that is created, you will have to define // it. It is suggested you use like field names to define counters. // // Be aware, Multiple line IF, WHEN, etc statements that // do not end with AND or OR, will be incorrectly flagged as // stand alone statements. No big deal to edit code after conversion // and remove unneeded ;. // example // C if a=b // C or c=d // will convert to // if a=b; // or c=d; // which will need editing to be correct. // END opcodes will not match newly generated FOR, without JCRNUMB utility. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FV4SRC if f 112 disk extfile(extIfile) extmbr(p_InMbr) F usropn FV5SRC o f 112 disk extfile(extOfile) extmbr(p_OutMbr) F usropn //--*STAND ALONE------------------------------------------- D F2upper s like(f2) D RFupper s like(rf) D SrcOut s like(Src112) D Work s like(Src112) D WorkUpper s like(Src112) D LF2 s 14a D LineOfCode s 112a D NewOpCode s 10a varying D OpCode s 10a varying D opupsave s 10a D SrcCspec s 100a D toOpCode s 10a dim(999) varying D User s 6a D zz s 14a D ii s 10i 0 D kk s 10i 0 D SrcDat s 6s 0 D SrcSeq s 6s 2 D LevelsDeep s 5u 0 D xx s 5u 0 D yy s 5u 0 D StartPosition s 3u 0 inz(10) D IndentPerLevel s 3u 0 inz(3) D DownOneLvl s n D IsArray s n D IsCalcSpec s n D IsCallp s n D IsCasxx s n D IsContinuation s n D IsFree s n D IsLastTime s n inz(*on) D IsOutputSpec s n D IsWhenIndent s n D UpOneLvl s n //--*COPY DEFINES------------------------------------------ /Define Constants /Define f_GetQual /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*DATA STRUCTURES--------------------------------------- D OPup ds 10 D DoIfWh 2a overlay(OPup:1) D EndOpcode 3a overlay(OPup:1) //--*ENTRY PARMS------------------------------------------- D p_JCR5FREER PR extpgm('JCR5FREER') D 10a const D 20a const D 10a const D 20a const D p_JCR5FREER PI D p_InMbr 10a const D p_InFileQual 20a const D p_OutMbr 10a const D p_OutFileQual 20a const //--*INPUT SPECS------------------------------------------- Iv4Src ns I s 7 12 0chgDate I a 13 15 CompileArry I a 13 112 Src112 I a 18 18 SpecType I a 19 19 Asterisk I a 19 20 LevlInd I a 22 23 CondInd I a 38 47 OP i a 24 37 F1 i a 48 61 F2 i a 48 92 ExtF2 i a 62 75 RF i a 83 84 HIind i a 85 86 LOind i a 87 88 EQind i a 83 88 ResultingInd i a 93 112 SrcComment //--------------------------------------------------------- /free extIfile = f_GetQual(p_InFileQual); extOfile = f_GetQual(p_OutFileQual); open v4Src; open v5Src; read v4Src; 1b dow not %eof; 2b if CompileArry = '** ' or CompileArry = '**C' or CompileArry = '**c'; IsArray = *on; 2e endif; 2b if not IsArray; 3b if not %eof; NewOpCode = ''; // check for continuation line, indicated by // colon at first non-blank position of // next line, e.g.: msg = f_inzmsg('CPF9898' // :'Hello World|') IsContinuation = *off; read v4Src; 4b if not %eof; 5b if SpecType = 'C' or SpecType = 'c'; ii = %check(' ': Src112: 19); 6b if ii > 0; 7b if %subst(Src112: ii: 1) = ':'; IsContinuation = *on; 7e endif; 6e endif; 5e endif; readp v4Src; 4e endif; 3e endif; // special code for GFD: // retain last change user and remove user // from comment field (user is added later) user = %subst(SrcComment: 15); %subst(SrcComment: 15) = ''; %subst(Src112: 95) = ''; // special code for GFD: // change op-code to lower case OP = %xlate(up: lo: OP); // --------- 3b if SpecType = 'C' or SpecType = 'c'; IsCalcSpec = *on; 4b if not IsFirstTime; SrcCspec = ' /FREE'; SrcSeq = SrcSeq + .01; SrcDat = 0; IsFirstTime = *on; except CSPEC; // write a blank line SrcCspec = ''; SrcSeq = SrcSeq + .01; SrcDat = 0; except CSPEC; IsFree = *on; 4e endif; 3e endif; 3b if SpecType = 'D' or SpecType = 'd' or SpecType = 'F' or SpecType = 'f'; IsCalcSpec = *off; 3e endif; 3b if SpecType = 'P' or SpecType = 'p'; 4b if IsFree; IsLastTime = *off; IsFirstTime = *off; IsCalcSpec = *off; SrcCspec = ' /END-FREE'; SrcSeq = SrcSeq + .01; SrcDat = 0; except CSPEC; exsr srCommentLine; IsFree = *off; 4e endif; 3e endif; // end-free after 1st o spec only 3b if SpecType = 'O' or SpecType = 'o'; 4b if IsFree; IsLastTime = *off; IsFirstTime = *off; IsCalcSpec = *off; 5b if not IsOutputSpec; SrcCspec = ' /END-FREE'; SrcSeq = SrcSeq + .01; SrcDat = 0; except CSPEC; exsr srCommentLine; IsFree = *off; IsOutputSpec = *on; 5e endif; 4e endif; 3e endif; //--------------------------------------------------------- 2e endif; 2b if IsArray or not IsCalcSpec; SrcSeq = SrcSeq + .01; SrcOut = Src112; SrcDat = chgdate; except writenonC; 2x else; DownOneLvl = *off; UpOneLvl = *off; 3b if not (Asterisk = '+' or //no sql Asterisk = '/'); //no copy statements 4b if op > *blanks; IsCallp = *off; 4e endif; OPup = %xlate(lo: up: OP); 4b if Asterisk = '*'; 4x elseif EndOpcode = 'CAS'; IsCasxx = *on; 4x elseif OPup = 'SELECT '; // DownOneLvl = *on; reset IsWhenIndent; 4x elseif DoIfWh = 'DO' or DoIfWh = 'IF' or OPup = 'BEGSR ' or OPup = 'FOR ' or OPup = 'MONITOR ' or %subst(OPup: 1: 4) = 'FOR('; DownOneLvl = *on; //--------------------------------------------------------- // Set Flag if END is found 4x elseif EndOpcode = 'END'; 5b if not IsCasxx; UpOneLvl = *on; 5e endif; IsCasxx = *off; 4e endif; 3e endif; //--------------------------------------------------------- // Convert EVERYTHING to free format clear Work; clear LineOfCode; IsComment = *off; 3b if Asterisk = '*'; 4b if %subst(Src112: 8) = *blanks; Work = *blanks; 4x else; work = '// ' + %triml(%subst(Src112: 8)); IsComment = *on; 4e endif; 3x elseif LevlInd = '/E' or //i hate ejects LevlInd = '/e'; Work = *blanks; // there is no /free equivalent for these opcodes. List as is. //--------------------------------------------------------- // All DO statements must be converted to FOR opcodes // There are 5 variations of on DO // DO = DOU '1' // DO xx = FOR ForCount = 1 to xx // DO xx yy = FOR yy = 1 to xx // aa DO xx = FOR ForCount = aa to xx // aa DO xx yy = FOR yy = aa to xx //--------------------------------------------------------- 3x elseif OPup = 'DO '; 4b if F1 > *blanks //aa DO xx yy and F2 > *blanks and RF > *blanks; work = 'for ' + %trimr(RF) + ' = ' + %trimr(F1) + ' to ' + F2; NewOpCode = 'endfor'; 4x elseif F1 > *blanks //aa DO xx and F2 > *blanks and RF = *blanks; work = 'for ForCount' + %char(LevelsDeep) + ' = ' + %trimr(F1) + ' to ' + F2; NewOpCode = 'endfor'; 4x elseif F1 = *blanks and F2 > *blanks and RF > *blanks; work = 'for ' + %trimr(RF) + ' = 1 to ' + F2; NewOpCode = 'endfor'; 4x elseif F1 = *blanks and F2 > *blanks and RF = *blanks; work = 'for ForCount' + %char(LevelsDeep) + ' = 1 to ' + F2; NewOpCode = 'endfor'; 4x elseif F1 = *blanks and F2 = *blanks and RF = *blanks; work = 'dou ''''1'''''; 4e endif; 3x elseif %subst(OPup: 1: 6) = 'ADDDUR' or %subst(OPup: 1: 6) = 'SUBDUR'; exsr srADDDUR; 3x elseif %subst(OPup: 1: 6) = 'EXTRCT'; work = %trimr(RF) + ' = %subdt(' + %trimr(F2) + ')'; 3x elseif %subst(OPup: 1: 5) = 'CHECK'; work = %trimr(RF) + ' = %' + %trimr(OP) + '(' + %trimr(F1) + ':' + %trimr(F2) + ')'; 3x elseif %subst(OPup: 1: 5) = 'XLATE'; work = %trimr(RF) + ' = %' + %trimr(OP) + '(' + %trimr(F1) + ':' + %trimr(F2) + ')'; 3x elseif %subst(OPup: 1: 6) = 'LOOKUP'; exsr srLOOKUP; 3x elseif %subst(OPup: 1: 5) = 'XFOOT'; exsr srXFOOT; 3x elseif %subst(OPup: 1: 5) = 'OCCUR'; exsr srOCCUR; //--------------------------------------------------------- // FACTOR1 OP FACTOR2 RESULT conversions. // FACTOR1 OP FACTOR2 // FACTOR1 OP // end result is opcode factor1 factor2 Result 3x elseif %subst(OPup: 1: 3) = 'ACQ' or OPup = 'BEGSR ' or OPup = 'MONITOR ' or OPup = 'ON-ERROR ' or %subst(OPup: 1: 5) = 'CHAIN' or %subst(OPup: 1: 6) = 'COMMIT' or %subst(OPup: 1: 6) = 'DELETE' or %subst(OPup: 1: 5) = 'DSPLY' or %subst(OPup: 1: 4) = 'DUMP' or %subst(OPup: 1: 4) = 'POST' or %subst(OPup: 1: 3) = 'END' or %subst(OPup: 1: 3) = 'IN ' or %subst(OPup: 1: 3) = 'IN(' or %subst(OPup: 1: 4) = 'NEXT' or %subst(OPup: 1: 3) = 'OUT' or %subst(OPup: 1: 4) = 'POST' or %subst(OPup: 1: 5) = 'READE' or %subst(OPup: 1: 6) = 'READPE' or %subst(OPup: 1: 3) = 'REL' or %subst(OPup: 1: 5) = 'RESET' or OPup = 'CLEAR ' or %subst(OPup: 1: 5) = 'ROLBK' or %subst(OPup: 1: 5) = 'SETGT' or %subst(OPup: 1: 5) = 'SETLL' or %subst(OPup: 1: 5) = 'TEST ' or %subst(OPup: 1: 5) = 'TEST(' or %subst(OPup: 1: 6) = 'UNLOCK'; 4b if F1 = *blanks; work = %trimr(OP) + ' ' + %trimr(F2) + ' ' + RF; 4x else; work = %trimr(OP) + ' ' + %trimr(F1) + ' ' + %trimr(F2) + ' ' + RF; 4e endif; // resulting ind errors 4b if ResultingInd > *blanks; work = %trimr(Work) + ' ??' + %trim(ResultingInd) + '????????????????'; opupsave = opup; opup = 'ResultInd'; opup = opupsave; 4e endif; //--------------------------------------------------------- // opcode FACTOR2 RESULT conversions. // opcode FACTOR2 // end result is Opcode Factor2 Result 3x elseif OPup = 'EXCEPT ' or OPup = 'EXFMT ' or OPup = 'EXSR ' or OPup = 'ELSE ' or OPup = 'FORCE ' or OPup = 'ITER ' or OPup = 'LEAVE ' or OPup = 'LEAVESR' or OPup = 'OTHER ' or %subst(OPup: 1: 5) = 'CLOSE' or %subst(OPup: 1: 4) = 'OPEN' or %subst(OPup: 1: 5) = 'READ ' or %subst(OPup: 1: 5) = 'READ(' or %subst(OPup: 1: 5) = 'READC' or %subst(OPup: 1: 5) = 'READP' or OPup = 'SELECT ' or OPup = 'SORTA ' or %subst(OPup: 1: 6) = 'UPDATE' or %subst(OPup: 1: 5) = 'WRITE' or %subst(OPup: 1: 4) = 'FEOD'; work = %trimr(OP) + ' ' + %trimr(F2) + ' ' + RF; 4b if ResultingInd > *blanks; work = %trimr(Work) + ' ??' + %trim(ResultingInd) + '????????????????'; opupsave = opup; opup = 'ResultInd'; opup = opupsave; 4e endif; //--------------------------------------------------------- // Opcode RESULT field simple compressions 3x elseif %subst(OPup: 1:7) = 'DEALLOC'; work = %trimr(OP) + ' ' + RF; //--------------------------------------------------------- // opcode Extended Factor2 compressions // Will need to revisit this for + signs to line up code. 3x elseif %subst(OPup: 1: 4) = 'DOU ' or %subst(OPup: 1: 4) = 'DOU(' or %subst(OPup: 1: 4) = 'DOW ' or %subst(OPup: 1: 4) = 'DOW(' or %subst(OPup: 1: 5) = 'CALLP' or %subst(OPup: 1: 4) = 'EVAL' or %subst(OPup: 1: 4) = 'FOR ' or %subst(OPup: 1: 4) = 'FOR(' or %subst(OPup: 1: 3) = 'IF ' or %subst(OPup: 1: 3) = 'IF(' or %subst(OPup: 1: 6) = 'RETURN' or %subst(OPup: 1: 5) = 'WHEN ' or %subst(OPup: 1: 5) = 'WHEN('; work = %trimr(OP) + ' ' + ExtF2; // get position for callp parms to line up with factor2 bb = %scan(ExtF2: Work); 4b if %subst(OPup: 1: 5) = 'CALLP'; IsCallp = *on; 4e endif; 3x else; //--------------------------------------------------------- 4b if OPup = *blanks; 5b if not IsCallp; work = ExtF2; 5x else; clear Work; %subst(Work: bb) = %trimr(ExtF2); 5e endif; 4x else; work = %trimr(OP) + ' ?????????????????????????'; 4e endif; 3e endif; exsr srOutput; 2e endif; read v4Src; 1e enddo; 1b if IsLastTime; 2b if IsFree; SrcCspec = ' /END-FREE'; SrcSeq = SrcSeq + .01; SrcDat = 0; except CSPEC; exsr srCommentLine; IsFree = *off; 2e endif; 1e endif; close v4Src; close v5Src; f_SndCompMsg('RPGLE /free mbr ' +%trimr(p_OutMbr) + ' generated.'); *inlr = *on; return; //--------------------------------------------------------- begsr srADDDUR; f2upper = %xlate(lo: up: f2); rfupper = %xlate(lo: up: RF); work = *blanks; 1b if OPup = 'ADDDUR(E)' or OPup = 'SUBDUR(E)'; work = 'eval(e) '; 1e endif; xx = %scan(':': F2); 1b if xx > 0; work = %trimr(Work) + ' ' + %trimr(RF) + ' ='; 2b if F1 = *blank; work = %trimr(Work) + ' ' + RF; 2x else; work = %trimr(Work) + ' ' + F1; 2e endif; 2b if %subst(OPup: 1: 6) = 'ADDDUR'; work = %trimr(Work) + ' + '; 2x else; work = %trimr(Work) + ' - '; 2e endif; xx = %scan(':': F2); 2b if %subst(F2upper : xx + 1) = '*MSECONDS' or %subst(F2upper: xx + 1) = '*MS'; work = %trimr(Work) + ' %mseconds('; 2x elseif %subst(F2upper: xx + 1) = '*SECONDS' or %subst(F2upper: xx + 1) = '*S'; work = %trimr(Work) + ' %seconds('; 2x elseif %subst(F2upper: xx + 1) = '*MINUTES' or %subst(F2upper: xx + 1) = '*MN'; work = %trimr(Work) + ' %minutes('; 2x elseif %subst(F2upper: xx + 1) = '*HOURS' or %subst(F2upper: xx + 1) = '*H'; work = %trimr(Work) + ' %hours('; 2x elseif %subst(F2upper: xx + 1) = '*DAYS' or %subst(F2upper: xx + 1) = '*D'; work = %trimr(Work) + ' %days('; 2x elseif %subst(F2upper: xx + 1) = '*MONTHS' or %subst(F2upper: xx + 1) = '*M'; work = %trimr(Work) + ' %months('; 2x elseif %subst(F2upper: xx + 1) = '*YEARS' or %subst(F2upper: xx + 1) = '*Y'; work = %trimr(Work) + ' %year('; 2e endif; work = %trimr(Work) + %subst(F2: 1: xx - 1) + ')'; 1x else; //--------------------------------------------------------- // Process DIFF statements // first extract field from RF xx = %scan(':': RF); work = %trimr(Work) + ' ' + %subst(RF: 1: xx - 1) + ' = %diff(' + %trimr(F1) + ':' + %trimr(f2) + ':' + %trimr(%subst(rf: xx + 1)) + ')'; 1e endif; endsr; //--------------------------------------------------------- begsr srLOOKUP; clear zz; lf2 = f2; f2upper = %xlate(lo: up: f2); work = *blanks; 1b if %subst(F2upper: 1: 3) = 'TAB'; work = '*in' + %trim(ResultingInd) + ' = %tlookup'; 1x else; xx = %scan('(': F2); 2b if xx = 0; 3b if (ResultingInd) > *blanks; work = '*in' + %trim(ResultingInd) + ' = %lookup'; 3x else; work = 'jcrInt = %lookup'; 3e endif; 2x else; yy = %scan(')': F2: xx); lf2 = %subst(f2: 1: xx - 1); zz = %subst(f2: xx + 1: yy - (xx + 1)); work = %trimr(zz) + ' = %lookup'; 2e endif; 1e endif; //--------------------------------------------------------- // Now look at indicators assigned and tack on type lookup. 1b if EQind > *blanks and HIind = *blanks and LOind = *blanks; 1x elseif EQind = *blanks and HIind > *blanks and LOind = *blanks; work = %trimr(Work) + 'GT('; 1x elseif EQind = *blanks and HIind = *blanks and LOind > *blanks; work = %trimr(Work) + 'LT('; 1x elseif EQind > *blanks and HIind > *blanks and LOind = *blanks; work = %trimr(Work) + 'GE('; 1x elseif EQind > *blanks and HIind = *blanks and LOind > *blanks; work = %trimr(Work) + 'LE('; 1x else; work = %trimr(Work) + '??('; 1e endif; work = %trimr(Work) + %trimr(f1) + ':' + %trimr(lf2); 1b if %subst(F2upper: 1: 3) <> 'TAB'; 2b if zz = *blanks; work = %trimr(Work) + ')'; 2x else; work = %trimr(Work) + ':' + %trimr(zz) + ')'; 2e endif; 1x else; 2b if RF = *blanks; work = %trimr(Work) + ')'; 2x else; work = %trimr(Work) + ':' + %trimr(RF) + ')'; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srXFOOT; work = *blanks; xx = %scan('(': OP); 1b if xx > 0; work = %trimr(Work) + %subst(OP: xx); 1e endif; work = %trimr(Work) + ' ' + %trimr(RF) + ' = %xfoot(' + %trimr(F2) + ')'; endsr; //--------------------------------------------------------- begsr srOCCUR; work = *blanks; xx = %scan('(': OP); 1b if xx > 0; work = %trimr(Work) + %subst(OP: xx); 1e endif; 1b if F1 > *blanks; work = %trimr(Work) + ' %occur(' + %trimr(F2) + ') = ' + F1; 1x else; work = %trimr(Work) + ' ' + %trimr(RF) + ' = %occur(' + %trimr(F2) + ')'; 1e endif; endsr; //--------------------------------------------------------- begsr srOutput; 1b if UpOneLvl; 2b if toOpCode(LevelsDeep) <> ''; ii = %check(' ': Work); 3b if ii > 0; kk = %scan(' ': Work); Work = %replace(toOpCode(LevelsDeep): Work: ii: kk - ii); 3e endif; 2e endif; toOpCode(LevelsDeep) = ''; LevelsDeep -= 1; 1e endif; //--------------------------------------------------------- // come back up level for when and others 1b if (opup = 'WHEN ' or opup = 'OTHER') and IsWhenIndent; LevelsDeep = LevelsDeep - 1; 1e endif; clear LineOfCode; xx = StartPosition - 7 + (LevelsDeep * IndentPerLevel); // deal with indenting code under WHEN, OTHER statement. 1b if opup = 'WHEN ' or opup = 'OTHER'; LevelsDeep += 1; IsWhenIndent = *on; 1e endif; 1b if not IsComment; // special code for GFD: strip out OpCode ... 2b if opup = 'CALLP'; OpCode = 'CALLP'; exsr srStripOpCode; 2x elseif opup = 'EVAL'; OpCode = 'EVAL'; exsr srStripOpCode; 2e endif; 1e endif; // deal with lines ending in AND / OR / + %subst(LineOfCode: xx) = Work; WorkUpper = %xlate(lo: up: Work); aa = %checkr(' ': WorkUpper); 1b if LineOfCode > *blanks and (aa > 3 and IsComment = *off and not (%subst(WorkUpper: aa: 1) = '+' or %subst(WorkUpper: aa: 1) = ':' or %subst(WorkUpper: aa: 1) = '=' or %subst(WorkUpper: aa: 1) = '>' or %subst(WorkUpper: aa: 1) = '<' or %subst(WorkUpper: aa: 1) = '(' or %subst(WorkUpper: aa - 3: 4) = ' AND' or %subst(WorkUpper: aa - 2: 3) = ' OR')); 2b if not IsContinuation; LineOfCode = %trimr(LineOfCode) + ';'; 2e endif; 1e endif; //--------------------------------------------------------- // Tack on comment field 1b if SrcComment > *blanks and not IsComment; 2b if %subst(LineOfCode: 71: 8) = ' '; %subst(LineOfCode: 71: 2) = '//'; %subst(LineOfCode: 73: 20) = SrcComment; 2x else; LineOfCode = %trimr(LineOfCode) + ' // ' + SrcComment; 2e endif; 1e endif; // special code for GFD: 1b if user > *blanks; %subst(LineOfCode: 86: 2) = '//'; %subst(LineOfCode: 88: 6) = user; 1e endif; 1b if DownOneLvl; LevelsDeep = LevelsDeep + 1; 2b if NewOpCode <> ''; toOpCode(LevelsDeep) = NewOpCode; 2e endif; 1e endif; 1b if LevlInd > *blanks and not (%subst(LevlInd: 1: 1) = '/' or %subst(LevlInd: 1: 1) = '*'); LineOfCode = '??' + LevlInd + '??????? ' + LineOfCode; opupsave = opup; opup = 'LevelInd'; opup = opupsave; 1e endif; 1b if CondInd > *blanks and not (%subst(LevlInd: 1: 1) = '/' or %subst(LevlInd: 1: 1) = '*'); LineOfCode = '??' + CondInd + '??????? ' + LineOfCode; opupsave = opup; opup = 'ConditInd'; opup = opupsave; 1e endif; SrcSeq = SrcSeq + .01; SrcDat = chgDate; 1b if opup = 'KLIST ' or opup = 'KFLD '; evalr SrcCspec = Src112; 1x else; SrcCspec = ' '+LineOfCode; 1e endif; except CSPEC; endsr; //--------------------------------------------------------- // STRIP OPCODE begsr srStripOpCode; ii = %check(' ': Work); //determine start position of OpCode 1b if ii > 0; kk = ii + %len(OpCode); //set pointer after OpCode 2b if %subst(Work: kk: 1) = ''; kk = %check(' ': Work: kk); //find next character 2e endif; 2b if kk > 0; 3b if %subst(Work: kk: 1) <> '('; //check for '(' Work = %replace('': Work: ii: kk - ii); 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Write comment line begsr srCommentLine; SrcCspec = ' *'; SrcSeq = SrcSeq + .01; SrcDat = 0; except CSPEC; endsr; /end-free Ov5Src e writenonC O SrcSeq 6 O SrcDat 12 O SrcOut 112 Ov5Src e CSPEC O SrcSeq 6 O SrcDat 12 O SrcCspec 112 ]]> v5r4 //--------------------------------------------------------- // JCR5FREEV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /Define f_OutFileAddPfm /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_JCR5FREEV PR extpgm('JCR5FREEV') D 10a const D 20a const D 10a const D 20a const D p_JCR5FREEV PI D p_InMbr 10a const D p_InFileQual 20a const D p_OutMbr 10a const D p_OutFileQual 20a const //--------------------------------------------------------- /free f_CheckMbr(p_InFileQual : p_InMbr); f_CheckObj(p_OutFileQual : '*FILE '); f_OutFileAddPfm( p_OutFileQual: p_OutMbr: 'X ': 'X ': p_InFileQual: p_InMbr); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLGEN - Generate XML source member - CMD */ /* Martin Rowe scripting cmd prompts */ /* David George intellectual input */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate XML download mbrs') PARM KWD(XMLSCRIPT) TYPE(*NAME) LEN(10) MIN(1) PROMPT('Script member name') PARM KWD(SCRIPTSRCF) TYPE(SCRIPTSRCF) MIN(0) PROMPT('Script source file') SCRIPTSRCF: QUAL TYPE(*NAME) LEN(10) DFT(QXMLGENS) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(SRCTOFILE) TYPE(SRCTOFILE) MIN(0) + PROMPT('Source file to put XML member') SRCTOFILE: QUAL TYPE(*NAME) LEN(10) DFT(QXML) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLGENC- Generate XML source member - From Selected Group ID */ /*--------------------------------------------------------------------------*/ PGM PARM(&SCRIPTMBR &SCRIPTSFL &XMLTOSFL) DCL &SCRIPTMBR *CHAR 10 /* MEMBER NAME IN SCRIPT FILE */ DCL &SCRIPTSFL *CHAR 20 /* SCRIPT SOURCE FILE LIB */ DCL &SCRIPTSFIL *CHAR 10 DCL &SCRIPTSLIB *CHAR 10 DCL &XMLTOSFL *CHAR 20 /* TO SOURCE FILE LIB */ DCL &XMLTOSFIL *CHAR 10 DCL &XMLTOSLIB *CHAR 10 DCL &TEXT *CHAR 50 CHGVAR VAR(&SCRIPTSFIL) VALUE(%SST(&SCRIPTSFL 1 10)) CHGVAR VAR(&SCRIPTSLIB) VALUE(%SST(&SCRIPTSFL 11 10)) CHGVAR VAR(&XMLTOSFIL) VALUE(%SST(&XMLTOSFL 1 10)) CHGVAR VAR(&XMLTOSLIB) VALUE(%SST(&XMLTOSFL 11 10)) IF COND(&SCRIPTSLIB = '*LIBL ') THEN(DO) RTVOBJD OBJ(&SCRIPTSFIL) OBJTYPE(*FILE) RTNLIB(&SCRIPTSLIB) MONMSG MSGID(CPF0000) ENDDO IF COND(&XMLTOSLIB = '*LIBL ') THEN(DO) RTVOBJD OBJ(&XMLTOSFIL) OBJTYPE(*FILE) RTNLIB(&XMLTOSLIB) MONMSG MSGID(CPF0000) ENDDO /* Create selected outfile and member (if requried) */ SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('XML + code generation in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) ADDPFM FILE(&XMLTOSLIB/&XMLTOSFIL) MBR(&SCRIPTMBR) MONMSG MSGID(CPF0000) EXEC(CLRPFM FILE(&XMLTOSLIB/&XMLTOSFIL) MBR(&SCRIPTMBR)) CHGVAR VAR(&TEXT) VALUE('XML data for group ' *CAT &SCRIPTMBR *TCAT '.') CHGPFM FILE(&XMLTOSLIB/&XMLTOSFIL) MBR(&SCRIPTMBR) SRCTYPE(XML) TEXT(&TEXT) /* Call program to generate XML source */ OVRDBF FILE(SCRIPT) TOFILE(&SCRIPTSLIB/&SCRIPTSFIL) + MBR(&SCRIPTMBR) OVRSCOPE(*JOB) OVRDBF FILE(GENSRC) TOFILE(&XMLTOSLIB/&XMLTOSFIL) + MBR(&SCRIPTMBR) OVRSCOPE(*JOB) CALL XMLGENR PARM(&SCRIPTMBR) DLTOVR FILE(SCRIPT) LVL(*JOB) DLTOVR FILE(GENSRC) LVL(*JOB) SNDPGMMSG MSG('XML generation for ' *CAT &SCRIPTMBR *TCAT ' + in ' *CAT &XMLTOSLIB *TCAT '/' *CAT &XMLTOSFIL *TCAT ' - completed.') ENDPGM ]]> */ /*--------------------------------------------------------------------------*/ /* XMLGENCMD - PROMPT IN SCRIPT MEMBER FOR COMMANDS TO EXECUTE */ /* COPYRIGHT (C) MARTIN ROWE */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Script - Command Prompt') PARM KWD(XCMD) TYPE(*CMDSTR) LEN(500) MIN(1) PROMPT('Command to execute') ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='XMLGEN'.Generate XML download mbrs (XMLGEN) - Help .*-------------------------------------------------------------------- :P.This command generates source file member containing validated, well-formed XML text with all the information required to recreate your source members/objects on another system. :P.The driver is 'script' member in source file QXMLGENS where you describe source members and object types you want to associate together with particular application build. The script member for this utility XMLGEN is in source file QXMLGENS for you to review. :P.Three commands included in this utility are used to build information in script file. :LINES. xmlgenINC specify whether to generate text for install pgm xmlgenMBR define attributes of source members and objects xmlgenCMD define commands to be executed at runtime. :ELINES. :P.The xmlgenINC command must appear first in your script source, but xmlgenMBR and xmlgenCMD can be mixed in any sequence after that and may be used any number of times. Installer program execution follows same sequence of events defined in script. .*-------------------------------------------------------------------- :LINES.Objects used by this command are: XMLGEN *CMD Command Prompt XMLGENC *PGM CLLE Command Processing Program XMLGENCMD *CMD Script command to execute XMLGENINC *CMD Script include installer XMLGENMBR *CMD Script to include source mbr XMLGENR *PGM RPGLE XML builder XMLGENARR *PGM RPGLE Source for installer program XMLGENH *PNLGRP Help Text XMLGENRV *PGM RPGLE Validity Checking :ELINES.:EHELP. :HELP name='XMLGEN/XMLSCRIPT'.Script member name - Help :XH3.Script member name (XMLSCRIPT) :P.Member name of script mbr in file QXMLGENS containing source and object information for this app.:EHELP. :HELP name='XMLGEN/SCRIPTSRCF'.Script source file - Help :XH3.Script source file (SCRIPTSRCF) :P.Source file where script for this app is stored. :PARML.:PT.:PK def.QXMLGENS:EPK.:PD.The default source file, QXMLGENS will be used. :PT.source-file-name :PD.Enter source file name for script member. :PT.:PK def.*LIBL:EPK.:PD.The system searches library list to find library where source file is located. :PT.library-name :PD.Enter name of library where source file is located.:EPARML.:EHELP. :HELP name='XMLGEN/SRCTOFILE'.Source file - Help :XH3.Source file (SRCTOFILE) :P.Source file where XML member will be created. :PARML.:PT.:PK def.QXML:EPK.:PD.The default source file, QXML will be used. :PT.source-file-name :PD.Enter source file name for XML member. :PT.:PK def.*LIBL:EPK.:PD.The system searches library list to find library where source file is located. :PT.library-name :PD.Enter name of library where source file is located.:EPARML.:EHELP.:EPNLGRP. ]]> */ /*--------------------------------------------------------------------------*/ /* XMLGENINC - PROMPT IN SCRIPT MEMBER TO INCLUDE INSTALLER PROGRAM IN XML */ /* COPYRIGHT (C) MARTIN ROWE */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Load Installer Program in XML') PARM KWD(XINCLUDE) TYPE(*CHAR) LEN(4) RSTD(*YES) + VALUES(*YES *NO) MIN(1) PROMPT('Load Installer Program in XML:') ]]> */ /*--------------------------------------------------------------------------*/ /* XMLGENMBR - PROMPT IN SCRIPT MEMBER FOR SOURCE MEMBER INFORMATION */ /* TO LOAD MEMBERS INTO OUTPUT FILE. */ /* COPYRIGHT (C) MARTIN ROWE */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Script - Source member info') PARM KWD(XMBR) TYPE(*NAME) LEN(10) MIN(1) PROMPT('Member name') PARM KWD(XMBRATR) TYPE(*NAME) LEN(10) MIN(1) + CHOICE('RPGLE CLP DSPF CMD etc') PROMPT('Source member attribute') PARM KWD(XFROMSRCF) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Copy from source file') PARM KWD(XFROMSRCL) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Copy from source lib') PARM KWD(XTOSRCF) TYPE(*NAME) LEN(10) MIN(1) + CHOICE('QRPGLESRC QCLSRC QDDSSRC etc') PROMPT('Target source file') PARM KWD(XOBJTYPE) TYPE(*CHAR) LEN(7) RSTD(*YES) + VALUES(*CMD *FILE *MENU *MODULE *PGM + *PNLGRP *QMQRY *SQLPKG *SRVPGM *TBL + *BNDSRC *CPYSRC) MIN(1) MAX(1) EXPR(*YES) PROMPT('Object type') PARM KWD(XGENCRT) TYPE(*CHAR) LEN(4) RSTD(*YES) + VALUES(*YES *NO) MIN(1) PROMPT('Generate compile code for mbr') ]]> v5r4 //--------------------------------------------------------- // XMLGENR - Generate XML source member // Read member script file to generate XML data //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FSCRIPT if f 92 disk extfile(extIfile) usropn F extmbr(p_ScriptMbr) FXMLOUTFILEuf a f 112 disk extfile(ExtXmlOutfile) usropn F extmbr(p_ScriptMbr) FMBRSRC if f 112 disk extfile(extOfile) usropn F extmbr(xMbr) infds(Infds) //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Infds /Define Constants /Define f_CrtCmdString /Define f_GetQual /Define f_Qusrmbrd /Define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D InstructArry s 100a dim(22) ctdata perrcd(1) D RpgArry s 100a dim(308) ctdata perrcd(1) D ba s 1a inz('[') D bc s 1a inz(']') D SrcOut s 100a D a17 s 17a D SeqNum s 6s 2 D SeqDate s 6s 0 D IsAllLoaded s n D String s 500a varying D XmlOutfileFile s 30a varying D AllowLimited s 10a inz('YES ') D extXmlOutfile s 21a D CopyFromRec s 10u 0 D CopyToRec s 10u 0 D RecordCounter s 10u 0 D ParserLine s 10u 0 // values extracted from mbr script command D xMbr s 10a member name D xMbratr s 10a src mbr attr D xfromSrcf s 10a copy from Src file D xfromSrcl s 10a copy from Src lib D xtoSrcf s 10a copy to Src file D xobjtype s 7a object type D xgencrt s 4a gen compile code? D xinclude s 4a gen compile code? //--*DATA STRUCTURES--------------------------------------- // Get source file length and CCSID of source file // from integer to alpha for load into XML. D MakeAlpha1 ds D SrcLenA 1 5a D SrcLenD 1 5s 0 inz D MakeAlpha2 ds D SrcCcsidA 1 5a D SrcCcsidD 1 5s 0 inz //--*FUNCTION PROTOTYPES----------------------------------- D f_GetMbrText PR 50a D 20a const File and Lib D 10a Member name //--*ENTRY PARMS------------------------------------------- D p_xmlgenr PR extpgm('XMLGENR') D 10a const Script source member D 20a const Script Src fil lib D 20a const Output XML fil lib D p_xmlgenr PI D p_ScriptMbr 10a const D p_ScriptQual 20a const D p_OutFileQual 20a const //--*INPUT SPECS------------------------------------------- ISCRIPT ns I a 13 92 xScriptSrc IMBRSRC ns I a 13 112 SrcDta IXmlOutfilens I a 13 112 XmlDta //--------------------------------------------------------- /free extIfile = f_GetQual(p_ScriptQual); extXmlOutfile = f_GetQual(p_OutFileQual); open SCRIPT; open XmlOutfile; // generate XML header statement. SrcOut = ''; exsr srWriteCode; //--------------------------------------------------------- // Read down in script to get whether or not to include installer. // XMLGENINC XINCLUDE(*YES) *YES, *NO read SCRIPT; 1b dou aa > 0; aa = %scan('XINCLUDE(': xScriptSrc); 2b if aa > 0; cc = %scan(')': xScriptSrc: aa + 9); xinclude = %subst(xScriptSrc: aa + 9: cc - (aa + 9)); 1v leave; 2e endif; read SCRIPT; 1e enddo; //--------------------------------------------------------- // Generate Install instructions and Install program. 1b if xinclude = '*YES'; // load '; exsr srWriteCode; clear SrcOut; //--------------------------------------------------------- // load // hex values BA=open BC=close // Load instruction array to outfile. SrcOut = '' + ' 0; exsr srLoadString; exsr srParseMbrVal; SrcOut = '* ' + xMbr + ' ' + xMbratr + ' ' + f_GetMbrText(xfromSrcf + xfromSrcl: xMbr); exsr srWriteCode; 3e endif; read SCRIPT; 2e enddo; chain 1 SCRIPT; // write comment line / closing border line. SrcOut = '*'; exsr srWriteCode; SrcOut = InstructArry(1); exsr srWriteCode; // close brackets SrcOut = bc+bc+'> '; exsr srWriteCode; // load Load RPG Source array to outfile. SrcOut = '' + ' ' + ' '; exsr srWriteCode; 1x else; SrcOut = ''; exsr srWriteCode; 1e endif; //--------------------------------------------------------- // Spin through script file and load data from tags as they occur. // XMLGENMBR XMBR(XMLGEN) XMBRATR(CLP) XFROMSRCF(JCLSRC) + // XFROMSRCL(JCRCMDS) XTOSRCF(QCLSRC) + // XOBJTYPE(*PGM) XGENCRT(*YES) // XMLGENCMD XCMD(CRTDTAARA DTAARA(&TOLIB/TEST) + // TYPE(*CHAR) LEN(10) VALUE(A)) read SCRIPT; 1b dow not %eof; aa = %scan('XMLGENMBR': xScriptSrc); 2b if aa > 0; exsr srLoadString; exsr srParseMbrVal; exsr srLoadMbr; 2x else; aa = %scan('XMLGENCMD': xScriptSrc); 3b if aa > 0; exsr srLoadString; exsr srLoadExc; 3e endif; 2e endif; read SCRIPT; 1e enddo; // generate completed message code. SrcOut = '' + ' '; exsr srWriteCode; SrcOut = ''; exsr srWriteCode; close SCRIPT; //--------------------------------------------------------- // Now that all XML is generated, spin back through // and get record numbers where install program is // located. Update installation copy instructions with // From and To record numbers. 1b if xinclude = '*YES'; setll 1 XmlOutFile; read XmlOutFile; 2b dow not %eof; RecordCounter += 1; 3b if %scan('TOMBR(parser) MBROPT(*REPLACE)':XmlDta) > 0; ParserLine = RecordCounter; 3e endif; 3b if %scan('* /// START OF INSTALL PGM HERE ':XmlDta) > 0; CopyFromRec = RecordCounter + 1; 3e endif; 3b if %scan('* /// END OF INSTALL PGM HERE ':XmlDta) > 0; CopyToRec = RecordCounter - 1; 2v leave; 3e endif; read XmlOutfile; 2e enddo; chain ParserLine XmlOutfile; %subst(XmlDta:41) = 'FROMRCD(' + %char(CopyFromRec) + ') TORCD(' + %char(CopyToRec) + ')'; except UpdateXML; 1e endif; close XmlOutfile; f_SndCompMsg('XML member ' + %trimr(p_ScriptMbr) + ' generated.'); *inlr = *on; return; //--------------------------------------------------------- // Load member into XML output begsr srLoadMbr; // send status message to user SrcOut = '' + ' '; exsr srWriteCode; // load F spec keywords. Asynchronously load source records // into memory for faster reads. Generate XML code. extOfile = %trimr(xfromSrcl) + '/' + xfromSrcf; open MBRSRC; SrclenD = InfdsRecLen; SrcCcsidD = InfdsCcsid; // member attributes SrcOut = ''; exsr srWriteCode; SrcOut = ''; exsr srWriteCode; // load member data into text file. SrcOut = '' + ' '; exsr srWriteCode; SrcOut = ''; exsr srWriteCode; // generate standard object creation code // if flag is set to '*YES' 1b if xgencrt = '*YES'; 2b if xMbratr = 'CMD '; exsr srCrtCmd; 2x else; SrcOut = '' + ' ' + ' '; exsr srWriteCode; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Command data was loaded into single String. Break commands // into 100 byte chunks and write to XML. begsr srLoadExc; SrcOut = '' + ' 0; %subst(String: cc: 6) = '&tolib'; cc = %scan('&TOLIB': String: cc + 1); 1e enddo; bb = %len(String); aa = (%scan('XCMD(': String) + 5); // see if one line command 1b if bb - aa < 101; SrcOut = %subst(String: aa: (bb - aa) + 1); exsr srWriteCode; 1x else; // multiline command 2b dou aa > bb; SrcOut = %subst(String: aa); exsr srWriteCode; aa += 100; 2e enddo; 1e endif; // close brackets SrcOut = bc+bc+'> '; exsr srWriteCode; endsr; //--------------------------------------------------------- // extract values from mbr script command // xMbr s 10 member name // xMbratr s 10 source mbr attr // xfromSrcf s 10 copy from Src file // xfromSrcl s 10 copy from Src lib // xtoSrcf s 10 copy to Src file // xobjtype s 7 object type // xgencrt s 4 gen compile code //--------------------------------------------------------- begsr srParseMbrVal; aa = %scan('XMBR(': String); cc = %scan(')': String: aa + 5); xMbr = %subst(String: aa + 5: cc - (aa + 5)); aa = %scan('XMBRATR(': String: cc + 1); cc = %scan(')': String: aa + 8); xMbratr = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XFROMSRCF(': String: cc + 1); cc = %scan(')': String: aa + 10); xfromSrcf = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XFROMSRCL(': String: cc + 1); cc = %scan(')': String: aa + 10); xfromSrcl = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XTOSRCF(': String: cc + 1); cc = %scan(')': String: aa + 8); xtoSrcf = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XOBJTYPE(': String: cc + 1); cc = %scan(')': String: aa + 9); xobjtype = %subst(String: aa + 9: cc - (aa + 9)); aa = %scan('XGENCRT(': String: cc + 1); cc = %scan(')': String: aa + 8); xgencrt = %subst(String: aa + 8: cc - (aa + 8)); endsr; //--------------------------------------------------------- // read input file to load all parts of script command into // single string for processing. // Drop plus + sign and assume String completed when // current line does not terminate in + sign. begsr srLoadString; clear String; IsAllLoaded = *off; 1b dou IsAllLoaded; cc = %checkr(' ': xScriptSrc); 2b if %subst(xScriptSrc: cc: 1) >' '; 3b if %subst(xScriptSrc: cc: 1) ='+'; %subst(xScriptSrc: cc: 1) =' '; 3x else; IsAllLoaded = *on; 3e endif; 2e endif; String += %trim(xScriptSrc) + ' '; 2b if not IsAllLoaded; read SCRIPT; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- // Extract command definition begsr srCrtCmd; String = f_CrtCmdString(xMbr + xfromSrcl); String = ' XCMD(' + string; // remove question marks used by command recreate utility cc = %scan('?': String); 1b dow cc > 0; String = %replace('': String: cc: 1); cc = %scan('?': String: cc); 1e enddo; // replace source file with value from 'To Source' a17 = '&tolib/' + xtoSrcf; cc = %scan('SRCFILE(': String); aa = %scan(')': String: cc); String = %replace(a17: String: cc+8: aa-(cc+8)); //--------------------------------------------------------- // load '&tolib' everywhere *LIBL is not specified // look for qualifier / then back up to first open parenth ( //--------------------------------------------------------- cc = %scan('/': String); 1b dow cc > 0; 2b for aa = cc -1 downto cc-10; 3b if %subst(string:aa:1) = '('; 4b if %subst( String: aa+1: cc-(aa+1)) <> '*LIBL '; String = %replace('&tolib': String: aa+1: cc-(aa+1)); 4e endif; 2v leave; 3e endif; 2e endfor; cc = %scan(')': String: aa); // get past compressed section cc = %scan('/': String: cc); 1e enddo; string += ' '; exsr srLoadExc; endsr; //--------------------------------------------------------- begsr srWriteCode; SeqNum += .01; except WriteCode; clear SrcOut; endsr; /end-free OXmlOutfileeadd WriteCode O SeqNum 6 O SeqDate 12 O SrcOut 112 OXmlOutfilee UpdateXML O XmlDta 112 //--------------------------------------------------------- // get member description then xlate out invalid characters P f_GetMbrText B D f_GetMbrText PI 50a D p_SrcFile 20a const D p_SrcMbr 10a /free QusrmbrdDS = f_Qusrmbrd(p_SrcFile: p_SrcMbr: 'MBRD0100'); return %xlate(qd + qs + '<&%':' ': QusrmbrdDS.Text); /end-free Pf_GetMbrText E //--------------------------------------------------------- ** install_instructions //--------------------------------------------------------- * 1. Upload entire XML txt to source file 112 long, into any mbr * name not in this XML (suggest member name like ABCX or XYZX). Source * file must be in library where source and objects are to be installed. * * 2. Extract XML parser program (If XMLPREVIEW installed, skip to step 3.) * Copy text between start tag and end * tag into any member name (your choice) * in file QRPGLESRC member type RPGLE. CRTBNDRPG to compile. * Example copy command (if you named member A in step 1) * CPYF FROMFILE(mylib/JCRCMDS) TOFILE(mylib/JCRCMDS) FROMMBR(a) + * TOMBR(parser) MBROPT(*REPLACE) FROMRCD(378) TORCD(704) * * 3. Call install program (or execute XMLPREVIEW) passing 3 Parms. * 'your-member-name you uploaded this text into' * 'your-source-file-name member is in' * 'your-library-name source file is in' * * Various source members will be extracted and objects required * for application will be created in your-library-name. * * Members in this install: (to view or manually extract members, scan 0; //error occurred 2b if ApiErrDS.ErrMsgId = 'CPF9810'; //lib not found Msgtxt = '0000 Library ' + %trimr(p_UploadSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; //src file not found Msgtxt = '0000 Source file ' + %trimr(p_UploadSrcFil) + ' was not found in ' + %trimr(p_UploadSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; //member not found Msgtxt = '0000 Member ' + %trimr(p_UploadMbr) + ' was not found in ' + %trimr(p_UploadSrcLib) + '/' + %trimr(p_UploadSrcFil); 2x else; Msgtxt = '0000 Unexpected message ' + ApiErrDS.ErrMsgId + ' received. '; 2e endif; // send message Msgid = 'CPD0006'; Msgtyp = '*DIAG'; Msgq = '*CTLBDY'; exsr srSndMessage; Msgtxt = *blanks; Msgid = 'CPF0002'; Msgtyp = '*ESCAPE'; exsr srSndMessage; *inlr = *on; return; 1e endif; //--------------------------------------------------------- // Set user selected library *first for remainder of program bldexc = 'RMVLIBLE LIB(' + %trimr(p_UploadSrcLib) + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDLIBLE LIB(' + %trimr(p_UploadSrcLib) + ') POSITION(*FIRST)'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); // Override Input file to uploaded text file extIfile = %trimr(p_UploadSrcLib) + '/' + p_UploadSrcFil; open xmlinput; read xmlinput; 1b dow not %eof; // write records to outfile if flag is on 2b if IsWrite; 3b if xmltag2 <> ''; srcSeqno += .01; // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. 4b if %parms = 4; UpSlash = %xlate(lo: up: SlashCopy); 5b if UpSlash = '/COPY' or UpSlash = '/INCL'; Start = 12; 6b if UpSlash = '/INCL'; Start = 15; 6e endif; aa = %scan(',': xmlcode: Start); //find start of member 6b if aa = 0; aa = %check(' ': xmlcode: Start) - 1; 6e endif; xmlcode = %subst(xmlcode: 1: Start) + %trimr(p_UploadSrcLib) + '/' + %trimr(p_OvrSrcFile) + ',' + %subst(xmlcode: (aa + 1)); 5e endif; 4e endif; except write_one; 3x else; IsWrite = *off; close MBRSRC; 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 = p_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 = 'srcccsid='; srcccsid = %subst(xmlcode: 13: 5); // Start of data to copy. Create source files/mbrs as required. 2x elseif xmltag1 = ''; bldexc = 'CRTSRCPF FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') RCDLEN(' + srclen + ') CCSID(' + srcccsid + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') SRCTYPE(' + %trimr(mbrtype) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); 3b if %error; bldexc = 'CHGPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'CLRPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); 3e endif; // override to outfile mbr extOfile = %trimr(p_UploadSrcLib) + '/' + srcfile; clear srcSeqno; open MBRSRC; IsWrite = *on; //--------------------------------------------------------- // Compile statement. Read next record and execute it. // Subroutine srTolibToken will replace &tolib with // library user has selected at run time. 2x elseif xmltag1 = ''; 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 = ''; clear bldexc; aa = 1; read xmlinput; 3b dow xmltag2 <> ''; %subst(bldexc: aa: 100) = xmlcode; 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 // read record and get single line of message text. 2x elseif xmltag1 = ' 0; bldexc = %replace(%trimr(p_UploadSrcLib): 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; bb = %scan(')': bldexc: aa); bldexc = %replace(%trimr(p_OvrSrcFile): bldexc: aa + 1: bb-(aa + 1)); 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srSndMessage; callp QMHSNDPM( Msgid: 'QCPFMSG *LIBL ': Msgtxt: %size(Msgtxt): Msgtyp: Msgq: 1: ' ': ApiErrDS); endsr; /end-free OMBRSRC e write_one O srcSeqno 6 O 12 '000000' O xmlcode 112 * /// END OF INSTALL PGM HERE /// do not copy past this point ********** /// ]]> 0; //error occurred 2b if ApiErrDS.ErrMsgId = 'CPF9810'; //lib not found Msgtxt = '0000 Library ' + %trimr(p_UploadSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; //src file not found Msgtxt = '0000 Source file ' + %trimr(p_UploadSrcFil) + ' was not found in ' + %trimr(p_UploadSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; //member not found Msgtxt = '0000 Member ' + %trimr(p_UploadMbr) + ' was not found in ' + %trimr(p_UploadSrcLib) + '/' + %trimr(p_UploadSrcFil); 2x else; Msgtxt = '0000 Unexpected message ' + ApiErrDS.ErrMsgId + ' received. '; 2e endif; // send message Msgid = 'CPD0006'; Msgtyp = '*DIAG'; Msgq = '*CTLBDY'; exsr srSndMessage; Msgtxt = *blanks; Msgid = 'CPF0002'; Msgtyp = '*ESCAPE'; exsr srSndMessage; *inlr = *on; return; 1e endif; //--------------------------------------------------------- // Set user selected library *first for remainder of program bldexc = 'RMVLIBLE LIB(' + %trimr(p_UploadSrcLib) + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDLIBLE LIB(' + %trimr(p_UploadSrcLib) + ') POSITION(*FIRST)'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); // Override Input file to uploaded text file extIfile = %trimr(p_UploadSrcLib) + '/' + p_UploadSrcFil; open xmlinput; read xmlinput; 1b dow not %eof; // write records to outfile if flag is on 2b if IsWrite; 3b if xmltag2 <> ''; srcSeqno += .01; // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. 4b if %parms = 4; UpSlash = %xlate(lo: up: SlashCopy); 5b if UpSlash = '/COPY' or UpSlash = '/INCL'; Start = 12; 6b if UpSlash = '/INCL'; Start = 15; 6e endif; aa = %scan(',': xmlcode: Start); //find start of member 6b if aa = 0; aa = %check(' ': xmlcode: Start) - 1; 6e endif; xmlcode = %subst(xmlcode: 1: Start) + %trimr(p_UploadSrcLib) + '/' + %trimr(p_OvrSrcFile) + ',' + %subst(xmlcode: (aa + 1)); 5e endif; 4e endif; except write_one; 3x else; IsWrite = *off; close MBRSRC; 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 = p_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 = 'srcccsid='; srcccsid = %subst(xmlcode: 13: 5); // Start of data to copy. Create source files/mbrs as required. 2x elseif xmltag1 = ''; bldexc = 'CRTSRCPF FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') RCDLEN(' + srclen + ') CCSID(' + srcccsid + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'ADDPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') SRCTYPE(' + %trimr(mbrtype) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp(e) QCMDEXC(bldexc: %len(%trimr(bldexc))); 3b if %error; bldexc = 'CHGPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ') TEXT(' + qs + %trimr(mbrtext) + qs + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); bldexc = 'CLRPFM FILE(' + %trimr(p_UploadSrcLib) + '/' + %trimr(srcfile) + ') MBR(' + %trimr(mbrname) + ')'; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); 3e endif; // override to outfile mbr extOfile = %trimr(p_UploadSrcLib) + '/' + srcfile; clear srcSeqno; open MBRSRC; IsWrite = *on; //--------------------------------------------------------- // Compile statement. Read next record and execute it. // Subroutine srTolibToken will replace &tolib with // library user has selected at run time. 2x elseif xmltag1 = ''; 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 = ''; clear bldexc; aa = 1; read xmlinput; 3b dow xmltag2 <> ''; %subst(bldexc: aa: 100) = xmlcode; 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 // read record and get single line of message text. 2x elseif xmltag1 = ' 0; bldexc = %replace(%trimr(p_UploadSrcLib): 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; bb = %scan(')': bldexc: aa); bldexc = %replace(%trimr(p_OvrSrcFile): bldexc: aa + 1: bb-(aa + 1)); 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srSndMessage; callp QMHSNDPM( Msgid: 'QCPFMSG *LIBL ': Msgtxt: %size(Msgtxt): Msgtyp: Msgq: 1: ' ': ApiErrDS); endsr; /end-free OMBRSRC e write_one O srcSeqno 6 O 12 '000000' O xmlcode 112 * /// END OF INSTALL PGM HERE /// do not copy past this point ********** /// ]]> v5r4 //--------------------------------------------------------- // XMLGENRV - Validity checking program for selected script // Verify TO lib and source file exist. // Verify script member exists in selected library // Verify all source members in script member exist in selected source file. // Verify all QCMDEXC statements are valid. // create/clear outfile member //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FSCRIPT if f 92 disk extfile(extIfile) extmbr(p_ScriptMbr) F usropn //--*COPY DEFINES------------------------------------------ /Define Qcmdchk /Define f_CheckMbr /Define f_CheckObj /Define f_GetQual /Define f_OutFileAddPfm /COPY JCRCMDS,JCRCMDSCPY //--*STAND ALONE------------------------------------------- D aa s 5u 0 D cc s 5u 0 D bldexc s 500a D String s 500a varying D IsAllLoaded s n // values extracted from mbr script command D xMbr s 10a member name D xMbratr s 10a source mbr attr D xfromSrcf s 10a copy from Src file D xfromSrcl s 10a copy from Src lib D xtoSrcf s 10a copy to Src file D xobjtype s 7a object type D xgencrt s 4a gen compile code? //--*ENTRY PARMS------------------------------------------- D p_xmlgenrv PR extpgm('XMLGENRV') D 10a const D 20a const D 20a const D p_xmlgenrv PI D p_ScriptMbr 10a const D p_ScriptQual 20a const D p_OutFileQual 20a const //--*INPUT SPECS------------------------------------------- Iscript ns I a 13 92 xScriptSrc //--------------------------------------------------------- /free // Verify script member, source file and library exists. f_CheckMbr(p_ScriptQual: p_ScriptMbr); // Verify target source file and library exists. f_CheckObj(p_OutFileQual : '*FILE '); // add outfile member; f_OutFileAddPfm( p_OutFileQual: p_ScriptMbr: 'XML ': 'XML data for group ' + p_ScriptMbr); // Override file to script member. extIfile = f_GetQual(p_ScriptQual); open script; // read through member loading source record to outfile read script; 1b dow not %eof; //--------------------------------------------------------- // Spin through driver file and load data from tags as they occur. // XMLGENMBR XMBR(XMLGEN) XMBRATR(CLP) XFROMSRCF(JCLSRC) + // XFROMSRCL(JCRCMDS) XTOSRCF(QCLSRC) + // XOBJTYPE(*PGM) XGENCRT(*YES) // XMLGENCMD XCMD(CRTDTAARA DTAARA(&TOLIB/TEST) + // TYPE(*CHAR) LEN(10) VALUE(A)) aa = %scan('XMLGENMBR': xScriptSrc); 2b if aa > 0; exsr srLoadString; //--------------------------------------------------------- // extract values from mbr script command // xMbr s 10 member name // xMbratr s 10 source mbr attr // xfromSrcf s 10 copy from Src file // xfromSrcl s 10 copy from Src lib // xtoSrcf s 10 copy to Src file // xobjtype s 7 object type // xgencrt s 4 gen compile code aa = %scan('XMBR(': String); cc = %scan(')': String: aa + 5); xMbr = %subst(String: aa + 5: cc - (aa + 5)); aa = %scan('XMBRATR(': String: cc + 1); cc = %scan(')': String: aa + 8); xMbratr = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XFROMSRCF(': String: cc + 1); cc = %scan(')': String: aa + 10); xfromSrcf = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XFROMSRCL(': String: cc + 1); cc = %scan(')': String: aa + 10); xfromSrcl = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XTOSRCF(': String: cc + 1); cc = %scan(')': String: aa + 8); xtoSrcf = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XOBJTYPE(': String: cc + 1); cc = %scan(')': String: aa + 9); xobjtype = %subst(String: aa + 9: cc - (aa + 9)); aa = %scan('XGENCRT(': String: cc + 1); cc = %scan(')': String: aa + 8); xgencrt = %subst(String: aa + 8: cc - (aa + 8)); f_CheckMbr(xfromSrcf + xfromSrcl: xMbr); 2x else; aa = %scan('XMLGENCMD': xScriptSrc); 3b if aa > 0; exsr srLoadString; //--------------------------------------------------------- // extract command from string, check with qcmdchk API // Replace &TOLIB (no matter how many times it is in String) // with lib QUSRSYS just to pass cmdchk. %len(String) = %len(String) - 2; //drop last ) cc = %scan('&TOLIB': String); 4b dow cc > 0; String = %replace('QUSRSYS': String: cc: 6); cc = %scan('&TOLIB': String: cc + 1); 4e enddo; aa = %scan('XCMD(': String); bldexc = %subst(String: aa + 5); callp QCMDCHK(bldexc: %len(%trimr(bldexc))); 3e endif; 2e endif; read script; 1e enddo; close script; *inlr = *on; return; //--------------------------------------------------------- // read input file to load all parts of script command into // single String for processing. // Drop plus + sign and assume String completed when // current line does not terminate in + sign. begsr srLoadString; clear String; IsAllLoaded = *off; 1b dou IsAllLoaded; cc = %checkr(' ': xScriptSrc); 2b if %subst(xScriptSrc: cc: 1) >' '; 3b if %subst(xScriptSrc: cc: 1) = '+'; %subst(xScriptSrc: cc: 1) = ' '; 3x else; IsAllLoaded = *on; 3e endif; 2e endif; String = String + %trim(xScriptSrc) + ' '; 2b if not IsAllLoaded; read Script; 2e endif; 1e enddo; endsr; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLPREVIEC- Preview uploaded XML install members */ /*--------------------------------------------------------------------------*/ PGM PARM(&XMLMBR &XMLSFL &USRSRCF) DCL &XMLMBR *CHAR 10 /* UPLOADED MEMBER NAME */ DCL &XMLSFL *CHAR 20 /* XML SOURCE FILE LIB */ DCL &USRSRCF *CHAR 10 /* USER SELECTED OUTPUT SRCF */ DCL &XMLSFIL *CHAR 10 DCL &XMLSLIB *CHAR 10 DCL &XMLINSTAL *CHAR 1 CHGVAR VAR(&XMLSFIL) VALUE(%SST(&XMLSFL 1 10)) CHGVAR VAR(&XMLSLIB) VALUE(%SST(&XMLSFL 11 10)) IF COND(&XMLSLIB = '*LIBL ') THEN(DO) RTVOBJD OBJ(&XMLSFIL) OBJTYPE(*FILE) RTNLIB(&XMLSLIB) MONMSG MSGID(CPF0000) ENDDO OVRDBF FILE(XMLINPUT) TOFILE(&XMLSLIB/&XMLSFIL) + MBR(&XMLMBR) OVRSCOPE(*JOB) CALL PGM(XMLPREVIER) PARM(&XMLMBR &XMLSFIL &XMLSLIB &USRSRCF &XMLINSTAL) /*-----------------------------------------------------------------------*/ /* if user has selected to run install. */ /* Create source file in qtemp */ /* Call RPG program to read and extract installer code */ /* compile and run installer code */ /*-----------------------------------------------------------------------*/ IF (&XMLINSTAL = 'Y') DO CRTSRCPF FILE(QTEMP/XMLEXTRACT) RCDLEN(112) MONMSG CPF0000 ADDPFM FILE(QTEMP/XMLEXTRACT) MBR(XMLEXTRACT) MONMSG MSGID(CPF0000) EXEC(CLRPFM FILE(QTEMP/XMLEXTRACT) MBR(XMLEXTRACT)) OVRDBF FILE(XMLEXTRACT) TOFILE(QTEMP/XMLEXTRACT) + MBR(XMLEXTRACT) OVRSCOPE(*JOB) CALL XMLPREVINR /* LOAD INSTALLER CODE */ CRTBNDRPG PGM(QTEMP/XMLEXTRACT) SRCFILE(QTEMP/XMLEXTRACT) + DBGVIEW(*SOURCE) OUTPUT(*NONE) TGTRLS(*CURRENT) DLTOVR FILE(XMLEXTRACT) LVL(*JOB) /*-----------------------------------------------------------------------*/ /* Many users do not use IBM default source file names, instead they */ /* prefer to have all different source member type in one file. */ /* */ /* if user has selected to use *DEFAULTS source files for output, */ /* (Note: *DEFAULTS means to use source files in the upload */ /* then call installer program passing only first 3 parms. */ /* */ /* If user has selected single target source file, then call installer */ /* program passing all 4 parms. */ /*-----------------------------------------------------------------------*/ IF COND(&USRSRCF *EQ '*DEFAULTS ') THEN(CALL + PGM(QTEMP/XMLEXTRACT) PARM(&XMLMBR &XMLSFIL &XMLSLIB)) IF COND(&USRSRCF *NE '*DEFAULTS ') THEN(CALL + PGM(QTEMP/XMLEXTRACT) PARM(&XMLMBR &XMLSFIL &XMLSLIB &USRSRCF)) ENDDO ENDPGM ]]> v5r4 *---------------------------------------------------------------- * XMLPREVIED - Preview uploaded XML install members - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 CA10 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A XDATA 77A O 5 2 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(17) SFLSIZ(51) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A 1 2'XMLPREVIEW' COLOR(BLU) A 1 23'Preview XML Upload before Install' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 35A O 2 7 A 2 72SYSNAME COLOR(BLU) A 4 2'Seq' DSPATR(UL) COLOR(BLU) A 4 6'Cmd' DSPATR(UL) COLOR(BLU) A 4 10'MbrName' DSPATR(UL) COLOR(BLU) A 4 21'MbrAttr' DSPATR(UL) COLOR(BLU) A 4 32'TargetSrc' DSPATR(UL) COLOR(BLU) A 4 44'Text ' A DSPATR(UL) COLOR(BLU) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A AINSTALL 1A P A 23 2'F3=Exit No Install' COLOR(BLU) A 23 30'F10=Run Install' DSPATR(&AINSTALL) A 23 69'F12=Cancel No Install' COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(24) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(01) SFLSIZ(02) A PROGID SFLPGMQ(10) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='XMLPREVIEW'.Preview XML Upload Members (XMLPREVIEW) - Help .*-------------------------------------------------------------------- :P.This JCR command reads uploaded XML source member, listing members and commands to be executed, into subfile for review.:EHELP. .*-------------------------------------------------------------------- :HELP name='XMLPREVIEW/UPLOADMBR'.Uploaded member name - Help :XH3.Uploaded member name (UPLOADMBR) :P.Member name of a uploaded member containing source and object information about to be installed.:EHELP. :HELP name='XMLPREVIEW/UPLOADSRCF'.Uploaded into source file - Help :XH3.Uploaded into source file (UPLOADSRCF) :P.Source file where upload member was placed.:EHELP. :HELP name='XMLPREVIEW/OUTPUTSRCF'.Output to this source file - Help :XH3.Output to this source file (OUTPUTSRCF) :P.Optionally specifies source file where ALL members will be extracted. This option is available to persons who want install all source members into a single selected source file. This option can only be used if uploaded file has different names for all members. :PARML.:PT.:PK def.*DEFAULTS:EPK. :PD.The default source files, defined in uploaded member, will be used. :PT.source-file-name :PD.Enter source file name to contain extracted source members. Source file does not have to exists as it will be created. To use this option you must verfiy the uploaded text has no duplicate member names. :EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // XMLPREVIER - Preview uploaded XML install members // It is recommended you run this program over any // uploaded XMLGEN generated source before you commit to install. // This subfile program will list // 1. source members to be installed. // 2. source files that may be created. // 3. any commands that will be executed during installation. // It is your responsibility to verify these operations are proper for your environment. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FXMLINPUT if f 112 disk FXMLPREVIEDcf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) //--*STAND ALONE------------------------------------------- D String s 500a varying D SequenceNum s 3p 0 D IsEnableInst s n //--*COPY DEFINES------------------------------------------ /Define FunctionKeys /Define Infds /Define Dspatr /Define Ind /Define Sds /Define Constants /Define f_GetDayName /Define f_BuildString /Define f_RmvSflMsg /Define f_SndSflMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_xmlprevier PR extpgm('XMLPREVIER') D 10a const D 10a const D 10a const D 10a const D 1a D p_xmlprevier PI D p_SrcMbr 10a const D p_SrcFil 10a const D p_SrcLib 10a const D p_UsrsFil 10a const D p_Install 1a //--*INPUT SPECS------------------------------------------- Ixmlinput ns I a 13 21 xmltag1 I a 13 29 xmlinstallpgm I a 18 27 xmltag2 I a 13 112 xmlcode //--------------------------------------------------------- /free aInstall = ND; p_Install = 'N'; f_RmvSflMsg(ProgId); evalr scDow = %trimr(f_GetDayName()); scObjHead = f_BuildString('& & &': P_SrcMbr: p_SrcFil: p_SrcLib); read xmlinput; 1b dow not %eof; // determine if install_program source is included in text 2b if xmlinstallpgm = ''; IsEnableInst = *on; //enable install aInstall = White; // Extract values based on XML tags and load to subfile record(s) 2x elseif xmltag1 = 'mbrname ='; SequenceNum += 1; xdata = %trimr(%editc(SequenceNum:'4')); %subst(xdata: 5: 3) = 'mbr'; %subst(xdata: 9: 10) = %subst(xmlcode: 13: 10); 2x elseif xmltag1 = 'mbrtype ='; %subst(xdata: 20: 10) = %subst(xmlcode: 13: 10); 2x elseif xmltag1 = 'mbrtext ='; %subst(xdata: 43) = %subst(xmlcode: 13: 50); 2x elseif xmltag1 = 'srcfile ='; 3b if p_UsrsFil = '*DEFAULTS '; %subst(xdata: 31: 10) = %subst(xmlcode: 13: 10); 3x else; %subst(xdata: 31: 10) = p_UsrsFil; 3e endif; 2x elseif xmltag1 = 'srcccsid=' or xmltag1 = 'srccssid='; rrn += 1; write SBFDTA1; //--------------------------------------------------------- // qcmdexc statement. Build statement from record between start // and stop tags. When stop tag, process into subfile records 2x elseif xmltag1 = ''; clear String; aa = 1; read xmlinput; 3b dow xmltag2 <> ''; %len(String) += 100; %subst(String: aa: 100) = xmlcode; aa += 100; read xmlinput; 3e enddo; //--------------------------------------------------------- // Replace &tolib (no matter how many times in String) // with whatever library user has selected at run time. // Must replace create-from source files if user has selected override. aa = %scan('&tolib': String); 3b dow aa > 0; String = %replace(%trimr(p_SrcLib): String: aa: 6); aa = %scan('&tolib': String); 3e enddo; 3b if p_UsrsFil<>'*DEFAULTS '; aa = %scan('SRCFILE(': String); 4b if aa > 0; aa = %scan('/': String: aa); 5b if aa > 0; bb = %scan(')': String: aa); String = %replace(%trimr(p_UsrsFil): String: aa + 1: bb-(aa + 1)); 5e endif; 4e endif; 3e endif; // parse out commands and write to subfile. clear xdata; rrn += 1; write SBFDTA1; SequenceNum += 1; xdata = %trimr(%editc(SequenceNum:'4')); %subst(xdata: 5: 3) = 'cmd'; aa = 1; bb = %len(String); // see if one line command 3b if bb - aa < 69; %subst(xdata: 9) = %subst(String: aa: (bb - aa) + 1); rrn += 1; write SBFDTA1; 3x else; // multiline command 4b dou aa > bb; %subst(xdata: 9) = %subst(String: aa); rrn += 1; write SBFDTA1; clear xdata; aa += 69; 4e enddo; 3e endif; clear xdata; rrn += 1; write SBFDTA1; 2e endif; read xmlinput; 1e enddo; //--------------------------------------------------------- // Show subfile. F3/F12 = Exit F10=Run Install Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b if rrn = 0; f_SndSflMsg(ProgId: 'No XMLGEN tags found in source member.'); 1x elseif not IsEnableInst; f_SndSflMsg(ProgId: 'Install Program not included in XML.'); 1e endif; write MSGCTL; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); // send parm back to CL to run installer 1b if InfdsFkey = f10 and IsEnableInst; p_Install = 'Y'; 1e endif; *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLPREVIEW - Preview uploaded XML install members - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Preview XML Upload Members') PARM KWD(UPLOADMBR) TYPE(*NAME) LEN(10) MIN(1) PROMPT('Uploaded member name') PARM KWD(UPLOADSRCF) TYPE(UPLOADSRCF) MIN(1) PROMPT('Upload source file') UPLOADSRCF: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTPUTSRCF) TYPE(*NAME) LEN(10) + DFT(*DEFAULTS) SPCVAL((*DEFAULTS + '*DEFAULTS ')) MIN(0) PROMPT('Output to this source file') ]]> v5r4 //--------------------------------------------------------- // XMLPREVINR - extract embedded installer code from text. // read XML input member. use tags in text to extract installer source. //--------------------------------------------------------- H DFTACTGRP(*NO) ACTGRP(*CALLER) /IF DEFINED(*V6R1M0) H OPTION(*NOUNREF: *NODEBUGIO) /ELSE H OPTION(*NODEBUGIO) /ENDIF FXMLINPUT if f 112 disk uploaded text FXMLEXTRACTo f 112 disk parsed out //--*STAND ALONE------------------------------------------- D IsWrite s n D SrcSeqno s 6s 2 //--*INPUT SPECS------------------------------------------- Ixmlinput ns I a 13 29 xmltag1 I a 18 35 xmltag2 I a 13 112 xmlcode //--------------------------------------------------------- /free read xmlinput; 1b dow not %eof; // write records to temp installer source if flag is on 2b if IsWrite; 3b if xmltag2 = ''; *inlr = *on; return; 3e endif; SrcSeqno += .01; except write_one; // Start of data to copy. Create source files/mbrs as required. 2x elseif xmltag1 = ''; IsWrite = *on; 2e endif; read xmlinput; 1e enddo; *inlr = *on; return; /end-free Oxmlextracte write_one O SrcSeqno 6 O 12 '000000' O xmlcode 112 ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLSRCFIL - Generate XML for all members in source file - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('All mbrs to single XML mbr') PARM KWD(INSRCFIL) TYPE(INSRCFIL) MIN(1) PROMPT('Input Source File name:') INSRCFIL: QUAL TYPE(*NAME) LEN(10) MIN(1) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') PARM KWD(OUTSRCFIL) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Source file for XML out member') PARM KWD(OUTSRCLIB) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Source lib for XML out member') ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLSRCFILC - Generate XML for all members in source file */ /* Load all member names in selected source file into script */ /* NOTE: You must have XMLGEN utility installed on your system! */ /*--------------------------------------------------------------------------*/ PGM PARM(&INSFILIB &OUTSFIL &OUTSLIB) DCL VAR(&INSFILIB) TYPE(*CHAR) LEN(20) DCL VAR(&INSFIL) TYPE(*CHAR) LEN(10) DCL VAR(&INSLIB) TYPE(*CHAR) LEN(10) DCL VAR(&OUTSFIL) TYPE(*CHAR) LEN(10) DCL VAR(&OUTSLIB) TYPE(*CHAR) LEN(10) DCL VAR(&TEXT) TYPE(*CHAR) LEN(50) CHGVAR VAR(&INSFIL) VALUE(%SST(&INSFILIB 1 10)) CHGVAR VAR(&INSLIB) VALUE(%SST(&INSFILIB 11 10)) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('XML + txt generation - in progress') TOPGMQ(*EXT) MSGTYPE(*STATUS) /* Create/clear out member */ ADDPFM FILE(&OUTSLIB/&OUTSFIL) MBR(&INSFIL) MONMSG MSGID(CPF0000) EXEC(CLRPFM FILE(&OUTSLIB/&OUTSFIL) MBR(&INSFIL)) CHGVAR VAR(&TEXT) VALUE('Source members for file ' *CAT &INSFIL *TCAT '.') CHGPFM FILE(&OUTSLIB/&OUTSFIL) MBR(&INSFIL) SRCTYPE(TXT) TEXT(&TEXT) /* Create script member in qtemp */ DLTF FILE(QTEMP/XMLSRCFIL) MONMSG MSGID(CPF0000) CRTSRCPF FILE(QTEMP/XMLSRCFIL) MBR(&INSFIL) /* Generate XML */ CALL PGM(XMLSRCFILR) PARM(&INSFIL &INSLIB &OUTSFIL &OUTSLIB) DLTOVR FILE(*ALL) MONMSG MSGID(CPF0000) RMVMSG PGMQ(*PRV) CLEAR(*ALL) SNDPGMMSG MSG('Source XML for ' *CAT &INSFIL *TCAT ' + in ' *CAT &OUTSLIB *TCAT '/' *CAT &OUTSFIL *TCAT ' - completed.') ENDPGM ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='XMLSRCFIL'.All mbrs to single XML mbr (XMLSRCFIL) - Help .*-------------------------------------------------------------------- :P.This command places all members from selected source file into single validated, well-formed XML mbr with all information required to recreate your source members on another system. :P.Installing utility XMLGEN is prerequisite. :P.Also there is maximum of 999,999 records (around 100Meg) that can be written to single source member.:EHELP. .*-------------------------------------------------------------------- :HELP name='XMLSRCFIL/INSRCFIL'.Input Source file name - Help :XH3.Input Source file name (INSRCFIL) :P.Source file whose members are to loaded.:EHELP. :HELP name='XMLSRCFIL/OUTSRCFIL'.Source file for XML out member - Help :XH3.Source file for XML out member (OUTSRCFIL) :P.Source file where XML member is to be generated.:EHELP. :HELP name='XMLSRCFIL/OUTSRCLIB'.Source lib for XML out member - Help :XH3.Source lib for XML out member (OUTSRCLIB) :P.Source library containing output source file.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // XMLSRCFILR - Generate XML for all members in source file // call Quslmbr API to load selected member names into user space // unload user space into script member. // call XMLGENR to generate XML text. //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FSCRIPT o f 92 disk extfile('QTEMP/XMLSRCFIL') F extmbr(p_SrcFil) usropn //--*STAND ALONE------------------------------------------- D SrcOut s 80a D SeqNum s 6s 2 //--*COPY DEFINES------------------------------------------ /Define ApiErrDS /Define Quslmbr /Define UserSpaceHeaderDS /Define f_BuildString /Define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY //--*CALL PROTOTYPES--------------------------------------- D p_xmlgenr PR extpgm('XMLGENR') D 10a const Script source member D 20a const Script Src fil lib D 20a const Output XML fil lib //--*ENTRY PARMS------------------------------------------- D p_xmlsrcfilr PR extpgm('XMLSRCFILR') D 10a const D 10a const D 10a const D 10a const D p_xmlsrcfilr PI D p_SrcFil 10a const D p_SrcLib 10a const D p_OutFile 10a const D p_OutLib 10a const //--------------------------------------------------------- /free // load user space with list of mbr names for selected files GenericHeaderPtr = f_Quscrtus(UserSpaceName); callp QUSLMBR( UserSpaceName: 'MBRL0200': p_SrcFil + p_SrcLib: '*ALL': '0': ApiErrDS); // Process members in user space, write record to driver file. open script; SrcOut = ' XMLGENINC XINCLUDE(*YES)'; exsr srWriteCode; QuslmbrPtr = GenericHeaderPtr + GenericHeader.OffSetToList; 1b for ForCount = 1 to GenericHeader.ListEntryCount; SrcOut = f_BuildString( ' XMLGENMBR XMBR(&) XMBRATR(&) XFROMSRCF(&) + ': QuslmbrDS.MbrName: QuslmbrDS.MbrType: p_SrcFil); exsr srWriteCode; SrcOut = f_BuildString( ' XFROMSRCL(&) XTOSRCF(&) XOBJTYPE(*N) XGENCRT(*NO)': p_SrcLib: p_SrcFil); exsr srWriteCode; QuslmbrPtr += GenericHeader.ListEntrySize; 1e endfor; //--------------------------------------------------------- // Call XMLGENR to generate outfile. close script; callp p_XMLGENR(p_SrcFil: 'XMLSRCFIL QTEMP ': p_OutFile + p_OutLib); *inlr = *on; return; //--------------------------------------------------------- begsr srWriteCode; SeqNum += .01; except WriteCode; clear SrcOut; endsr; /end-free Oscript e WriteCode O SeqNum 6 O 12 '000000' O SrcOut 92 ]]> v5r4 //--------------------------------------------------------- // XMLSRCFILV - Validity checking program //--*COPY DEFINES------------------------------------------ /Define ProgramHeaderSpecs /Define f_CheckMbr /Define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_xmlsrcfilv PR extpgm('XMLSRCFILV') D 20a const D 10a const D 10a const D p_xmlsrcfilv PI D p_InSrcQual 20a const D p_OutXmlFile 10a const D p_OutXmlLib 10a const //--------------------------------------------------------- /free f_CheckMbr(p_InSrcQual : '*FIRST '); f_CheckObj(p_OutXmlFile + p_OutXmlLib : '*FILE '); *inlr = *on; return; ]]> v5r4 */ /*--------------------------------------------------------------------------*/ /* XMLSVIEW - Easy subfile view of XML scripting CL mbrs - CMD */ /*--------------------------------------------------------------------------*/ CMD PROMPT('View XML script members') PARM KWD(XMLSCRIPT) TYPE(*NAME) LEN(10) MIN(1) PROMPT('Script member name') PARM KWD(SCRIPTSRCF) TYPE(SCRIPTSRCF) MIN(0) PROMPT('Script source file') SCRIPTSRCF: QUAL TYPE(*NAME) LEN(10) DFT(QXMLGENS) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*LIBL)) PROMPT('Library:') ]]> v5r4 *---------------------------------------------------------------- * XMLSVIEWD - Easy subfile view of XML scripting CL mbrs - DSPF *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT INDARA CA03 CA12 A ENTFLDATR((*COLOR YLW) (*DSPATR UL)) A R SBFDTA1 SFL A XDATA 77A O 5 2 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(17) SFLSIZ(51) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A 1 2'XMLSVIEWR' COLOR(BLU) A 1 23'XML Script Member Viewer' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTWRD('0 / / ') COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 60A O 2 7 A 2 72SYSNAME COLOR(BLU) A 4 2'Seq' DSPATR(UL) COLOR(BLU) A 4 6'Cmd' DSPATR(UL) COLOR(BLU) A 4 10'MbrName' DSPATR(UL) COLOR(BLU) A 4 21'MbrAttr' DSPATR(UL) COLOR(BLU) A 4 32'FrmSrcFil' DSPATR(UL) COLOR(BLU) A 4 43'FrmSrcLib' DSPATR(UL) COLOR(BLU) A 4 54'TargetSrc' DSPATR(UL) COLOR(BLU) A 4 65'Objtyp' DSPATR(UL) COLOR(BLU) A 4 73'GenYN' DSPATR(UL) COLOR(BLU) *---------------------------------------------------------------- A R SFOOTER1 BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) ]]> v5r4 * .*-------------------------------------------------------------------- :PNLGRP.:HELP NAME='XMLSVIEW'.View XML Script Members (XMLSVIEW) - Help .*-------------------------------------------------------------------- :P.This JCR command provides easy review of script members you have defined for XMLGEN command. It processes the script member and loads xmlgenmbr command values into single subfile record. Xmlgencmd records are parsed into as many subfile records as required.:EHELP. .*-------------------------------------------------------------------- :HELP name='XMLSVIEW/XMLSCRIPT'.Script member name - Help :XH3.Script member name (XMLSCRIPT) :P.Member name of script member containing source and object information for this app.:EHELP. :HELP name='XMLSVIEW/SCRIPTSRCF'.Script source file - Help :XH3.Script source file (SCRIPTSRCF) :P.Source file where script for this app is stored. :PARML.:PT.:PK def.QXMLGENS:EPK.:PD.The default source file, QXMLGENS will be used. :PT.source-file-name :PD.Enter source file name for script member. :PT.:PK def.*LIBL:EPK.:PD.The system searches library list to find source file library. :PT.library-name :PD.Enter name of library where source file is located.:EPARML.:EHELP.:EPNLGRP. ]]> v5r4 //--------------------------------------------------------- // XMLSVIEWR - Easy subfile view of XML scripting CL mbrs // read script member, load values to subfile //--------------------------------------------------------- /Define ProgramHeaderSpecs /COPY JCRCMDS,JCRCMDSCPY /UnDefine ProgramHeaderSpecs FXMLSVIEWD cf e workstn sfile(SBFDTA1: rrn) infds(Infds) F indds(Ind) FSCRIPT if f 92 disk extfile(extIfile) extmbr(p_SrcMbr) F usropn //--*STAND ALONE------------------------------------------- D xInclude s 4a D String s 500a varying D SequenceNum s 3p 0 D IsAllLoaded s n //--*COPY DEFINES------------------------------------------ /Define FunctionKeys /Define Infds /Define Dspatr /Define Dspatr /Define Ind /Define Constants /Define f_BuildString /Define f_GetDayName /Define f_Qusrmbrd /Define f_GetQual /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY PARMS------------------------------------------- D p_xmlsviewr PR extpgm('XMLSVIEWR') D 10a D 20a D p_xmlsviewr PI D p_SrcMbr 10a D p_SrcFilQual 20a //--*INPUT SPECS------------------------------------------- ISCRIPT ns I a 13 92 xScriptSrc //--------------------------------------------------------- /free // Get actual source lib QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; // override input extIfile = f_GetQual(p_SrcFilQual); open SCRIPT; //--------------------------------------------------------- // Extract install include value from top of script // XMLGENINC XINCLUDE(*YES) *YES, *NO //--------------------------------------------------------- read SCRIPT; 1b dou aa > 0 or %EOF; aa = %scan('XINCLUDE(': xScriptSrc); 2b if aa > 0; cc = %scan(')': xScriptSrc: aa + 9); xinclude = %subst(xScriptSrc: aa + 9: cc - (aa + 9)); 1v leave; 2e endif; read SCRIPT; 1e enddo; //--------------------------------------------------------- // read through member loading source record to outfile read SCRIPT; 1b dow not %eof; //--------------------------------------------------------- // Spin through driver file and load data from tags as they occur. // XMLGENINC XINCLUDE(*YES) *YES, *NO // XMLGENMBR XMBR(XMLGEN) XMBRATR(CLP) XFROMSRCF(JCLSRC) + // XFROMSRCL(JCRCMDS) XTOSRCF(QCLSRC) + // XOBJTYPE(*PGM) XGENCRT(*YES) // XMLGENCMD XCMD(CRTDTAARA DTAARA(&TOLIB/TEST) + // TYPE(*CHAR) LEN(10) VALUE(A)) aa = %scan('XMLGENMBR': xScriptSrc); 2b if aa > 0; exsr srLoadString; // extract values from mbr script command xdata = %trimr(%editc(SequenceNum:'4')); %subst(xdata: 5: 3) = 'mbr'; aa = %scan('XMBR(': String); cc = %scan(')': String: aa + 5); %subst(xdata: 9: 10) = %subst(String: aa + 5: cc - (aa + 5)); aa = %scan('XMBRATR(': String: cc + 1); cc = %scan(')': String: aa + 8); %subst(xdata: 20: 10) = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XFROMSRCF(': String: cc + 1); cc = %scan(')': String: aa + 10); %subst(xdata: 31: 10) = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XFROMSRCL(': String: cc + 1); cc = %scan(')': String: aa + 10); %subst(xdata: 42: 10) = %subst(String: aa + 10: cc - (aa + 10)); aa = %scan('XTOSRCF(': String: cc + 1); cc = %scan(')': String: aa + 8); %subst(xdata: 53: 10) = %subst(String: aa + 8: cc - (aa + 8)); aa = %scan('XOBJTYPE(': String: cc + 1); cc = %scan(')': String: aa + 9); %subst(xdata: 64: 7) = %subst(String: aa + 9: cc - (aa + 9)); aa = %scan('XGENCRT(': String: cc + 1); cc = %scan(')': String: aa + 8); %subst(xdata: 72: 1) = %subst(String: aa + 9: 1); rrn += 1; write SBFDTA1; 2x else; aa = %scan('XMLGENCMD': xScriptSrc); 3b if aa > 0; exsr srLoadString; // extract command from String. clear xdata; rrn += 1; write SBFDTA1; xdata = %trimr(%editc(SequenceNum:'4')); %subst(xdata: 5: 3) = 'cmd'; %len(String) = %len(String) - 2; bb = %len(String); aa = (%scan('XCMD(': String) + 5); // see if one line command 4b if bb - aa < 69; %subst(xdata: 9) = %subst(String: aa: (bb - aa) + 1); rrn += 1; write SBFDTA1; 4x else; // multiline command 5b dou aa > bb; %subst(xdata: 9) = %subst(String: aa); rrn += 1; write SBFDTA1; clear xdata; aa += 69; 5e enddo; 4e endif; clear xdata; rrn += 1; write SBFDTA1; 3e endif; 2e endif; read SCRIPT; 1e enddo; //--------------------------------------------------------- // Show subfile evalr scDow = %trimr(f_GetDayName()); scObjHead = f_BuildString('& & & Installer: &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: xinclude); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b dow InfdsFkey <> f03; write SFOOTER1; exfmt SBFCTL1; 2b if InfdsFkey = f03 or InfdsFkey = f12; 1v leave; 2e endif; 1e enddo; *inlr = *on; return; //--------------------------------------------------------- // read input file to load all parts of script command into // single String for processing. // Drop plus + sign and assume String completed when // current line does not terminate in + sign. begsr srLoadString; SequenceNum += 1; clear String; IsAllLoaded = *off; 1b dou IsAllLoaded; cc = %checkr(' ': xScriptSrc); 2b if %subst(xScriptSrc: cc: 1) >' '; 3b if %subst(xScriptSrc: cc: 1) = '+'; %subst(xScriptSrc: cc: 1) = ' '; 3x else; IsAllLoaded = *on; 3e endif; 2e endif; String = String + %trim(xScriptSrc) + ' '; 2b if not IsAllLoaded; read Script; 2e endif; 1e enddo; endsr; ]]>