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(391) TORCD(720) * * 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 are 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'; Msgtxt = '0000 Library ' + %trimr(p_UploadSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; Msgtxt = '0000 Source file ' + %trimr(p_UploadSrcFil) + ' was not found in ' + %trimr(p_UploadSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; 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; 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 inputDS; 1b dow not %eof; 2b if IsWrite; 3b if not(xmltag2 = ''); //---------------------------------------------------- // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. //---------------------------------------------------- 4b if %parms = %parmnum(p_OvrSrcFile); UpSlash = %upper(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; SrcOut = xmlcode; SeqNum += .01; write MBRSRC mbrsrcDS; 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; SeqNum = 0; 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 inputDS; bldexc = %trimr(xmlcode); exsr srTolibToken; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); //--------------------------------------------------------- // qcmdexc statement. Build statement from 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 inputDS; 3b dow not(xmltag2 = ''); %subst(bldexc: aa: 100) = xmlcode; aa += 100; read xmlinput inputDS; 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; 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 OF INSTALL PGM HERE /// do not copy past this point *** /// ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('DSPF Screen Layout') PARM KWD(DSPF) TYPE(DSPF) MIN(1) PGM(*YES) PROMPT('DSPF Object') 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(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.Report layout with field names printed under the data positions. :P.Wrap-around fields (longer than line in DSPF) are truncated to fit on one line. :P.Numeric fields longer than 14 are edited with Z edit code due to restrictions of Float numbers.: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 or * Display the layout.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 198) A R PRTHEAD SKIPB(1) SPACEA(2) A SCOBJHEAD 99A 2 A SCSYSTEM 8A +2 A SCDOW 9A O 113 A 123DATE EDTCDE(Y) *---------------------------------------------------------------- A R PRTLINE SPACEA(1) A LAYOUT 198A 1 ]]> '); //--------------------------------------------------------- // JCRANZDR - DSPF screen layout with field names print // Pointers to pointers to pointer arrays. The Retrieve Display // File Info API (QDFRTVFD) is a complicated piece of work. (97 page API documentation) //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Constants /define BitMask /define Cvthc /define f_OvrPrtf /define f_BuildString /define f_DisplayLastSplf /define f_DltOvr /define f_Qusrobjd /define Atof /define f_GetDayName /define f_SndEscapeMsg /define f_RtvMsgAPI /define Qecedt /define QecedtAlpha /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRANZDP printer oflind(IsOverFlow) usropn; dcl-s dd uns(5); dcl-s zz uns(5); dcl-s rr uns(3); dcl-s FillChar char(3000); dcl-s FieldNam char(10); dcl-s row uns(3); dcl-s PrintRow uns(3); dcl-s col uns(3); dcl-s MaxCol uns(3); dcl-s NumberDec uns(3); dcl-s NameSpace uns(3); dcl-s pConst char(132); dcl-s ReceiverVar char(256); dcl-s ReceiverVarLen int(10); dcl-s EditMask char(256); dcl-s Alpha63 char(63); dcl-s CharParm char(256); dcl-s EditMaskLen int(10); dcl-s ZeroSuppress char(1); dcl-s ProgramLen int(10); dcl-s FldNameRowArry char(132) dim(6); dcl-s IsEdit ind; // Retrieve Display File Description dcl-pr QDFRTVFD extpgm('QDFRTVFD'); *n char(8) options(*varsize); // Receiver *n int(10) const; // Receiver Length *n char(8) const; // Api Format *n char(20) const; // Qualified File Name *n like(apierrds); end-pr; // Convert Double Float to Packed Decimal dcl-pr QXXDTOP extproc(*dclcase); *n pointer value; *n int(10) value; // digits *n int(10) value; // decimals *n float(8) value; // double end-pr; // Base File dcl-ds QDFFBASEds based(qdffbaseptr) qualified; OffsetToQDFFINFO int(5) pos(9); NumRecFmts int(5) pos(11); NumScreenSizes int(5) pos(14); end-ds; // Screen Size Table dcl-ds QDFFSCRAds based(qdffscraptr) qualified; ScreenID char(1) pos(1); end-ds; // Display Device Dependent dcl-ds QDFFINFOds based(qdffinfoptr) qualified; LengthFileHeader int(10) pos(1); OffsetToQDFWFLEI int(10) pos(5); end-ds; // Displacement to Record Format Table dcl-ds QDFARFTEds based(qdfarfteptr) qualified; RcdFmtName char(10) pos(1); OffsetToQDFFRINF int(10) pos(13); end-ds; // Record Header dcl-ds QDFFRINFds based(qdffrinfptr) qualified; LengthRecordHeader int(10) pos(1); OffsetToQDFFFITB int(10) pos(5); NumFields int(5) pos(17); OffsetToQDFFRDPD int(5) pos(29); end-ds; // Fields Indexing Table dcl-ds QDFFFITBds based(qdfffitbptr) qualified; OffsetToQDFFFINF int(10) pos(1); DisplayLength int(5) pos(7); end-ds; // Field Header dcl-ds QDFFFINFds based(qdfffinfptr) qualified; FieldAttribute char(1) pos(3); DateTimeBits char(1) pos(4); SystemUserBits char(1) pos(5); end-ds; // Named Field Header dcl-ds QDFFFNAMds based(qdfffnamptr) qualified; ProgramLen int(5) pos(5); NumberDec char(1) pos(7); DataType char(1) pos(8); NamedOffsetToQDFFFDPD int(5) pos(11); end-ds; // Constant Header dcl-ds QDFFFCONds based(qdfffconptr) qualified; ConstantOffsetToQDFFFDPD int(5) pos(3); end-ds; // Record Level Device Dependent dcl-ds QDFFRDPDds based(qdffrdpdptr) qualified; OffsetToQDFFRCTB int(10) pos(1); end-ds; // Row Column Table dcl-ds QDFFRCTBds based(qdffrctbptr) qualified; QDFFRCTEds char(2) pos(7) dim(1000); end-ds; // Where Used File dcl-ds QDFWFLEIds based(qdfwfleiptr) qualified; OffsetToQDFWRCDI int(5) pos(1); OffsetToQDFFNTBL int(10) pos(9); end-ds; // Where Used Record dcl-ds QDFWRCDIds based(qdfwrcdiptr) qualified; OffsetToQDFWFLDI int(5) pos(1); RecordLengthWhereUsed int(10) pos(5); end-ds; // Where Used Field dcl-ds QDFWFLDIds based(qdfwfldiptr) qualified; FieldLengthWhereUsed int(5) pos(1); FieldNameIndex int(10) pos(7); FieldLength int(5) pos(11); end-ds; // Field Name Table dcl-ds QDFFNTBLds based(qdffntblptr) qualified; NumberOfEntries int(10) pos(1); FieldNameArry char(10) pos(5) dim(1000); end-ds; // Device Field Dependent dcl-ds QDFFFDPDds based(qdfffdpdptr) qualified; OffsetToQDFFCOSA int(5) pos(5); end-ds; // Constant Keywords dcl-ds QDFFCOSAds based(qdffcosaptr) qualified; NumberEntries int(5) pos(1); end-ds; // Keyword Entries dcl-ds QDFFCCOAds based(qdffccoaptr) qualified; Category char(1) pos(1); OffsetToCategory int(5) pos(2); end-ds; // Keyword 24 structure dcl-ds QDFKEDTRds based(qdfkedtrptr) qualified; NumberOfKeys int(5) pos(1); end-ds; // Keyword Parameters dcl-ds QDFKEDTPds based(qdfkedtpptr) qualified; KeyWord char(1) pos(1); ZeroSuppress char(1) pos(2); LenEditMask int(5) pos(3); EditMask char(256) pos(6); end-ds; // Keyword 23 structure dcl-ds QDFKDFTds based(qdfkdftptr) qualified; NumberOfKeys int(5) pos(1); end-ds; // Keword Parameters dcl-ds QDFKDFPMds based(qdfkdfpmptr) qualified; LengthOfData int(5) pos(5); MscgonData char(4000) pos(7); end-ds; dcl-ds GetAllocSizeDS qualified; SizeReturned int(10) pos(5); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_ObjTyp char(10); p_Output char(8); end-pi; //--------------------------------------------------------- // Print headings. Load print position 'rulers' f_OvrPrtf('JCRANZDP': '*JOB': %subst(p_FileQual: 1: 10)); open JCRANZDP; scDow = f_GetDayName(); QusrObjDS = f_QUSROBJD(p_FileQual: '*FILE'); %subst(p_FileQual: 11: 10) = QusrObjDS.ReturnLib; scObjHead = f_BuildString('& File: & & &': 'JCRANZDR': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: QusrObjDS.Text); write PrtHead; IsOverFlow = *off; // load output positions ruler 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; //--------------------------------------------------------- // Receiver variable returned by this API can be larger than max rpg field size. // 'Allocate memory size and point to it' then call again so all data will fit. 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; 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.LengthFileHeader; 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 trick is to keep track of all different pointers while spinning through // 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.FieldAttribute in %list(x'06':x'07'); 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; exsr srPrintLine; PrintRow = row; 5e endif; //--------------------------------------------------------- // CONSTANTS 5b if QDFFFINFds.FieldAttribute = x'01'; FieldNam = *blanks; 6b if %bitand(bit0: QDFFFINFds.DateTimeBits) = bit0 or %bitand(bit1: QDFFFINFds.DateTimeBits) = bit1; FieldNam = 'DATE'; pConst = 'DD/DD/DD'; 6x elseif %bitand(bit2: QDFFFINFds.DateTimeBits) = bit2; FieldNam = 'TIME'; pConst = 'TT:TT:TT'; 6x elseif %bitand(bit4: QDFFFINFds.SystemUserBits) = bit4; FieldNam = 'USER'; pConst = 'UUUUUUUUUU'; 6x elseif %bitand(bit5: QDFFFINFds.SystemUserBits) = bit5; 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.FieldNameIndex > 0; FieldNam = QDFFNTBLds.FieldNameArry(QDFWFLDIds.FieldNameIndex); QDFFFDPDptr = QDFFFINFptr + QDFFFNAMds.NamedOffsetToQDFFFDPD; //--------------------------------------------------------- // if field has edit code or edit word then it will have keywords // Float numbers will only work for 14 or less length numeric, so // if field is longer than 14, give it Z edit code //--------------------------------------------------------- 7b if QDFFFNAMds.DataType in %list(x'00':x'01'); 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.FieldLengthWhereUsed; 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.RecordLengthWhereUsed; 2e endif; QDFARFTEptr += %len(QDFARFTEds); 1e endfor; exsr srPrintLine; %subst(LayOut:1:132) = *all'-'; write PrtLine; dealloc(n) QDFFBASEptr; close JCRANZDP; f_DltOvr('JCRANZDP'); f_DisplayLastSplf('JCRANZDR': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Print display line and field names begsr srPrintLine; write PrtLine; 1b for-each LayOut in FldNameRowArry; 2b if LayOut > *blanks; 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); //--------------------------------------------------------- // Get field description into decimal value to apply editing mask. // Way cool 'virtual decimal' number created by // Alpha to Float C++ function combined with Float to Packed C++ function. //--------------------------------------------------------- ReceiverVar = *blanks; ReceiverVarLen = %len(ReceiverVar); Alpha63 = *blanks; 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 spin through Keyword Category Displacement String // until category 23 is found. //--------------------------------------------------------- 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; //--------------------------------------------------------- // Convert hex to character, then character to integer. //--------------------------------------------------------- dcl-proc f_CvtHexToInt; dcl-pi *n uns(3); p_Character char(1) const; end-pi; dcl-s HexVal char(1); dcl-s Alpha2 char(2); dcl-s Integer uns(3); // Convert Character to Hex dcl-pr cvtch extproc(*dclcase); *n pointer value; // receiver pointer *n pointer value; // source pointer *n int(10) value; // receiver length end-pr; 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-proc; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('O SPEC Layout Print') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('RPG source member') 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(SHOWNAMES) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Show + except and field names') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.Reads RPGLE source O specs to provide report layout with field names printed under the data layout.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRANZO/PGM'.PGM source member name - Help :XH3.PGM source member name (PGM) :P.Source member whose 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/SHOWNAMES'.Show except and field names - Help :XH3.Show except and field names (SHOWNAMES) :P.Show print line names and field names on layout report.:EHELP. :HELP NAME='JCRANZO/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT or * Display the layout.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRANZOR - O spec layout with field names print // call program to load field names & attributes into IMPORTED array // read rpgle source code specs // load output arrays with positional field data and field names // Shares common print file with jcranzdr and jcranzpr //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define FieldsArry /define Constants /define FieldsAttrDS /define Qeccvtec /define f_Qusrmbrd /define f_BuildString /define Qecedt /define SrcDS /define f_BuildEditWord /define f_GetQual /define f_SndEscapeMsg /define f_GetDayName /define f_OvrPrtf /define f_Dltovr /define f_DisplayLastSplf /define f_IsCompileTimeArray /define p_JCRGETFLDR // *ENTRY /define p_JCRANZOR /COPY JCRCMDS,JCRCMDSCPY dcl-f RPGSRC disk(112) extfile(extifile) extmbr(p_srcmbr) usropn; dcl-f JCRANZDP printer oflind(IsOverFlow) usropn; dcl-s IsFoundOspec ind; dcl-s AllNines char(30) inz(*all'9'); dcl-s AllZeros char(30) inz(*all'0'); dcl-s DecimalPart char(9); dcl-s EditMask char(256); dcl-s FirstTime char(2) inz('XX'); dcl-s FloatDollar char(3) inz('''$'''); dcl-s StaggerNam char(198) dim(15); dcl-s IPPfield char(12); dcl-s LoadNamFlg char(14) inz('Load Name Flag'); dcl-s LookupName char(15); dcl-s ReceiverVar char(256); dcl-s WholePart char(21); dcl-s EditMaskLen int(10); dcl-s ReceiverVarLen int(10); dcl-s xa int(5); dcl-s xe int(5); dcl-s xm int(5); dcl-s DecimalPos packed(1); dcl-s v30_9Dec packed(30: 9); dcl-s oEndPosN zoned(5) based(oendptr); dcl-s ForCount uns(5); dcl-s StaggerDepth uns(3); // prevent name overlap dcl-s IntegerLength uns(5); dcl-s LastEndPos uns(5); dcl-s xb uns(5); dcl-s xd uns(3); // ) dcl-s xf uns(3); // ) dcl-s xg uns(3); // ( dcl-s xh uns(3); // ( dcl-s xi uns(5); dcl-s EndPosX uns(5); dcl-s xk uns(5); dcl-s xo uns(5); dcl-s oEndPtr pointer inz(%addr(srcds.oendpos)); dcl-s IsContinuation ind inz(*off); dcl-s BuildContin varchar(200); dcl-s PlusSignVal char(5); dcl-s DimSizeVal char(5); dcl-s PepCnt packed(3); dcl-ds v30_9DS qualified; v30_9Zoned zoned(30: 9) inz(0); end-ds; dcl-ds EditedDS qualified; EditedArry char(1) dim(40) inz; end-ds; //--------------------------------------------------------- // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFilQual: p_SrcMbr: DiagSeverity: PepCnt); 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': '*JOB': p_SrcMbr); open JCRANZDP; scDow = f_GetDayName(); scObjHead = f_BuildString('& Mbr: & & & &': 'JCRANZOR': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); write PrtHead; IsOverFlow = *off; // 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 SrcDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(SrcDS.CompileArray) or %upper(SrcDS.SpecType) = 'P'; 1v leave; 2e endif; SrcDS.oAndOr = %upper(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_ShowNames = '*YES' and StaggerDepth > 0; 6b for-each LayOut in %subarr(StaggerNam:1:StaggerDepth); 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_ShowNames = '*YES'; LayOut = *all'_'; %subst(Layout:2:74) = %xlate(' ':'_':SrcDS.Src80); 4e endif; write PrtLine; LayOut = *blanks; 3x else; IPPfield = *blanks; exsr srGetFieldAttr; exsr srFieldLoad; 3e endif; 2e endif; read RPGSRC SrcDS; 1e enddo; // all processed 1b if (not IsFoundOspec); LayOut = 'No Output Specifications found in source ********'; StaggerDepth = 0; 1e endif; write prtLine; 1b if p_ShowNames = '*YES' and StaggerDepth > 0; 2b for-each LayOut in %subarr(StaggerNam:1:StaggerDepth); write PrtLine; 2e endfor; 1e endif; close RPGSRC; close JCRANZDP; f_Dltovr('JCRANZDP'); f_DisplayLastSplf('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. // 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 having edit words or constants. // The only difference is edit words replace ' ' 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; //----------------------------------------------------------------- // 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 SrcDS; 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 = *blanks; endsr; //--------------------------------------------------------- // Formatted2 & Formatted3 business is to stagger field names if short length fields. // 9 99 9 // Fieldname 1 // Fieldname 2 // Fieldname 3 // 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 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 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 = %upper(SrcDS.oEname); //--------------------------------------------------------- // There could be an indexed array name as an output field. // 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: FieldsArry(*).Name: 1: FieldsArryCnt); 2b if xa > 0; FieldsAttrDS = FieldsArry(xa).Attr; 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. // Dummy up field length, // build an edit word based on type field // and type formatting. //--------------------------------------------------------- 3x elseif FieldsAttrDS.DataType = 'D' or FieldsAttrDS.DataType = 'T' or FieldsAttrDS.DataType = 'Z'; IPPfield = 'Num EditWord'; SrcDS.oConstant = f_BuildEditWord(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. Zeros and nines are loaded. // End result for 9,2 field is 000000000000009999999 // 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); //--------------------------------------------------------- // Number of decimal places loads up left side // of field with 9's and fill out remainder with zeros. // End result for 9,2 field is 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 = %upper(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 // If using leading 0 suppress in front of // constant, then must make field length parm 1 // bigger than actual value of field. //--------------------------------------------------------- ReceiverVar = *blanks; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec: '*PACKED': 30: EditMask: EditMaskLen: ' ': ApiErrDS); //--------------------------------------------------------- // If API cannot apply user defined edit codes, it returns blank. // 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; ]]> '); //--------------------------------------------------------- // JCRANZOV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define Constants /define f_IsValidSrcType /define f_SndEscapeMsg /define p_JCRGETFILR // *ENTRY /define p_JCRANZOR /COPY JCRCMDS,JCRCMDSCPY dcl-s string varchar(512); dcl-s IsPrinter ind inz(*off); //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_SrcFilQual: p_SrcMbr:'RPGLE': 'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_SrcMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; // retrieve the f specs then check for printer specs in the array callp p_JCRGETFILR( p_SrcMbr: p_SrcFilQual: FileCount: OnePerRcdFmt: FspecArry: CommentArry: PrNameArry: DeleteArry); //--------------------------------------------------------- 1b for aa = FileCount downto 1; // printer spec usually last string = %trimr(FspecArry(aa)); string = %upper(string); 2b if %subst(string:16:1)= 'F' and %subst(string:30:4) = 'PRIN'; IsPrinter = *on; 1v leave; 2e endif; bb = %scan('PRINTER(': string); 2b if bb>0 and %subst(string: bb+8: 1) <> '*'; //skip (*EXT) IsPrinter = *on; 1v leave; 2e endif; 1e endfor; //--------------------------------------------------------- 1b if (not IsPrinter); f_SndEscapeMsg('Member ' + %trimr(p_SrcMbr) + ' does not have internal PRINTER specification.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('PRTF Layout Print') PARM KWD(PRTF) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('PRTF source member') 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(SHOWNAMES) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Show + rcdfmts and field names') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &FILEQUAL &SHOWNAMES &OUTPUT) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&FILEQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&FILE) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&FILEQUAL 1) DCL VAR(&LIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&FILEQUAL 11) DCL VAR(&SHOWNAMES) TYPE(*CHAR) LEN(4) DCL VAR(&TEXT) TYPE(*CHAR) LEN(50) DCL VAR(&OUTPUT) TYPE(*CHAR) LEN(8) 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 */ CRTPRTF FILE(QTEMP/&FILE) SRCFILE(&LIB/&FILE) + SRCMBR(&MBR) DEVTYPE(*AFPDS) 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 ENDDO /*-------------------------------------------------*/ 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 + &SHOWNAMES &OUTPUT) DLTF FILE(QTEMP/&FILE) ENDPGM ]]> .*-------------------------------------------------------------------- :P.Report layout with field names printed under the field positions from PRTF source. :NT.You must have all print file referenced files in library list to execute command.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRANZP/PRTF'.PRTF source member name - Help :XH3.PRTF source member name (PRTF) :P.PRTF whose 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/SHOWNAMES'.Show rcdfmts and field names - Help :XH3.Show rcdfmts and field names (SHOWNAMES) :P.Show record format names and field names on generated report.:EHELP. :HELP NAME='JCRANZP/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT or * Display the print file layout.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRANZPR - PRTF Field Layout Print // read dds extended source code listing. // extract source information from spooled file. // load output arrays with positional field data and field names. // // Shares common print file with jcranzdr. //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Constants /define f_RtvMsgApi /define FieldsAttrDS /define Qeccvtec /define Qecedt /define f_GetDayName /define f_BuildString /define f_BuildEditWord /define f_OvrPrtf /define f_DltOvr /define f_DisplayLastSplf /COPY JCRCMDS,JCRCMDSCPY dcl-f DDSLIST disk(132) extfile('QTEMP/DDSLIST'); dcl-ds inputDS len(132); aAsterisk char(1) pos(2); aSeqno char(6) samepos(aAsterisk); aNameType char(1) pos(26); sRcdFmtName char(12) samepos(aNameType); aFldName char(10) pos(28); aFldLen char(3) pos(41); aFldType char(1) pos(44); aDecimalPos char(2) pos(45); aLineNumb char(3) pos(48); aStartPos char(3) pos(51); aConstant char(36) pos(54); aMinusSgn char(1) pos(89); aEndOfSrc char(8) pos(30); aHeading char(8) pos(42); aExpanded char(8) pos(43); aCompNumb char(1) pos(95); end-ds; dcl-f JCRANZDP printer oflind(IsOverFlow) usropn; dcl-s AllNines char(30) inz(*all'9'); dcl-s AllZeros char(30) inz(*all'0'); dcl-s MsgconArry char(1) dim(288) based(blocptr); dcl-s BlocDta char(288); dcl-s Ctl_BlkTyp char(19) inz('Record Format Block'); dcl-s DecimalPart char(9); dcl-s EditMask char(256); dcl-s FieldName char(10); dcl-s FirstField char(3) inz('YES'); dcl-s FirstRecFm char(23) inz('YES'); dcl-s FlushBuffr char(3) inz('NO'); dcl-s StaggerNam char(198) dim(15); dcl-s StaggerDepth uns(3); // prevent name overlap dcl-s IPPfield char(12); dcl-s LoadNamFlg char(14) inz('Load Name Flag'); dcl-s O_EditCode char(1); dcl-s PrvLineNum char(3); dcl-s ReceiverVar char(256); dcl-s WholePart char(21); dcl-s MapStartPos char(3); dcl-s EditMaskLen int(10); dcl-s ReceiverVarLen int(10); dcl-s WholeLength int(5); dcl-s xb int(5); dcl-s xd int(5); dcl-s EndPosX packed(5); dcl-s xf int(5); dcl-s xg int(10); dcl-s xh int(5); dcl-s DecimalPos packed(1); dcl-s v30_9Dec packed(30: 9); dcl-s aFldLenNUM zoned(3) based(aptr); dcl-s ForCount uns(5); dcl-s aPtr pointer inz(%addr(afldlen)); dcl-s BlocPtr pointer inz(%addr(blocdta)); dcl-s IsExpanded ind; dcl-s IsFloatDollar ind; dcl-s savspace char(288); dcl-s edit1 char(1); dcl-ds v30_9DS qualified; v30_9Zoned zoned(30: 9) inz(0); end-ds; dcl-ds EditedDS qualified; EditedArry char(1) dim(40) inz; end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_File char(10); p_Lib char(10); p_Text char(50); p_ShowNames char(4); p_Output char(8); end-pi; //--------------------------------------------------------- f_OvrPrtf('JCRANZDP': '*JOB': p_Mbr); open JCRANZDP; // Print headings. Load print position 'rulers' scDow = f_GetDayName(); scObjHead = f_BuildString('& Mbr: & & & &': 'JCRANZPR': p_Mbr: p_File: p_Lib: p_Text); write PrtHead; IsOverFlow = *off; // load output positions ruler 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 inputDS; 1b dow not %eof; 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 aAsterisk <> '*'; //--------------------------------------------------------- // '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_ShowNames = '*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 must 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 = '-'; %subst(aConstant: 36: 1) = ' '; //remove continuation sign 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) = ' '; 5e endif; 5b if FieldName > *blanks or BlocDta in %list('PAGNBR': 'DATE': 'DATE(*SYS)': 'DATE(*JOB)': 'DATE(*YY)': 'DATE(*Y)': 'DATE(*SYS)': 'TIME'); BlocDta = %trimr(BlocDta) + ' ' + aConstant; 5x else; BlocDta = %trimr(BlocDta) + aConstant; 5e endif; 4e endif; 3e endif; 2e endif; read ddslist inputDS; //--------------------------------------------------------- // '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_DisplayLastSplf('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_ShowNames = '*YES' and StaggerDepth > 0; for-each LayOut in %subarr(StaggerNam:1:StaggerDepth); write PrtLine; 3e endfor; 2e endif; Layout = *blanks; StaggerDepth = 0; StaggerNam(*) = *blanks; EndPosX = 0; 1e endif; // Determine what type of field. IPPfield = *blanks; O_EditCode = *blanks; 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(qs: BlocDta); xb += 1; 1x elseif FieldsAttrDS.DataType = 'A'; IPPfield = 'Alpha Field'; 1x else; //--------------------------------------------------------- // Extract either starting position to edit word/edit code. // Handle date,time,stamp type data be building an // edit word based on type field and type formatting. // Then watch out for 'DATFMT(*ISO) SPACEA(2) ' // and be careful to not overlay the // spacing keyword when building the edit word. //--------------------------------------------------------- 2b if FieldsAttrDS.DataType in %list('L':'T':'Z'); savspace = *blanks; xb = %scan('SPACEA(': BlocDta); 3b if xb = 0; xb = %scan('SKIPB(': BlocDta); 3e endif; 3b if xb = 0; xb = %scan('SPACEB(': BlocDta); 3e endif; 3b if xb = 0; xb = %scan('SKIPA(': BlocDta); 3e endif; 3b if xb > 0; savspace = %subst(BlocDta:xb); %subst(BlocDta:xb) = *blanks; 3e endif; blocdta = 'EDTWRD(' + (f_BuildEditWord(%subst(blocdta:1:28): FieldsAttrDS.DataType)) +')'; 3b if savspace > *blanks; blocdta = %trimr(blocdta) + ' ' + %triml(savspace); 3e endif; 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 //--------------------------------------------------------- O_EditCode = *blanks; 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_ShowNames = '*YES' and StaggerDepth > 0; for-each LayOut in %subarr(StaggerNam:1:StaggerDepth); write PrtLine; 3e endfor; 2e endif; Layout = *blanks; StaggerDepth = 0; StaggerNam(*) = *blanks; EndPosX = 0; 1e endif; endsr; //--------------------------------------------------------- // load field name data begsr srLoadFieldData; clear FieldsAttrDS; FieldName = *blanks; DecimalPos = 0; 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. Zeros and nines are loaded into field. // End result for 9,2 field is 000000000000009999999 // 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); //--------------------------------------------------------- // Number of decimal places loads up left side // of field with 9's and fill out remainder with zeros. // End result for 9,2 field is 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 // If using leading 0 suppress in front of // constant, then must make field length parm 1 // bigger than actual value of field. //--------------------------------------------------------- ReceiverVar = *blanks; callp QECEDT( ReceiverVar: ReceiverVarLen: v30_9Dec: '*PACKED': 30: EditMask: EditMaskLen: ' ': ApiErrDS); //--------------------------------------------------------- // If API cannot apply user defined edit codes, it returns blank. // 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-each edit1 in EditedDS.EditedArry; 2b if edit1 > ' ' and edit1 <> '0'; 3b if DecimalPos = 0 and edit1 = '.'; 3x else; EndPosX += 1; 4b if EndPosX > 198; EndPosX = 198; 4e endif; 4b if LoadNamFlg = 'Start FldNam'; exsr srLoadFieldName; 4e endif; 4b if EndPosX in %range(1:198); %subst(Layout: EndPosx:1) = edit1; 4e endif; 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Process numeric fields with edit words or constants. // The only difference is edit words replace ' ' 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) = qs; //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 not (EndPosX in %range(1: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 = *blanks; endsr; //--------------------------------------------------------- // Formatted2 & Formatted3 business is to stagger field // field names if short length fields. // 9 99 // Fieldname 1 // Fieldname 2 // 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 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; //--------------------------------------------------------- // Changes parms to match attribute of DDS reserved field names //--------------------------------------------------------- dcl-proc f_DDsReservedWords; dcl-pi *n; BlocDta char(288); FieldName char(10); MapFldLength uns(10); MapDecPos char(2); MapDtaTyp char(1); end-pi; dcl-s QuotePos1 uns(5); dcl-s QuotePos2 uns(5); dcl-s xg int(10); //--------------------------------------------------------- // Reserved words (PAGE DATE PAGNBR) are more difficult to extract. // Real problem is when words are part of constant. // ('Work DATE') // Check if either reserved word is in first position or not between two ' '. //--------------------------------------------------------- 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(qs: BlocDta); 2b if QuotePos1 > 0; QuotePos2 = %scan(qs: 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-proc; //--------------------------------------------------------- // Returns text from dds MSGCON keyword dcl-proc f_MsgCon; dcl-pi *n char(288); p_BlockOfData char(288); end-pi; // variables for processing MSGCON keywords dcl-s mWork like(p_blockofdata); dcl-s xx int(10); // numeric work field dcl-s yy int(10); // numeric work field dcl-s Msgid char(7); dcl-s MsgFile char(10); dcl-s MsgLib char(10); dcl-s replacement char(112); dcl-ds MsgLengthDS qualified; MsgLength zoned(7) inz(0); end-ds; //--------------------------------------------------------- // p_BlockOfData could contain MSGCON(len msgid msgf) // 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; //did not find one 2b if xx < yy; //find lowest yy = xx; 2e endif; 1e endif; yy -= 1; //last pos of string //--------------------------------------------------------- // Is string 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-proc; ]]> '); //--------------------------------------------------------- // JCRANZPV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_IsValidSrcType /define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_ShowNames char(4); p_Output char(8); end-pi; //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_SrcFilQual: p_SrcMbr: 'PRTF'); f_SndEscapeMsg('Member ' + %trimr(p_SrcMbr) + ' is not type PRTF.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Procedure Names List') PARM KWD(BINDING) TYPE(BINDING) MIN(1) PROMPT('Binding Object') BINDING: QUAL TYPE(*NAME) LEN(10) 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 *PGM) 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) 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) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRBNDF; CREATE TABLE JCRBNDF ( JCRBNDDIR CHAR(10) NOT NULL DEFAULT '' , JCRBNDDIRL CHAR(10) NOT NULL DEFAULT '' , JCRSRVPGM CHAR(10) NOT NULL DEFAULT '' , JCRSRVPGML CHAR(10) NOT NULL DEFAULT '' , JCRMODULE CHAR(10) NOT NULL DEFAULT '' , JCRMODULEL CHAR(10) NOT NULL DEFAULT '' , JCRPROC CHAR(256) NOT NULL DEFAULT '' ) RCDFMT JCRBNDFR ; LABEL ON TABLE JCRBNDF IS 'Procedure names list - outfile jcr' ; LABEL ON COLUMN JCRBNDF ( JCRBNDDIR TEXT IS 'Binding Object' , JCRBNDDIRL TEXT IS 'Binding Lib' , JCRSRVPGM TEXT IS 'Service Pgm' , JCRSRVPGML TEXT IS 'Service Lib' , JCRMODULE TEXT IS 'Module' , JCRMODULEL TEXT IS 'Module lib' , JCRPROC TEXT IS 'Procedure Name' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRBNDF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Lists exported procedures/symbols of *BNDDIR, *SRVPGM, or *MODULEs. :P.The *PGM option will find the service programs in the program object and show where the procedures are coming from.: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) whose procedures are to be listed.:EHELP. :HELP NAME='JCRBND/OBJTYPE'.Object Type - Help :XH3.Object Type (OBJTYPE) :P.Type of binding object.:EHELP. :HELP NAME='JCRBND/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print, outfile, or * display the results.:EHELP. :HELP NAME='JCRBND/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRBND/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRBNDR' A 22'Procedure Names List' A SCSYSTEM 8A 100 A SCDOW 9A O 110 A 120DATE EDTCDE(Y) A 130TIME 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 ]]> '); //--------------------------------------------------------- // JCRBNDR - Procedure names list from bnddir/svcpgm/mod // // If object is BNDDIR, must execute CL command dspbnddir to outfile to get info. // Wish there was API for that! //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Qbnlspgm /define Qbnlpgmi /define f_BuildString /define f_GetQual /define f_OvrPrtf /define f_Dltovr /define f_Quscrtus /define f_Qusrobjd /define f_SndCompMsg /define f_RunCmd /define f_DisplayLastSplf /define f_GetDayName /define Quslobj /define f_IsValidObj // *ENTRY /define p_JCRBNDR /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRBNDF usage(*output) extfile(extOfile) extmbr(ExtOmbr) usropn; dcl-f JCRBNDP printer oflind(IsOverFlow) usropn; dcl-s extOmbr char(10); dcl-s LibObjQual char(21); dcl-s PgmSpace char(20) inz('JCRPGM QTEMP'); dcl-s ModuleSpace char(20) inz('JCRMODULE QTEMP'); dcl-s SrvPgmSpace char(20) inz('JCRSRVPGM QTEMP'); dcl-ds ApiHead3 likeds(GenericHeader) based(ApiHeadPtr3); //--------------------------------------------------------- QusrObjDS = f_QUSROBJD(p_ObjQual: p_ObjTyp); %subst(p_ObjQual: 11: 10) = QusrObjDS.ReturnLib; LibObjQual = f_GetQual(p_ObjQual); // depending on output selection 1b if p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRBNDF; 1x else; f_OvrPrtf('JCRBNDP': '*JOB': %subst(p_ObjQual: 1: 10)); open JCRBNDP; scDow = 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; IsOverFlow = *off; 1e endif; //-------------------------------------------------------- 1b if p_ObjTyp = '*PGM'; ApiHeadPtr = f_Quscrtus(PgmSpace); 1e endif; ApiHeadPtr2 = f_Quscrtus(SrvPgmSpace); ApiHeadPtr3 = f_Quscrtus(ModuleSpace); 1b if QusrObjDS.Type = '*BNDDIR'; f_GetBndDir(QusrObjDS.ObjNam: QusrObjDS.ReturnLib); 1x elseif QusrObjDS.Type = '*SRVPGM'; f_GetSrvPgm(QusrObjDS.ObjNam: QusrObjDS.ReturnLib); 1x elseif QusrObjDS.Type = '*MODULE'; f_GetModule(QusrObjDS.ObjNam: QusrObjDS.ReturnLib); 1x elseif QusrObjDS.Type = '*PGM'; f_GetProceduresinPgm(QusrObjDS.ObjNam: QusrObjDS.ReturnLib); 1e endif; 1b if p_Output in %list('*PRINT':'*'); close JCRBNDP; f_Dltovr('JCRBNDP'); f_DisplayLastSplf('JCRBNDR': p_Output); 1x elseif p_Output = '*OUTFILE'; f_SndCompMsg('File ' +%trimr(extOfile)+ ' generated by JCRBND.'); 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Excute a API to get all service program names used in a program. // Then execute the f_GetSrvPgm to print them out. //--------------------------------------------------------- dcl-proc f_GetProceduresinPgm; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; dcl-ds Pgml0200DS qualified based(Pgml0200PTR); Name char(10) pos(21); Lib char(10) pos(31); end-ds; callp QBNLPGMI( PgmSpace: 'PGML0200': p_ObjName + p_ObjLib: ApiErrDS); Pgml0200Ptr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if Pgml0200DS.Lib <> 'QSYS'; 3b if Pgml0200DS.Lib <> ' '; Pgml0200DS.Lib = '*LIBL'; 3e endif; f_GetSrvPgm(Pgml0200DS.Name:Pgml0200DS.Lib); 2e endif; Pgml0200Ptr += ApiHead.ListEntrySize; 1e endfor; return; end-proc; //--------------------------------------------------------- // There is no API to get bind directory entries!. // Execute DSPBNDDIR command to *OUTFILE, then process outfile. //--------------------------------------------------------- dcl-proc f_GetBndDir; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; dcl-f JCRBNDFB usropn; dcl-ds inputDS likerec(QBNDSPBD); f_RunCmd('DSPBNDDIR BNDDIR(' + f_GetQual(p_ObjName + p_ObjLib) + ') OUTPUT(*OUTFILE) ' + ' OUTFILE(JCRBNDFB) OUTMBR(*FIRST *REPLACE)'); jcrBndDir = p_ObjName; jcrBndDirL = p_ObjLib; open JCRBNDFB; read JCRBNDFB inputDS; 1b dow not %eof; //------------------------------------------------- // Directory entries sometimes have *LIBL for the // service program or *module name, and these objects are not // in your library list. If object not in your library list, // execute function to search *ALLUSR for object. //--------------------------------------------------- inputDS.bnolnm = f_GetLib(inputDS.bnobnm: inputDS.bnolnm: inputDS.bnobtp); //--------------------------------------------------- 2b if inputDS.bnobtp = '*SRVPGM'; f_GetSrvPgm(inputDS.bnobnm: inputDS.bnolnm); 2x elseif inputDS.bnobtp = '*MODULE'; f_GetModule(inputDS.bnobnm: inputDS.bnolnm); 2e endif; read JCRBNDFB inputDS; 1e enddo; close JCRBNDFB; f_RunCmd('CLRPFM JCRBNDFB'); return; end-proc; //--------------------------------------------------------- dcl-proc f_GetSrvPgm; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; jcrSrvPgm = p_ObjName; jcrSrvPgmL = p_ObjLib; jcrModule = *blanks; jcrModuleL = *blanks; callp QBNLSPGM( SrvPgmSpace: 'SPGL0600': p_ObjName + p_ObjLib: ApiErrDS); SrvPgmPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 1b for ForCount2 = 1 to ApiHead2.ListEntryCount; jcrProc = %subst(SrvPgmDS.BigProcName:1:SrvPgmDS.LengthOfName); f_PutPrint( jcrBndDir: jcrBndDirL: jcrSrvPgm: jcrSrvPgmL: jcrModule: jcrModuleL: jcrProc); SrvPgmPtr += ApiHead2.ListEntrySize; 1e endfor; jcrSrvPgm = *blanks; jcrSrvPgmL = *blanks; return; end-proc; //--------------------------------------------------------- dcl-proc f_GetModule; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; dcl-s ForCount int(10); dcl-s ProcNameRaw char(256) based(rawnameptr); dcl-ds ListEntryDS qualified based(ListEntryPtr); SizeOfThisEnt int(10) pos(1); OffsetToProc int(10) pos(29); LengthOfName int(10) pos(33); end-ds; // List Module Information dcl-pr Qbnlmodi extpgm('QBNLMODI'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // object and lib *n like(ApiErrDS); end-pr; jcrModule = p_ObjName; jcrModuleL = p_ObjLib; callp QBNLMODI( ModuleSpace: 'MODL0300': p_ObjName + p_ObjLib: ApiErrDS); ListEntryPtr = ApiHeadPtr3 + ApiHead3.OffSetToList; 1b for ForCount = 1 to ApiHead3.ListEntryCount; 2b if ListEntryDS.LengthOfName > %size(jcrProc); ListEntryDS.LengthOfName = %size(jcrProc); 2e endif; RawNamePtr = ApiHeadPtr3 + 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-proc; //--------------------------------------------------------- dcl-proc f_PutPrint; dcl-pi *n; jcrBndDir char(10); jcrBndDirL char(10); jcrSrvPgm char(10); jcrSrvPgmL char(10); jcrModule char(10); jcrModuleL char(10); jcrProc char(256); end-pi; 1b if p_Output in %list('*PRINT':'*'); 2b if QusrObjDS.Type = '*BNDDIR'; DetailVar = jcrBndDir + ' ' + jcrSrvPgm + ' ' + jcrSrvPgmL + ' ' + jcrModule + ' ' + jcrModuleL + ' ' + jcrProc; 2x elseif QusrObjDS.Type in %list('*SRVPGM':'*PGM'); DetailVar = jcrSrvPgm + ' ' + jcrProc; 2x elseif QusrObjDS.Type = '*MODULE'; DetailVar = jcrModule + ' ' + jcrProc; 2e endif; write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; 1x elseif p_Output = '*OUTFILE'; write JCRBNDFR; 1e endif; end-proc; //--------------------------------------------------------- // Directory entries sometimes have *LIBL for the // service program or *module name, and these objects are not // in your library list. Search *ALLUSR for object then return library name. //--------------------------------------------------------- dcl-proc f_GetLib; dcl-pi *n char(10); // returned library name p_ObjName char(10); p_ObjLib char(10); p_ObjType char(7); end-pi; dcl-ds ApiHead4 likeds(GenericHeader) based(ApiHeadPtr4); dcl-s LiblSpace char(20) inz('JCRLIBL QTEMP'); 1b if f_IsValidObj(p_ObjName: p_ObjLib: p_ObjType); return p_ObjLib; 1e endif; ApiHeadPtr4 = f_Quscrtus(LiblSpace); callp QUSLOBJ( LiblSpace: 'OBJL0100': p_ObjName + '*ALLUSR': p_ObjType: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0 or ApiHead4.ListEntryCount = 0; return p_ObjLib; 1e endif; QuslobjPtr = ApiHeadPtr4 + ApiHead4.OffSetToList; return QuslobjDS.ObjLib; end-proc; ]]> '); //--------------------------------------------------------- // JCRBNDV - Validity checking program with create outfile //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_OutFileCrtDupObj // *ENTRY /define p_JCRBNDR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckObj(p_ObjQual: p_ObjTyp); 1b if p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRBNDF'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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') ]]> .*-------------------------------------------------------------------- :P.Prompts a temp command created from entry field names and attributes required by called program. :P.The generated command designates called program as the command processing program, so parm values can be entered and the program executed. :P.The generated command source is available in QTEMP/CMDSRC member JCRCALLX. :P.Conditions::UL COMPACT. :LI.Called program source code must be available for compile.:EUL. :P.A prompt override program retrieves source code location used to compile called program. Read compile listing, building a command in QTEMP with prompts matching the entry parameters then specifies called program as command processing program. :P.The generated command is executed, prompting key input parameters in command format. :NT.Prompt the 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. ]]> '); //--------------------------------------------------------- // JCRCALLO - prompt override program // return command prompt override string for program source lib/file/mbr //--------------------------------------------------------- /define ControlStatements /define f_PromptOverrideGetSource /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_CmdQual char(20); p_PgmQual char(20); p_RtnString char(5700); end-pi; //--------------------------------------------------------- p_RtnString = f_PromptOverrideGetSource(p_PgmQual); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRCALLR - Generate CMD to provide parms to called program // Generate/execute command that will prompt for parms in RPG or CL program // Get program attributes from prompt override program. // A command is created with called program as Command Processing Pgm // Helpful Hint: Execute jcrcallx after this command has run. // V7 drive off first dcl-pi to get procedure interface command definition //--------------------------------------------------------- /define ControlStatements /define FieldsArry /define FieldsAttrDS /define ApiErrDS /define Constants /define f_GetQual /define f_BuildString /define f_SndCompMsg /define f_SndEscapeMsg /define f_RunCmd /define f_IsIgnoreLine /define f_IsCompileTimeArray /define p_JCRGETFLDR /define p_JCRGETCLPR /define f_GetProcedureEntryPoint /define f_GetParmFieldsArryIndex /define SourceOutDS // *ENTRY /define p_JCRCALLR /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGETFLDF disk(132) extfile('QTEMP/JCRGETFLDF') usropn; dcl-ds SplfDs len(132) qualified inz; CompileArray char(3) pos(3); SpecType char(1) pos(8); Src94 char(94) pos(9); SourceListing char(27) pos(27); EndOfSource char(25) pos(20); end-ds; dcl-f CMDSRC disk(112) usage(*output) extfile('QTEMP/CMDSRC') extmbr('JCRCALLX') usropn; //--------------------------------------------------------- dcl-s string varchar(94); dcl-s p_DiagSeverity char(2) inz('00'); dcl-s p_Lib char(10); dcl-s p_CPPname char(10); dcl-s WorkField char(11); dcl-s linecount packed(6:2); dcl-s WorkType char(5); dcl-s ProcedureEntryPoint char(6); dcl-s IsAllDone ind; dcl-s PepCnt packed(3); dcl-s DoParmCnt packed(3); dcl-s ParmName char(10); //--------------------------------------------------------- exsr srWriteCmdPromptLine; 1b if p_Pgmatr in %list('RPGLE': 'SQLRPGLE'); exsr srRPG; 1x elseif p_Pgmatr in %list('CLLE': 'CLP'); exsr srCL; 1e endif; exsr srExecutePrompt; *inlr = *on; return; //--------------------------------------------------------- begsr srRPG; // load global clipboard with field attributes from JCRGETFLDR callp p_JCRGETFLDR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity: PepCnt); 1b if DiagSeverity > '19'; *inlr = *on; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; 1b If PepCnt > 0; DoParmCnt = 0; //--------------- open JCRGETFLDF; ProcedureEntryPoint = *blanks; 2b dou SplfDs.SourceListing = 'S o u r c e L i s t i n g'; read JCRGETFLDF SplfDs; 2e enddo; read JCRGETFLDF SplfDs; 2b dow not %eof; // no process compile time arrays 3b if f_IsCompileTimeArray(SplfDs.CompileArray) or SplfDS.EndOfSource = 'E N D O F S O U R C E'; 2v leave; 3e endif; SplfDs = %upper(SplfDs); string = %trimr(SplfDs.Src94); 3b if not f_IsIgnoreLine(string); // execute function that looks for PI or *entry; 4b if ProcedureEntryPoint = *blanks; ProcedureEntryPoint = f_GetProcedureEntryPoint(SplfDs.SpecType: string); 5b if ProcedureEntryPoint = 'NO-PEP'; 2v leave; 5e endif; 4x else; //------------------------------------------------------------- // The ability to mix new free format and old fixed columns // makes it difficult to tell where the entry parms end. // I let the rpggetfldr program count the number of parms // then read until I load that many field names. //------------------------------------------------------------- bb = f_GetParmFieldsArryIndex(SplfDs.SpecType: string); 5b if bb > 0; exsr srWriteParmKwdSource; DoParmCnt += 1; 6b If DoParmCnt = PepCnt; 2v leave; 6e endif; 5e endif; 4e endif; 3e endif; read JCRGETFLDF SplfDs; 2e enddo; close JCRGETFLDF; 1e endif; endsr; //--------------------------------------------------------- // write out command source begsr srWriteParmKwdSource; ParmName = FieldsArry(bb).Name; FieldsAttrDS = FieldsArry(bb).Attr; OutDS.SrcCod = 'PARM KWD(' + %subst(ParmName: 1: 10) + ') TYPE('; 1b if FieldsAttrDS.DecimalPos > ' '; OutDS.SrcCod = %trimr(OutDS.SrcCod) + '*DEC) LEN('; 1x else; OutDS.SrcCod = %trimr(OutDS.SrcCod) + '*CHAR) LEN('; 1e endif; OutDS.SrcCod = %trimr(OutDS.SrcCod) + %char(FieldsAttrDS.Length) + ' ' + FieldsAttrDS.DecimalPos + ') + '; linecount += 10; OutDS.SrcSeq = linecount; write CMDSRC OutDS; // Generate PROMPT text OutDS.SrcCod = 'PROMPT(' + qs + ParmName + ' ' + %char(FieldsAttrDS.Length); 1b if FieldsAttrDS.DecimalPos > ' '; OutDS.SrcCod = %trimr(OutDS.SrcCod) + ',' +FieldsAttrDS.DecimalPos; 1e endif; OutDS.SrcCod = %trimr(OutDS.SrcCod) + qs + ')'; linecount += 10; OutDS.SrcSeq = linecount; write CMDSRC OutDS; 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 FieldsArryCnt; linecount += 10; OutDS.SrcSeq = linecount; FieldsAttrDS = FieldsArry(aa).Attr; 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(FieldsArry(aa).Name: 2: 10); OutDS.SrcCod = f_BuildString('PARM KWD(&) TYPE(&) LEN(& &) PROMPT(&Q&&Q)': WorkField: WorkType: %char(FieldsAttrDS.Length): FieldsAttrDS.DecimalPos: WorkField); write CMDSRC OutDS; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srWriteCmdPromptLine; p_CPPname = %subst(p_PgmQual: 1: 10); p_Lib = %subst(p_PgmQual: 11: 10); // create source file for temp command member f_RunCmd('DLTF FILE(QTEMP/CMDSRC)'); f_RunCmd('CRTSRCPF FILE(QTEMP/CMDSRC) MBR(JCRCALLX) RCDLEN(112)'); open CMDSRC; OutDS.SrcCod = f_BuildString('CMD PROMPT(&QEntry Parms - &&Q)':p_CPPname); linecount += 10; OutDS.SrcSeq = linecount; write CMDSRC OutDS; endsr; //--------------------------------------------------------- // create command object and execute //--------------------------------------------------------- begsr srExecutePrompt; close CMDSRC; f_RunCmd('DLTCMD CMD(QTEMP/JCRCALLX)'); f_RunCmd('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_RunCmd('?QTEMP/JCRCALLX'); f_SndCompMsg('JCRCALL parm processing for ' + f_GetQual(p_CPPname + p_Lib) + ' - completed'); endsr; ]]> '); //--------------------------------------------------------- // JCRCALLV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_SndEscapeMsg // *ENTRY /define p_JCRCALLR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckObj(p_PgmQual: '*PGM'); 1b if not (p_Pgmatr in %list('RPGLE':'SQLRPGLE':'CLP':'CLLE')); f_SndEscapeMsg('Program type ' + %trimr(p_Pgmatr) + ' is not type RPGLE, SQLRPGLE, CLP, or CLLE.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ STRPGMEXP SIGNATURE('JCRCMDS890123456') EXPORT SYMBOL(ApiErrDS) EXPORT SYMBOL(FieldsArry) EXPORT SYMBOL(FieldsArryCnt) EXPORT SYMBOL(f_AddSortKey) EXPORT SYMBOL(f_BlankCommentsCL) EXPORT SYMBOL(f_BuildString) EXPORT SYMBOL(f_CamelCase) EXPORT SYMBOL(f_CenterText) EXPORT SYMBOL(f_CheckDir) EXPORT SYMBOL(f_CheckMbr) EXPORT SYMBOL(f_CheckObj) EXPORT SYMBOL(f_CheckSameLineEnd) EXPORT SYMBOL(f_CrtCmdString) EXPORT SYMBOL(f_ConvertCcsid) EXPORT SYMBOL(f_DecodeApiTimeStamp) EXPORT SYMBOL(f_DisplayLastSplf) EXPORT SYMBOL(f_DltOvr) EXPORT SYMBOL(f_EllipsisLoc) EXPORT SYMBOL(f_BuildEditWord) EXPORT SYMBOL(f_GetAllocatedSize) EXPORT SYMBOL(f_GetApiHMS) EXPORT SYMBOL(f_GetApiISO) EXPORT SYMBOL(f_GetCardColor) EXPORT SYMBOL(f_GetCardFace) EXPORT SYMBOL(f_GetDataTypeKeyWords) EXPORT SYMBOL(f_GetDayName) EXPORT SYMBOL(f_GetEmail) EXPORT SYMBOL(f_GetFileLevelID) EXPORT SYMBOL(f_GetFileUtil) EXPORT SYMBOL(f_GetInternalProcNames) EXPORT SYMBOL(f_GetParmFieldsArryIndex) EXPORT SYMBOL(f_GetProcedureEntryPoint) EXPORT SYMBOL(f_GetQual) EXPORT SYMBOL(f_GetRandom) EXPORT SYMBOL(f_GetRowColumn) EXPORT SYMBOL(f_IsCompileTimeArray) EXPORT SYMBOL(f_IsIgnoreLine) EXPORT SYMBOL(f_IsSameMbr) EXPORT SYMBOL(f_IsValidMbr) EXPORT SYMBOL(f_IsValidSrcType) EXPORT SYMBOL(f_IsValidObj) EXPORT SYMBOL(f_SrcFileAddPfm) EXPORT SYMBOL(f_OutFileCrtDupObj) EXPORT SYMBOL(f_OvrPrtf) EXPORT SYMBOL(f_PromptOverrideGetSource) EXPORT SYMBOL(f_Qmhrcvpm) EXPORT SYMBOL(f_Quscrtus) EXPORT SYMBOL(f_Qusrmbrd) EXPORT SYMBOL(f_Qusrobjd) EXPORT SYMBOL(f_ReturnZeroIfAfterComments) EXPORT SYMBOL(f_ReturnZeroIfBetweenQuotes) EXPORT SYMBOL(f_RmvSflMsg) EXPORT SYMBOL(f_RtvMsgApi) EXPORT SYMBOL(f_RunOptionFile) EXPORT SYMBOL(f_RunOptionJob) EXPORT SYMBOL(f_RunOptionSplf) EXPORT SYMBOL(f_ShuffleDeck) EXPORT SYMBOL(f_SndCompMsg) EXPORT SYMBOL(f_SndEscapeMsg) EXPORT SYMBOL(f_SndStatMsg) EXPORT SYMBOL(f_RunCmd) EXPORT SYMBOL(f_ZipIFS) ENDPGMEXP ]]> //--------------------------------------------------------- // JCRCMDSCPY - Copy Book for JCRCMDS //--------------------------------------------------------- /endif /If defined(ControlStatements) ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); /endif /If defined(ApiErrDS) //--------------------------------------------------------- // API error return parm dcl-ds ApiErrDS qualified import; BytesProvided int(10) pos(1); BytesReturned int(10) pos(5); ErrMsgId char(7) pos(9); MsgReplaceVal char(112) pos(17); end-ds; /endif /If defined(Atof) //--------------------------------------------------------- // C String to Float dcl-pr atof float(8) extproc(*dclcase); *n pointer value options(*string); end-pr; /endif /If defined(Constants) //--------------------------------------------------------- dcl-s rrn uns(5); dcl-s aa uns(5); dcl-s bb uns(5); dcl-s cc uns(5); dcl-c qs const(''''); // quote single dcl-c qd const('"'); // quote double /endif /If defined(Cvthc) //--------------------------------------------------------- // Convert Hex to Character dcl-pr cvthc extproc(*dclcase); *n pointer value; // receiver pointer *n pointer value; // source pointer *n int(10) value; // receiver length end-pr; /endif /If defined(Infds) //--------------------------------------------------------- // File Information Data Structure dcl-ds Infds; InfdsFile char(10) pos(83); InfdsLib char(10) pos(93); InfdsRecLen int(5) pos(125); InfdsMbr char(10) pos(129); InfdsCcsid int(5) pos(218); InfdsRcdfmt char(10) pos(261); InfdsFkey char(1) pos(369); InfdsSflRcdNbr int(5) pos(378); InfdsDbRrn int(10) pos(397); end-ds; /endif /If defined(Dspatr) //--------------------------------------------------------- dcl-c Green const(x'20'); dcl-c White const(x'22'); dcl-c Red const(x'28'); dcl-c Turq const(x'30'); dcl-c Yellow const(x'32'); dcl-c Pink const(x'38'); dcl-c Blue const(x'3A'); dcl-c ND const(x'27'); dcl-c RI const(x'01'); dcl-c HI const(x'02'); dcl-c UL const(x'04'); dcl-c PR const(x'80'); /endif /If defined(FieldsAttrDS) //--------------------------------------------------------- dcl-ds FieldsAttrDS qualified inz; Length uns(10); DecimalPos char(2); DecimalPosN zoned(2) samepos(DecimalPos); DataType char(1); FromFile char(10); QualifyingDS char(50); Text char(25); end-ds; /endif /If defined(FieldsArry) //--------------------------------------------------------- dcl-s FieldsArryCnt uns(10) import; dcl-ds FieldsArry dim(5000) qualified import; Name char(100); Attr like(FieldsAttrDS); end-ds; /endif /If defined(FunctionKeys) //--------------------------------------------------------- dcl-c f01 const(x'31'); dcl-c f02 const(x'32'); dcl-c f03 const(x'33'); dcl-c f04 const(x'34'); dcl-c f05 const(x'35'); dcl-c f06 const(x'36'); dcl-c f07 const(x'37'); dcl-c f08 const(x'38'); dcl-c f09 const(x'39'); dcl-c f10 const(x'3A'); dcl-c f11 const(x'3B'); dcl-c f12 const(x'3C'); dcl-c f13 const(x'B1'); dcl-c f14 const(x'B2'); dcl-c f15 const(x'B3'); dcl-c f16 const(x'B4'); dcl-c f17 const(x'B5'); dcl-c f18 const(x'B6'); dcl-c f19 const(x'B7'); dcl-c f20 const(x'B8'); dcl-c f21 const(x'B9'); dcl-c f22 const(x'BA'); dcl-c f23 const(x'BB'); dcl-c f24 const(x'BC'); dcl-c fPageup const(x'F4'); dcl-c fPageDown const(x'F5'); /endif /If defined(Ind) //--------------------------------------------------------- // name screen indicators dcl-ds ind qualified inz; IsActivateF14 ind pos(04); IsKeysMode ind pos(05); sfldrop ind pos(06); HeadingSwitch ind pos(10); sflnxtchg ind pos(11); IsChangedDate ind pos(20); IsChange ind pos(23); ShowSrcData ind pos(27); sfldsp ind pos(31); sfldspctl ind pos(32); sflclr ind pos(33); sflend ind pos(34); sfldsp2 ind pos(41); sfldspctl2 ind pos(42); sflclr2 ind pos(43); sflend2 ind pos(44); sfldsp3 ind pos(51); sfldspctl3 ind pos(52); sfldsp4 ind pos(61); sfldspctl4 ind pos(62); end-ds; /endif /If defined(Qwcrneta) //--------------------------------------------------------- // Retrieve Network Attributes dcl-pr Qwcrneta extpgm('QWCRNETA'); *n char(200) options(*varsize); // Receiver Variable *n int(10) const; // Receiver Length *n int(10) const; // Number Of Keys *n char(20) const; // Constant *n like(ApiErrDS); end-pr; dcl-ds QwcrnetaDS len(200) qualified inz; NumberKeys int(10); TableOffset int(10); end-ds; // Network Attribute Information Table returned dcl-ds NetworkInfoDS qualified based(NetWorkInfoPtr); Attribute char(10) pos(1); TypeOfData char(1) pos(11); InfoStatus char(1) pos(12); LengthOfData int(10) pos(13); LocalSysName char(8) pos(17); end-ds; /endif /If defined(Qbnlpgmi) //--------------------------------------------------------- // List ILE Program Information dcl-pr Qbnlpgmi extpgm('QBNLPGMI'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // object and lib *n like(ApiErrDS); end-pr; dcl-ds QbnlpgmiDS qualified based(QbnlpgmiPTR); SrcFil char(10) pos(41); SrcLib char(10) pos(51); SrcMbr char(10) pos(61); SrcAttrb char(10) pos(71); end-ds; /endif /If defined(Qbnlspgm) //--------------------------------------------------------- // List Service Program Information dcl-pr Qbnlspgm extpgm('QBNLSPGM'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // object and lib *n like(ApiErrDS); end-pr; dcl-ds SrvPgmDs qualified based(SrvPgmPtr); //these 2 fields are for SPGL0600 format LengthOfName int(10) pos(25); BigProcName char(256) pos(29); // SPGL0100 format SrcFil char(10) pos(41); SrcLib char(10) pos(51); SrcMbr char(10) pos(61); SrcAttrb char(10) pos(71); end-ds; /endif /If defined(Qbnrmodi) //--------------------------------------------------------- // Retrieve Module Information dcl-pr Qbnrmodi extpgm('QBNRMODI'); *n char(200); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // object and lib *n like(ApiErrDS); end-pr; dcl-ds QbnrmodiDS len(200) qualified; SrcFil char(10) pos(52); SrcLib char(10) pos(62); SrcMbr char(10) pos(72); end-ds; /endif /If defined(Qclrpgmi) //--------------------------------------------------------- // Retrieve Non-ile Program Information (like CLP) dcl-pr Qclrpgmi extpgm('QCLRPGMI'); *n char(528); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // file and lib *n like(ApiErrDS); end-pr; dcl-ds QclrpgmiDS len(528) qualified; SrcAttrb char(10) pos(39); SrcFil char(10) pos(62); SrcLib char(10) pos(72); SrcMbr char(10) pos(82); PgmType char(1) pos(161); // B=ILE program end-ds; /endif /If defined(Qcmdchk) //--------------------------------------------------------- // Check Command Syntax dcl-pr Qcmdchk extpgm('QCMDCHK'); *n char(500); *n packed(15: 5) const; end-pr; /endif /If defined(Qdbldbr) //--------------------------------------------------------- // List Database Relations dcl-pr Qdbldbr extpgm('QDBLDBR'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // file and lib *n char(10) const; // mbr *n char(10) const; // record format *n like(ApiErrDS); end-pr; //-DBRL0100 format- dcl-ds QdbldbrDS qualified based(QdbldbrPtr); DependentLF char(10) pos(21); DependentLib char(10) pos(31); DependentFile char(20) samepos(DependentLF); end-ds; /endif /If defined(Qdbrtvfd) //--------------------------------------------------------- // Retrieve Database File Description dcl-pr Qdbrtvfd extpgm('QDBRTVFD'); *n char(16000) options(*varsize); // receiver *n int(10) const; // receiver length *n char(20); // return file and lib *n char(8) const; // api format *n char(20) const; // file and lib *n char(10) const; // record format *n char(1) const; // overrides *n char(10) const; // system *n char(10) const; // format type *n like(ApiErrDS); end-pr; dcl-s ReturnFileQual char(20); // file header offsets dcl-ds Fild0100ds qualified based(Fild0100ptr); BytesReturned int(10) pos(1); TypeBits char(1) pos(9); NumOfBasedPf int(5) pos(15); MaxMbrs int(5) pos(42); NumMbrs int(5) pos(48); NumRcdFmts int(5) pos(62); FileText char(50) pos(85); NumOfFlds int(5) pos(207); FileRecLen int(5) pos(305); OffsFileScope int(10) pos(317); AccessType char(2) pos(337); OffsPFAttr int(10) pos(365); OffsLfAttr int(10) pos(369); end-ds; // file scope array dcl-ds FileScopeArry len(160) qualified based(fscopePtr); BasedOnPf char(10) pos(49); BasedOnPfLib char(10) pos(59); RcdFmt char(10) pos(69); NumOfKeys int(5) pos(116); NumSelectOmit int(5) pos(129); OffsSelectOmit int(10) pos(131); OffsKeySpecs int(10) pos(135); end-ds; // key specification array dcl-ds KeySpecsDS qualified based(KeySpecsPtr); KeyFieldName char(10) pos(1); KeySequenBits char(1) pos(14); end-ds; // select/omit specification array dcl-ds SelectOmitSpec qualified based(SelectOmitSpecPtr); StatementRule char(1) pos(3); CompRelation char(2) pos(4); FieldName char(10) pos(6); NumberOfParms int(5) pos(16); OffsToParms int(10) pos(29); end-ds; // select/omit parameters dcl-ds SelectOmitParm qualified based(SelectOmitParmPtr); OffsToNext int(10) pos(1); ParmLength int(5) pos(5); ParmValue char(30) pos(21); end-ds; // Logical file specific attributes dcl-ds LfSpecific len(48) qualified based(lfSpecificPtr); JoinOffset int(10) pos(1); AttrBits char(1) pos(31); end-ds; // join specifications linked list dcl-ds JoinSpecDS len(48) qualified based(JoinSpecPtr); NextLink int(10) pos(1); NumJFlds int(5) pos(9); JoinFileNum int(5) pos(13); OffsToJSA int(10) pos(41); end-ds; // join specification array (JSA) dcl-ds JoinSpecArryDS len(48) qualified based(JoinSpecArryPtr); FromField char(10) pos(1); FromNumber int(5) samepos(FromField); ToField char(10) pos(17); ToNumber int(5) pos(27); end-ds; // physical file attributes dcl-ds PfAttrDS based(PfAttrPtr) qualified; Bits char(1) pos(24); // bit 1 = reuse *yes OffsTriggers int(10) pos(25); NumOfTriggers int(5) pos(29); end-ds; // trigger information array dcl-ds TriggerDS based(TriggerPtr) qualified; TTime char(1) pos(1); TEvent char(1) pos(2); TPrgNam char(10) pos(3); TPrgLib char(10) pos(13); end-ds; // file header for fild0200 format dcl-ds fild0200DS len(3000) qualified inz; BytesReturned int(10); BytesAvail int(10); LevelID char(13) pos(81); end-ds; //--------------------------------------------------------- // size of memory to allocate for QDBRTVFD call dcl-pr f_GetAllocatedSize int(10); // memory size *n char(20) const; // qualified file name *n char(10) const; // record format name end-pr; dcl-s AllocatedSize int(10); /endif /If defined(qdtaqproto) //--------------------------------------------------------- // data queue monitor for f3 or f12 dcl-pr qclrdtaq extpgm('QCLRDTAQ'); // Clear Data Queue *n char(10) const; // Name *n char(10) const; // Library end-pr; dcl-pr qrcvdtaq extpgm('QRCVDTAQ'); // Receive Dtaq Entry *n char(10) const; // Name *n char(10) const; // Library *n packed(5) const; // Length of Data *n char(80); // Data *n packed(5) const; // Wait Time end-pr; dcl-s dtaqEntry char(80); /endif /If defined(Qeccvtec) //--------------------------------------------------------- // Convert Edit Code to Edit Mask dcl-pr Qeccvtec extpgm('QECCVTEC'); *n char(256); // receiver *n int(10); // mask length *n int(10); // receiver length *n char(1) const; // 0 balance file *n char(1) const; // edit code *n char(1) const; // blank fill *n int(10) const; // field length *n int(10) const; // decimal location *n like(ApiErrDS); end-pr; /endif /If defined(Qecedt) //--------------------------------------------------------- // Apply Edit Mask dcl-pr Qecedt extpgm('QECEDT'); *n char(256); *n int(10); /if defined(QecedtAlpha) *n char(256); // to be edited alpha /else *n packed(30:9); // to be edited numeric /endif *n char(10) const; // type *n int(10) const; // field length *n char(256); // edit mask *n int(10); // mask length *n char(1) const; // 0 balance file *n like(ApiErrDS); end-pr; /endif /If defined(Qlgsort) //--------------------------------------------------------- // Sort Api dcl-pr qlgsort extpgm('QLGSORT'); *n char(1024) options(*varsize); // sort ds *n char(20) dim(10); // in buffer *n char(20) dim(10); // out buffer *n int(10) const; // length in buffer *n int(10) const; // length out buffer *n like(ApiErrDS); end-pr; // QLGSORT Sort Control Block dcl-ds qlgSortDS len(1024) qualified inz; BlockLength int(10) pos(1); TypeRequest int(10) pos(5) inz(5); Reserved1 int(10) pos(9); Options int(10) pos(13); RecordLength int(10) pos(17); RecordCount int(10) pos(21); OffToKeyList int(10) pos(25) inz(80); NumOfKeys int(10) pos(29); OffNatLangInf int(10) pos(33); OffInpFileList int(10) pos(37); NumOfInpFiles int(10) pos(41); OffOutFileList int(10) pos(45); NumofOutFiles int(10) pos(49); KeyEntryLength int(10) pos(53) inz(16); SortSeqLength int(10) pos(57); LenInFileEntry int(10) pos(61); LenOutFileEntry int(10) pos(65); OffToNullMap int(10) pos(69); OffToVarRecInf int(10) pos(73); Reserved2 int(10) pos(77); end-ds; dcl-pr f_AddSortKey char(16); *n int(10) const; // start pos *n int(10) const; // string size *n int(10) const options(*nopass); // data type *n int(10) const options(*nopass); // sort order end-pr; /endif /If defined(Qmhqrdqd) //--------------------------------------------------------- // Retrieve Data Queue Description dcl-pr Qmhqrdqd extpgm('QMHQRDQD'); *n like(QmhqrdqdDS); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20); // data queue and lib name end-pr; dcl-ds QmhqrdqdDS qualified inz; MsgLength int(10) pos(9); KeyLength int(10) pos(13); Sequence char(1) pos(17); SenderID char(1) pos(18); Text char(50) pos(20); LocalOrDDM char(1) pos(70); EntryCount int(10) pos(73); CurrAllocated int(10) pos(77); DtaqName char(10) pos(81); DtaqLib char(10) pos(91); MaxAllowed int(10) pos(101); CreateSize int(10) pos(109); end-ds; /endif /If defined(Qmhsndpm) //--------------------------------------------------------- // Send Program Message dcl-pr Qmhsndpm extpgm('QMHSNDPM'); *n char(7) const; // message id *n char(20) const; // file and lib *n char(75) const; // text *n int(10) const; // length *n char(10) const; // type *n char(10) const; // queue *n int(10) const; // stack entry *n char(4) const; // key *n like(ApiErrDS); end-pr; /endif /If defined(QsnGetCsrAdr) //--------------------------------------------------------- // Get Cursor Address Row and Column dcl-pr QsnGetCsrAdr int(10) extproc(*dclcase); *n int(10) const; // row *n int(10) const; // col *n int(10) const; // low level handle *n like(ApiErrDS); end-pr; dcl-s QsnCursorRow int(10); dcl-s QsnCursorCol int(10); /endif /If defined(Qspclosp) //--------------------------------------------------------- // Close Spooled File dcl-pr Qspclosp extpgm('QSPCLOSP'); *n int(10); // splf handle *n like(ApiErrDS); end-pr; /endif /If defined(Qspgetsp) //--------------------------------------------------------- // Get Spooled File Data dcl-pr Qspgetsp extpgm('QSPGETSP'); *n int(10); // splf handle *n char(20); // user space *n char(8) const; // api format *n int(10); // ordinal number *n char(10) const; // end of open *n like(ApiErrDS); end-pr; /endif /If defined(Qspopnsp) //--------------------------------------------------------- // Open Spooled File dcl-pr Qspopnsp extpgm('QSPOPNSP'); *n int(10); // splf handle *n char(26) const; // qualified job *n char(16); // internal job id *n char(16); // internal spool num *n char(10) const; // spool file name *n int(10) const; // spool file num *n int(10) const; // number of buffers *n like(ApiErrDS); end-pr; /endif /If defined(Quscmdln) //--------------------------------------------------------- // Display Command Line Window dcl-pr Quscmdln extpgm('QUSCMDLN') end-pr; /endif /If defined(ListAuthorizedUsers) //--------------------------------------------------------- // List Authorized Users dcl-pr qsylautu extpgm('QSYLAUTU'); *n char(20); // user space *n char(8) const; // format *n like(ApiErrDS); end-pr; dcl-ds Autu0200DS based(Autu0200ptr); UsrPrf char(10) pos(1); UsrPrfTxt char(50) pos(21); end-ds; // Retrieve User Information dcl-pr qsyrusri extpgm('QSYRUSRI'); *n char(309); // user profile info *n int(10) const; // receiver len *n char(8) const; // format *n char(10); // user profile *n like(ApiErrDS); end-pr; dcl-ds Usri0300DS qualified inz; BytesProvided int(10) pos(1); BytesReturned int(10) pos(5); PrvSignDatTim char(13) pos(19); Status char(10) pos(37); UserClass char(7) pos(74); SpecialAuth char(15) pos(84); AllObj char(1) overlay(SpecialAuth:1); Secadm char(1) overlay(SpecialAuth:2); JobCtl char(1) overlay(SpecialAuth:3); SplCtl char(1) overlay(SpecialAuth:4); SavSys char(1) overlay(SpecialAuth:5); Service char(1) overlay(SpecialAuth:6); Audit char(1) overlay(SpecialAuth:7); IoSysCfg char(1) overlay(SpecialAuth:8); SpecialAuthArry char(1) samepos(SpecialAuth) dim(8); InitialPgm char(10) pos(169); InitialPgmL char(10) pos(179); Text char(50) pos(199); Jobd char(10) pos(290); JobdL char(10) pos(300); Outq char(10) pos(361); OutqL char(10) pos(371); HomeDirectoryOffset int(10) pos(601); HomeDirectoryLength int(10) pos(605); test11 char(300) pos(722); AllowLengthForHomeDirectory char(1) pos(1024); end-ds; /endif /If defined(Qwclobjl) //--------------------------------------------------------- // List Object Locks dcl-pr Qwclobjl extpgm('QWCLOBJL'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // object and lib *n char(10); // object type *n char(10) const; // mbr *n like(ApiErrDS); end-pr; dcl-ds QwclobjlDS qualified based(QwclobjlPtr); JobName char(10) pos(1); JobUser char(10) pos(11); JobNumb char(6) pos(21); LockState char(10) pos(27); LockStatus int(10) pos(37); LockType int(10) pos(41); MbrName char(10) pos(45); Share char(1) pos(55); LockScope char(1) pos(56); ThreadID char(8) pos(57); end-ds; /endif /If defined(Quslfld) //--------------------------------------------------------- // List Fields dcl-pr Quslfld extpgm('QUSLFLD'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // file and lib *n char(10) const; // record format *n char(1) const; // overrides *n like(ApiErrDS); end-pr; dcl-ds QuslfldDS qualified based(QuslfldPtr); FieldName char(10) pos(1); FieldType char(1) pos(11); OutputPosition int(10) pos(13); InputPosition int(10) pos(17); FieldLengthA int(10) pos(21); Digits int(10) pos(25); DecimalPos int(10) pos(29); FieldText char(50) pos(33); AlternativeFieldName char(30) pos(223); FieldCCSID int(10) pos(273); ScreenFieldRow int(10) pos(449); ScreenFieldCol int(10) pos(453); end-ds; /endif /If defined(Quslmbr) //--------------------------------------------------------- // List Database File Members dcl-pr Quslmbr extpgm('QUSLMBR'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // file and lib *n char(10) const; // mbr *n char(1) const; // override *n like(ApiErrDS); end-pr; dcl-ds QuslmbrDS qualified based(QuslmbrPtr); MbrName char(10) pos(1); MbrType char(10) pos(11); CreateDateTime char(13) pos(21); ChangeDateTime char(13) pos(34); Text char(50) pos(47); end-ds; /endif /If defined(Quslobj) //--------------------------------------------------------- // List Objects dcl-pr Quslobj extpgm('QUSLOBJ'); *n char(20); // user space *n char(8) const; // api format *n char(20) const; // object and lib *n char(10) const; // object type *n like(ApiErrDS); end-pr; dcl-ds QuslobjDS qualified based(QuslobjPtr); ObjNam char(10) pos(1); ObjLib char(10) pos(11); ObjTyp char(10) pos(21); ExtendedAttr char(10) pos(32); ObjText char(50) pos(42); CreateStamp char(8) pos(125); CreatedByUser char(10) pos(216); LastUseStamp char(8) pos(533); NumDaysUsed int(10) pos(549); ObjSize int(10) pos(577); MultiplySize int(10) pos(581); end-ds; /endif /If defined(Quslspl) //--------------------------------------------------------- // List Spooled Files dcl-pr Quslspl extpgm('QUSLSPL'); *n char(20); // user space *n char(8) const; // api format *n char(10) const; // user profile *n char(20); // outq and lib *n char(10) const; // form type *n char(10) const; // user data *n like(ApiErrDS); end-pr; dcl-ds QuslsplDS qualified based(QuslsplPtr); InternalJobID char(16) pos(51); InternalSplfID char(16) pos(67); end-ds; dcl-ds splf0300DS qualified based(splf0300Ptr); JobName char(10) pos(1); UserID char(10) pos(11); JobNo char(6) pos(21); SplfName char(10) pos(27); SplfNum int(10) pos(37); Status int(10) pos(41); CreateYYMMDD char(6) pos(46); CreateHHMMSS char(6) pos(52); UsrDta char(10) pos(69); FormType char(10) pos(79); Outq char(10) pos(89); OutqLib char(10) pos(99); ASP int(10) pos(109); SplfSize int(10) pos(113); MultiplySize int(10) pos(117); PageNum int(10) pos(121); Copies int(10) pos(125); Priority char(1) pos(129); end-ds; /endif /If defined(Qusptrus) //--------------------------------------------------------- // Retrieve Pointer to User Space dcl-pr Qusptrus extpgm('QUSPTRUS'); *n char(20); // user space *n pointer; // pointer *n like(ApiErrDS); end-pr; /endif /If defined(Qusrusat) //--------------------------------------------------------- // Retrieve User Space Attributes dcl-pr Qusrusat extpgm('QUSRUSAT'); *n like(QusrusatDS); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20); // user space *n like(ApiErrDS); end-pr; dcl-ds QusrusatDS qualified inz; BytesReturned int(10) pos(1); BytesAvailable int(10) pos(5); SpaceSize int(10) pos(9); Extendability char(1) pos(13); InitialValue char(1) pos(14); SpaceLibrary char(10) pos(15); end-ds; /endif /If defined(f_ZipIFS) //--------------------------------------------------------- // zip files on the IFS drive dcl-pr f_ZipIFS; *n char(10); // file *n char(10); // attribute *n char(50); // ifs path end-pr; /endif /If defined(psds) //--------------------------------------------------------- dcl-ds *n PSDS; progid char(10) pos(1); scSystem char(8) pos(396); end-ds; /endif /If defined(BitMask) //--------------------------------------------------------- dcl-c bit0 const(x'80'); // 10000000 dcl-c bit1 const(x'40'); // 01000000 dcl-c bit2 const(x'20'); // 00100000 dcl-c bit3 const(x'10'); // 00010000 dcl-c bit4 const(x'08'); // 00001000 dcl-c bit5 const(x'04'); // 00000100 dcl-c bit6 const(x'02'); // 00000010 dcl-c bit7 const(x'01'); // 00000001 /endif /If defined(SrcDS) //--------------------------------------------------------- // Define fields from different spec types dcl-ds SrcDS qualified inz; SeqNum6 zoned(6: 2) pos(1); CompileArray char(3) pos(13); SpecType char(1) pos(18); Asterisk char(1) pos(19); SlashComment char(2) pos(19); FreeForm char(9) pos(19); Src80 char(74) pos(19); Src112 char(100) pos(13); // C specs Conditioning char(2) pos(22); Factor1 char(14) pos(24); OpCode char(10) pos(38); Factor2 char(14) pos(48); ExtendFactor2 char(45) samepos(Factor2); ResultField char(14) pos(62); ResultingInd char(6) pos(83); HIind char(2) overlay(ResultingInd:1); LOind char(2) overlay(ResultingInd:3); EQind char(2) overlay(ResultingInd:5); SrcComment char(20) pos(93); // 0 specs Commentln char(73) pos(20); oAndOr char(4) pos(28); oLineType char(1) pos(29); oIndicator char(9) pos(33); oSpaceB char(1) pos(54); oSpaceA char(1) pos(57); oSkipB char(2) pos(59); oSkipA char(2) pos(62); oEname char(14) pos(42); oEditCode char(1) pos(56); oEndPos char(5) pos(59); oEndPosN zoned(5) pos(59); oConstant char(28) pos(65); Src63 char(63) pos(13); UpperCase char(51) pos(13); // DDS specs ddsCondIn1 char(2) pos(21); ddsCondIn2 char(2) pos(24); ddsCondIn3 char(2) pos(27); ddsParenthesis char(1) pos(61); ddsField char(12) pos(57); ddsField2 char(2) samepos(ddsField); ddsField4 char(4) samepos(ddsField); ddsField5 char(5) samepos(ddsField); ddsField6 char(6) samepos(ddsField); ddsField7 char(7) samepos(ddsField); ddsField9 char(9) samepos(ddsField); ddsField10 char(10) samepos(ddsField); end-ds; /endif /If defined(OpenCloseDir) //--------------------------------------------------------- dcl-s pDir pointer; dcl-pr opendir pointer extproc(*dclcase); *n pointer value options(*string); end-pr; dcl-pr closedir int(10) extproc(*dclcase); *n pointer value; end-pr; dcl-pr readdir pointer extproc(*dclcase); *n pointer value; end-pr; dcl-pr stat int(10) extproc(*dclcase); *n pointer value options(*string); *n pointer value; end-pr; dcl-pr tmpnam pointer extproc(*dclcase); *n pointer value; end-pr; /endif //--------------------------------------------------------- /If defined(f_CheckDir) dcl-pr f_CheckDir; *n char(50); end-pr; /endif /If defined(f_CrtCmdString) //--------------------------------------------------------- dcl-pr f_CrtCmdString varchar(500); *n char(20) const; // cmd name and lib end-pr; /endif /If defined(f_ConvertCcsid) //--------------------------------------------------------- dcl-pr f_ConvertCcsid char(1024); *n char(1024) const; // unknown ccsid path namecmd name and lib end-pr; /endif /If defined(f_BuildString) //--------------------------------------------------------- dcl-pr f_BuildString varchar(2048); *n varchar(2048) const; *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); *n varchar(100) const options(*nopass:*trim); end-pr; /endif /If defined(f_CamelCase) //--------------------------------------------------------- dcl-pr f_CamelCase char(50); *n char(50); end-pr; /endif /If defined(f_Centertext) //--------------------------------------------------------- dcl-pr f_CenterText char(100) opdesc; *n char(100) const options(*varsize); *n uns(3) const options(*nopass); end-pr; /endif /If defined(f_CheckMbr) //--------------------------------------------------------- dcl-pr f_CheckMbr; *n char(20) const; // file and lib *n char(10) const; // mbr end-pr; /endif /If defined(f_CheckObj) //--------------------------------------------------------- // validate Object exists dcl-pr f_CheckObj; *n char(20) const; // object and lib *n char(10) const; // object type end-pr; /endif /If defined(f_GetDayName) //--------------------------------------------------------- dcl-pr f_GetDayName char(9); *n date const options(*nopass); end-pr; /endif /If defined(f_DecodeApiTimeStamp) //--------------------------------------------------------- dcl-pr f_DecodeApiTimeStamp char(16); *n char(8); end-pr; dcl-ds ApistampDS len(16) qualified inz; Century char(1) pos(1); // 0=19 1=20 MmDd char(4) pos(2); Yy char(2) pos(6); HhMmSs char(8) pos(8); end-ds; /endif /If defined(f_GetEmail) //--------------------------------------------------------- dcl-pr f_GetEmail char(150); *n char(10) const options(*nopass); // user profile end-pr; /endif /If defined(usleep) //--------------------------------------------------------- // delay job up to 999999 milliseconds ~= 1 second dcl-pr usleep uns(10) extproc(*dclcase); *n uns(10) value; // milliseconds end-pr; // delay job number of seconds dcl-pr sleep uns(10) extproc(*dclcase); *n uns(10) value; // seconds end-pr; /endif /If defined(f_DltOvr) //--------------------------------------------------------- dcl-pr f_DltOvr; *n char(10) const; // spooled file end-pr; /endif /If defined(f_DisplayLastSplf) //--------------------------------------------------------- dcl-pr f_DisplayLastSplf; *n char(10) const; // program name *n char(8) const; // * or *PRINT end-pr; /endif /If defined(f_RunOptionFile) //--------------------------------------------------------- dcl-pr f_RunOptionFile; *n packed(1) const; // option *n char(10) const; // file *n char(10) const; // lib *n char(10) const; // record format *n char(10) const; // member *n char(10); // program id end-pr; /endif /If defined(f_RunOptionJob) //--------------------------------------------------------- dcl-pr f_RunOptionJob; *n packed(2); // option *n char(10); // job name *n char(10); // User Name *n char(6); // job number *n char(10); // program id end-pr; /endif /If defined(f_RunOptionSplf) //--------------------------------------------------------- dcl-pr f_RunOptionSplf; *n char(1); // option *n char(10); // spool file name *n char(6) const; // spool file number *n char(10); // job name *n char(10); // User Name *n char(6); // job number *n char(10); // program id end-pr; /endif /If defined(f_BuildEditWord) //--------------------------------------------------------- dcl-pr f_BuildEditWord char(28); *n char(28) const; *n char(1) const; // date or time end-pr; /endif /If defined(f_GetCardFace) //--------------------------------------------------------- dcl-pr f_GetCardFace char(2); *n uns(3); end-pr; /endif /If defined(f_GetCardColor) //--------------------------------------------------------- dcl-pr f_GetCardColor char(1); *n char(1); end-pr; /endif /If defined(f_GetRowColumn) //--------------------------------------------------------- dcl-pr f_GetRowColumn char(6); *n char(10) const; // field *n char(10); // file *n char(10); // lib *n char(10); // record format end-pr; dcl-ds CsrRowColDS; CsrRow zoned(3) inz; CsrCol zoned(3) inz; end-ds; /endif /If defined(f_GetApiISO) //--------------------------------------------------------- dcl-pr f_GetApiISO char(10); // return ISO from api *n char(13) const; end-pr; /endif /If defined(f_GetFileLevelID) //--------------------------------------------------------- dcl-pr f_GetFileLevelID char(13); *n char(20) const; // file lib *n char(10) const options(*nopass); // rcdfmt end-pr; /endif /If defined(f_GetFileUtil) //--------------------------------------------------------- dcl-pr f_GetFileUtil char(6) end-pr; // dbu or dfu or wrkdbf /endif /If defined(f_GetQual) //--------------------------------------------------------- dcl-pr f_GetQual varchar(21); *n char(20) const; // name and lib end-pr; dcl-s ExtIfile varchar(21); dcl-s ExtOFile varchar(21); /endif /If defined(f_GetRandom) //--------------------------------------------------------- dcl-pr f_GetRandom uns(3); *n uns(3) const; // upper limit value end-pr; /endif /If defined(f_GetApiHMS) //--------------------------------------------------------- dcl-pr f_GetApiHMS char(8); // from 13 digit api *n char(13); end-pr; /endif /If defined(f_IsSameMbr) //--------------------------------------------------------- dcl-pr f_IsSameMbr ind; *n char(20) const; // input file lib *n char(10) const; // input mbr *n char(20) const; // output file lib *n char(10) const; // output mbr end-pr; /endif /If defined(f_IsValidMbr) //--------------------------------------------------------- dcl-pr f_IsValidMbr ind; *n char(20) const; // file lib *n char(10) const options(*nopass); // mbr end-pr; /endif /If defined(f_IsValidSrcType) //--------------------------------------------------------- dcl-pr f_IsValidSrcType ind; *n char(20); // file and lib *n char(10) const; // mbr *n char(10) const; // mbr type 1 *n char(10) const options(*nopass); // mbr type 2 *n char(10) const options(*nopass); // mbr type 3 *n char(10) const options(*nopass); // mbr type 4 end-pr; /endif /If defined(f_IsValidObj) //--------------------------------------------------------- dcl-pr f_IsValidObj ind; *n char(10) const; // object *n char(10) const; // library *n char(10) const; // object type end-pr; /endif /If defined(f_SrcFileAddPfm) //--------------------------------------------------------- dcl-pr f_SrcFileAddPfm; *n char(20) const; // new file qual *n char(10) const; // new mbr *n char(8) const; // mbr type *n char(50) const options(*nopass); // mbr text *n char(20) const options(*nopass); // org file qual *n char(10) const options(*nopass); // org mbr end-pr; /endif /If defined(f_OutFileCrtDupObj) //--------------------------------------------------------- dcl-pr f_OutFileCrtDupObj; *n char(20) const; // out file and lib *n char(22) const; // mbr options *n char(10) const; // from object end-pr; /endif /If defined(f_OvrPrtf) //--------------------------------------------------------- dcl-pr f_OvrPrtf; *n char(10) const; // spooled file *n char(20) const; // outq *n char(10) const; // usrdta end-pr; /endif /If defined(f_PromptOverrideGetSource) //--------------------------------------------------------- dcl-pr f_PromptOverrideGetSource char(5700); *n char(20); end-pr; /endif /If defined(f_Quscrtus) //--------------------------------------------------------- dcl-pr f_Quscrtus pointer; *n char(20); // user space name and library end-pr; // Get user space list info from header dcl-ds GenericHeader qualified template; JobScheduleEntry char(10) pos(10); ContinuationHandle char(16) pos(11); InformationStatus char(1) pos(104); // P=Partail SizeOfUsrSpc int(10) pos(105); OffSetToHeader int(10) pos(117); OffSetToList int(10) pos(125); ListEntryCount int(10) pos(133); ListEntrySize int(10) pos(137); end-ds; // define 2 user space headers since needed in many programs dcl-ds ApiHead likeds(GenericHeader) based(ApiHeadPtr); dcl-ds ApiHead2 likeds(GenericHeader) based(ApiHeadPtr2); dcl-s UserSpaceName char(20) inz('JCRCMDS QTEMP'); dcl-s UserSpaceName2 char(20) inz('JCRCMDS2 QTEMP'); dcl-s ForCount int(10); dcl-s ForCount2 int(10); /endif /If defined(f_Qmhrcvpm) //--------------------------------------------------------- dcl-pr f_Qmhrcvpm char(75); // receive program msg *n int(10) const; // call stack counter end-pr; /endif /If defined(f_Qusrmbrd) //--------------------------------------------------------- dcl-pr f_Qusrmbrd char(256); // retrieve mbr desc *n char(20) const; // file and lib *n char(10) const; // mbr *n char(8) const; // api format end-pr; dcl-ds QusrmbrdDS len(256) qualified inz; File char(10) pos(9); Lib char(10) pos(19); Mbr char(10) pos(29); Attribute char(10) pos(39); MbrType char(10) pos(49); CreateDateTime char(13) pos(59); Text char(50) pos(85); IsSrcPF ind pos(135); CurrNumberRecs int(10) pos(141); DeletedRecs int(10) pos(145); SizeOfData int(10) pos(149); ChangeDateTime char(13) pos(161); SaveDateTime char(13) pos(174); LastUseCount int(10) pos(213); LastUseDateTime char(13) pos(217); SizeOfDataMLT int(10) pos(233); end-ds QusrmbrdDS; /endif /If defined(f_Qusrobjd) //--------------------------------------------------------- dcl-pr f_Qusrobjd char(480); // retrieve object desc *n char(20) const; // object and lib *n char(10) const; // oblect type *n char(8) const options(*nopass); // api format end-pr; dcl-ds QusrObjDS qualified inz; ObjNam char(10) pos(9); Lib char(10) pos(19); Type char(10) pos(29); ReturnLib char(10) pos(39); ExtendedAttr char(10) pos(91); CreateDateTime char(13) pos(65); ChangeDateTime char(13) pos(78); Text char(50) pos(101); SrcFile char(10) pos(151); SrcLib char(10) pos(161); SrcMbr char(10) pos(171); SaveDateTime char(13) pos(194); RestoreDateTime char(13) pos(207); CreatedByUser char(10) pos(220); LastUsedDate char(7) pos(461); // cyymmdd format NumDaysUsed int(10) pos(469); ObjSize int(10) pos(473); MultiplySize int(10) pos(477); end-ds; /endif /If defined(f_RmvSflMsg) //--------------------------------------------------------- dcl-pr f_RmvSflMsg; *n char(10) const; // program name end-pr; /endif /If defined(f_RtvMsgAPI) //--------------------------------------------------------- dcl-pr f_RtvMsgAPI char(232); // retrieve message api wrapper *n char(7) const; // message id *n char(112); // replace values *n char(20) const options(*nopass); // msg file qual end-pr; /endif /If defined(f_ShuffleDeck) //--------------------------------------------------------- dcl-pr f_ShuffleDeck char(2) dim(52) end-pr; /endif /If defined(f_SndCompMsg) //--------------------------------------------------------- dcl-pr f_SndCompMsg; //send completion message *n char(75) const; end-pr; /endif /If defined(f_SndEscapeMsg) //--------------------------------------------------------- dcl-pr f_SndEscapeMsg; //send error message *n char(75) value; end-pr; /endif // /If defined(f_SndSflMsg) //--------------------------------------------------------- //dcl-pr f_SndSflMsg; // *n char(10) const; // program name // *n char(75) const; // msg text // *n char(7) const options(*nopass); // msg id // *n char(10) const options(*nopass); // msg file // *n char(10) const options(*nopass); // msg lib //end-pr; ///endif /If defined(f_SndStatMsg) //--------------------------------------------------------- dcl-pr f_SndStatMsg; *n char(75) const; // message text end-pr; /endif /If defined(f_RunCmd) //--------------------------------------------------------- dcl-pr f_RunCmd; // run commands *n varchar(2048) const options(*trim); end-pr; /endif /If defined(f_BlankCommentsCL) //--------------------------------------------------------- dcl-pr f_BlankCommentsCL char(100); *n char(100) const; end-pr; /endif /If defined(CEEDAYS) //--------------------------------------------------------- // Convert Date to Lilian Format dcl-pr CEEDAYS extproc(*dclcase) opdesc; *n char(8) const; // iso *n char(8) const; // Picture *n int(10); // lilian date *n char(12) const options(*omit); end-pr; dcl-s Pic char(8) inz('YYYYMMDD'); dcl-s Lilian int(10); /endif /If defined(p_JCRBNDR) //--*entry------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_ObjTyp char(10); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRCALLR) //--*entry------------------------------------------------- dcl-pi *n; p_PgmQual char(20); p_SrcFil char(10); p_SrcLib char(10); p_SrcMbr char(10); p_Pgmatr char(10); end-pi; /endif /If defined(p_JCRFFDR) //--*entry------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_RcdFmt char(10); p_UnPack char(4); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRFSETS) //--*entry------------------------------------------------- dcl-pi *n; p_DtaFileQual char(20); p_SrcFiles char(398); p_LfSameLib char(4); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRSCDER) //--*entry------------------------------------------------- dcl-pi *n; p_jobname char(10); p_cmd char(20); p_Output char(8); p_OutqQual char(20); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRSMLTRS) //--*entry------------------------------------------------- dcl-pi *n; p_ScanStrings char(272); p_Case char(4); p_IfContains char(7); p_SrcFiles char(398); p_QuickScan char(1); p_Listlvl char(6); p_ScanComment char(5); p_From packed(3); p_To packed(3); p_Output char(8); p_OutqQual char(20); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRGETFLDR) //--------------------------------------------------------- dcl-pr p_JCRGETFLDR extpgm('JCRGETFLDR'); *n char(20) const; // src file and lib *n char(10); // src mbr *n char(2); // severity *n packed(3); // parm count end-pr; dcl-s DiagSeverity char(2); /endif /If defined(p_JCRGETFILR) //--retrieve file names from source member----------------- dcl-pr p_JCRGETFILR extpgm('JCRGETFILR'); *n char(10); *n char(20); *n like(FileCount); *n like(OnePerRcdFmt) dim(%elem(OnePerRcdFmt)); *n like(FspecArry) dim(%elem(FspecArry)); *n like(CommentArry) dim(%elem(CommentArry)); // 93-112 comments *n like(PrNameArry) dim(%elem(PrNameArry)); *n like(DeleteArry) dim(%elem(DeleteArry)); end-pr; dcl-s FileCount uns(5); dcl-s FspecArry char(512) dim(256); // one element per file dcl-s CommentArry char(20) dim(256); dcl-s PrNameArry char(74) dim(256); // JCRHFDR 1 to 1 with FspecArry dcl-s DeleteArry char(1) dim(256); // JCRHFDR 1 to 1 with FspecArry dcl-ds OnePerRcdFmt dim(256) qualified; FileCount uns(5); // corresponds to fSpec and Comment index File char(10); FileExt char(10); // extfile(name) Lib char(10); Format char(10); FormatReName char(10); BasedOnPF char(10); Usage char(1); FileAddition char(1); Text char(50); ProcName char(74); end-ds; /endif /If defined(p_JCRGETCLPR) //--------------------------------------------------------- dcl-pr p_JCRGETCLPR extpgm('JCRGETCLPR'); *n char(20) const; // src file and lib *n char(10); // src mbr *n char(2); // severity end-pr; /endif /If defined(p_JCRANZOR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_ShowNames char(4); p_Output char(8); end-pi; /endif /If defined(p_JCRPRGENR) //--*entry------------------------------------------------- dcl-pi *n; p_InsertInMbr char(10); p_InsertFileQual char(20); p_PgmQual char(20); p_SrcFil char(10); p_SrcLib char(10); p_SrcMbr char(10); p_Pgmatr char(10); end-pi; /endif /If defined(p_JCRIFSCPYR) //--*entry------------------------------------------------- dcl-pi *n; p_IfsDir char(50); end-pi; /endif /If defined(p_JCRIFSMBRR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFile char(10); p_SrcLib char(10); p_SrcAttr char(10); p_IfsDir char(50); p_CreateZip char(4); end-pi; /endif /If defined(p_JCRIFSSAVR) //--*entry------------------------------------------------- dcl-pi *n; p_Savf char(10); p_Lib char(10); p_IfsDir char(50); p_CreateZip char(4); end-pi; /endif /If defined(p_JCRINDR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbrs char(104); end-pi; /endif /If defined(p_JCRPRTFR) //--*entry------------------------------------------------- dcl-pi *n; p_RpgMbr char(10); p_RpgFileQual char(20); p_DDsMbr char(10); p_DDsFileQual char(20); p_RefFields char(4); end-pi; /endif /If defined(p_JCRLSRCR) //--*entry------------------------------------------------- dcl-pi *n; p_PgmQual char(20); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRRFLDR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRNETFFR) //--------------------------------------------------------- dcl-ds entlistds qualified template; Count uns(5); Arry char(10) dim(10); end-ds; dcl-ds entlistds2 qualified template; Count uns(5); MixedList char(118); end-ds; //--*entry------------------------------------------------- dcl-pi *n; p_Lib char(10); p_FileList likeds(entlistds); p_UsrList likeds(entlistds2); end-pi; /endif /If defined(p_JCRNETFMR) //--*entry------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_UsrList char(120); p_MbrList char(242); end-pi; /endif /If defined(p_JCRPATTRR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_CrtToLib char(10); p_LikePrtf char(20); end-pi; /endif /If defined(p_JCRRFILR) //--*entry------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); end-pi; /endif /If defined(p_JCRSPLFR) dcl-ds elemds template; Count uns(5); Usrprf char(10); UsrDta char(10); OutqQual char(20); SplfName char(10); Formtyp char(10); end-ds; //--*entry------------------------------------------------- dcl-pi *n; p likeds(elemds); end-pi; /endif /If defined(p_JCRUFINDR) //--*entry------------------------------------------------- dcl-pi *n; p_ScanSpaces char(20); p_ScanString1 char(25); p_Relations char(4); p_ScanString2 char(25); p_Output char(8); p_OutFileQual char(20); p_OutMbrOpt char(22); end-pi; /endif /If defined(p_JCRPROTOR) //--*entry------------------------------------------------- dcl-pi *n; p_InMbr char(10); p_InFileQual char(20); p_OutMbr char(10); p_OutFileQual char(20); end-pi; /endif /If defined(p_JCRHFDR) //--*entry------------------------------------------------- dcl-pi *n; p_InMbr char(10); p_InFileQual char(20); p_OutMbr char(10); p_OutFileQual char(20); end-pi; /endif /If defined(p_JCRDDLR) //--*entry------------------------------------------------- dcl-pi *n; p_InFileQual char(20); p_ObjTyp char(10); p_OutMbr char(10); p_OutFileQual char(20); end-pi; /endif /If defined(p_JCR5FREER) //--*entry------------------------------------------------- dcl-pi *n; p_InMbr char(10); p_InFileQual char(20); p_OutMbr char(10); p_OutFileQual char(20); end-pi; /endif /If defined(p_XMLGENR) //--*entry------------------------------------------------- dcl-pi *n; p_ScriptMbr char(10); p_ScriptQual char(20); p_OutFileQual char(20); end-pi; /endif /If defined(p_XMLSRCFILR) //--*entry------------------------------------------------- dcl-pi *n; p_InFileQual char(20); p_OutFileQual char(20); end-pi; /endif /If defined(f_IsIgnoreLine) //--------------------------------------------------------- dcl-pr f_IsIgnoreLine ind; *n varchar(94); end-pr; /endif /If defined(f_ReturnZeroIfBetweenQuotes) //--------------------------------------------------------- dcl-pr f_ReturnZeroIfBetweenQuotes uns(3); *n uns(3); *n varchar(94); end-pr; /endif /If defined(f_ReturnZeroIfAfterComments) //--------------------------------------------------------- dcl-pr f_ReturnZeroIfAfterComments uns(3); *n uns(3); *n varchar(94); end-pr; /endif /If defined(f_CheckSameLineEnd) //--------------------------------------------------------- dcl-pr f_CheckSameLineEnd char(10); *n char(10); *n varchar(94); end-pr; /endif /If defined(f_IsCompileTimeArray) //--------------------------------------------------------- dcl-pr f_IsCompileTimeArray ind; *n char(3); end-pr; /endif /If defined(f_GetProcedureEntryPoint) //--------------------------------------------------------- dcl-pr f_GetProcedureEntryPoint char(6); *n char(1); *n varchar(94); end-pr; /endif /If defined(f_GetParmFieldsArryIndex) //--------------------------------------------------------- dcl-pr f_GetParmFieldsArryIndex uns(5); *n char(1); *n varchar(94); end-pr; /endif /If defined(f_GetDataTypeKeyWords) //--------------------------------------------------------- dcl-pr f_GetDataTypeKeyWords char(16); *n char(1); *n uns(10); *n char(2); *n varchar(37) options(*nopass); end-pr; /endif /If defined(SourceOutDS) //--------------------------------------------------------- dcl-ds OutDS qualified inz; SrcSeq zoned(6:2) pos(1) inz(0); SrcDate zoned(6) pos(7) inz(0); Src100 char(100) pos(13); SrcType char(1) pos(18); SrcCod char(74) pos(19); SrcCmt char(20) pos(93); end-ds; /endif /If defined(f_GetInternalProcNames) //--------------------------------------------------------- dcl-pr f_GetInternalProcNames char(37002); *n char(10); *n char(20) const; end-pr; /endif /If defined(f_EllipsisLoc) //--------------------------------------------------------- dcl-pr f_EllipsisLoc uns(3); *n char(74); end-pr; /endif /If defined(FspecDS) //--------------------------------------------------------- dcl-ds FspecDS qualified; FixedFormat char(37) pos(1); Name char(10) pos(1); FileType char(1) pos(11); Designation char(1) pos(12); FileAddition char(1) pos(14); FixedOrExt char(1) pos(16); RecordLength char(5) pos(17); LengthOfKeyedField char(5) pos(23); RecordAddressType char(1) pos(28); Device char(7) pos(30); KeyWords char(2048) pos(38); end-ds; /endif /If defined(p_JCRLONGFIL) //--------------------------------------------------------- dcl-pr p_JCRLONGFIL extpgm('JCRLONGFIL'); *n char(140); // p_filequal *n char(10); // p_outshortfil end-pr; /endif ]]> '); //--------------------------------------------------------- // JCRCMDSSRV - Service program for JCRCMDS //--------------------------------------------------------- // f_AddSortKey - concatenate sort key blocks for qlgsort // f_BuildString - build string with replacement values // f_BlankCommentsCL - CL source is easier to process if comments are blanked // f_CamelCase - upper case first letter of each word or following / ( or & // f_CenterText - return centered text for any length parm // f_CheckDir - check if IFS directory exists // f_CheckMbr - check if mbr exists // f_CheckObj - check if object exists // f_CrtCmdString - return command creation parameters in a string // f_ConvertCcsid - turn cartwheels to convert to default 37 ccsid // f_GetEmail - gets user email from directory entry // f_GetDayName - return day name // f_DecodeApiTimeStamp - accept API time stamp and return data structure // f_DltOvr - delete file overrides // f_DisplayLastSplf - displays last spooled file // f_BuildEditWord - return edit for date/time format printing // f_GetAllocatedSize - return 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_GetFileLevelID - return file level identifier // f_GetFileUtil - return DBU, PEEK, WRKDBF, or STRDFU data base utility name // f_GetQual - return lib/obj for 20 long input // f_GetRandom - return random number within range // f_IsValidMbr - return *on if member exists in file // f_IsSameMbr - return *on input file/lib/mbr same as output file/lib/mbr // f_IsValidSrcType - return *on if member type is a selected type // f_IsValidObj - return *on if object exists // f_SrcFileAddPfm - addpfm to select lib/file // f_OutFileCrtDupObj - validity check / create OutFiles // f_OvrPrtf - override prtf with outq and/or usrdta // f_PromptOverrideGetSource - return cmd prompt override command string // 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 - retrieve message with substitution values loaded // f_RunCmd - execute command with error monitoring // f_RunOptionFile - execute subfile options related to files // f_RunOptionJob - execute subfile options related to jobs // f_RunOptionSplf - execute subfile options related to Spooled Files // f_Qmhrcvpm - receive program messages // f_ShuffleDeck - return randomly shuffled 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_ZipIFS - execute QzipZip to zip IFS files // ----------------- // free format H,F,D functions // f_IsIgnoreLine - return *on if blank, comment or /define // f_GetProcedureEntryPoint // f_ReturnZeroIfAfterComments // f_ReturnZeroIfBetweenQuotes // f_GetParmFieldsArryIndex // f_GetDataTypeKeyWords // f_GetInternalProcNames // f_EllipsisLoc //--------------------------------------------------------- ctl-opt nomain datfmt(*iso) timfmt(*iso) expropts(*resdecpos) option(*nounref: *nodebugio) bnddir('QSYS/QUSAPIBD') STGMDL(*TERASPACE); /define DspAtr /define Qdbrtvfd /define Qmhsndpm /define Quslfld /define Qusptrus /define f_Qusrmbrd /define f_Qusrobjd /define f_Quscrtus /define Constants /define OpenCloseDir /define CEEDAYS /define Qbnlpgmi /define Qclrpgmi /COPY JCRCMDS,JCRCMDSCPY //--global data structures -------------------------------- dcl-ds ApiErrDS qualified export; BytesProvided int(10) pos(1) inz(%size(ApiErrDS)); BytesReturned int(10) pos(5) inz(0); ErrMsgId char(7) pos(9); MsgReplaceVal char(112) pos(17); end-ds; // Several utilities use common array to pass field attributes dcl-s FieldsArryCnt uns(10) export; dcl-ds FieldsArry len(192) dim(5000) qualified export; Name char(100); end-ds; //--------------------------------------------------------- // return character field with integer values for qlgsort key block. // If third and fourth parms are not passed, return character defaults. //--------------------------------------------------------- dcl-proc f_AddSortKey export; dcl-pi *n char(16); p_StartPos int(10) const; p_StringSize int(10) const; p_DataType int(10) const options(*nopass); p_SortOrder int(10) const options(*nopass); end-pi; dcl-ds KeyBlock len(16) qualified; aa int(10); bb int(10); cc int(10); dd int(10); end-ds; KeyBlock.aa = p_StartPos; keyBlock.bb = p_StringSize; 1b if %parms >= %parmnum(p_DataType); KeyBlock.cc = p_DataType; KeyBlock.dd = p_SortOrder; 1x else; KeyBlock.cc = 6; KeyBlock.dd = 1; 1e endif; return KeyBlock; end-proc; //--------------------------------------------------------- // CL source is easier to process if comments are blanked //--------------------------------------------------------- dcl-proc f_BlankCommentsCL export; dcl-pi *n char(100); LineCL char(100) const; end-pi; dcl-s IsPreviousLineEndedinPlus ind static; dcl-s IsBlanked ind; dcl-s IsComment ind; dcl-s aa int(5); dcl-s bb int(5); dcl-s Wrka char(100); 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-proc; //--------------------------------------------------------- // return 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. Check // ApiErrDs data structure if string was returned as error. //--------------------------------------------------------- dcl-proc f_BuildString export; dcl-pi *n varchar(2048); pString varchar(2048) const; pParm01 varchar(100) const options(*nopass:*trim); pParm02 varchar(100) const options(*nopass:*trim); pParm03 varchar(100) const options(*nopass:*trim); pParm04 varchar(100) const options(*nopass:*trim); pParm05 varchar(100) const options(*nopass:*trim); pParm06 varchar(100) const options(*nopass:*trim); pParm07 varchar(100) const options(*nopass:*trim); pParm08 varchar(100) const options(*nopass:*trim); pParm09 varchar(100) const options(*nopass:*trim); pParm10 varchar(100) const options(*nopass:*trim); pParm11 varchar(100) const options(*nopass:*trim); pParm12 varchar(100) const options(*nopass:*trim); pParm13 varchar(100) const options(*nopass:*trim); pParm14 varchar(100) const options(*nopass:*trim); pParm15 varchar(100) const options(*nopass:*trim); pParm16 varchar(100) const options(*nopass:*trim); pParm17 varchar(100) const options(*nopass:*trim); pParm18 varchar(100) const options(*nopass:*trim); pParm19 varchar(100) const options(*nopass:*trim); pParm20 varchar(100) const options(*nopass:*trim); pParm21 varchar(100) const options(*nopass:*trim); pParm22 varchar(100) const options(*nopass:*trim); pParm23 varchar(100) const options(*nopass:*trim); pParm24 varchar(100) const options(*nopass:*trim); pParm25 varchar(100) const options(*nopass:*trim); pParm26 varchar(100) const options(*nopass:*trim); pParm27 varchar(100) const options(*nopass:*trim); pParm28 varchar(100) const options(*nopass:*trim); pParm29 varchar(100) const options(*nopass:*trim); pParm30 varchar(100) const options(*nopass:*trim); end-pi; dcl-s xx uns(3); dcl-s ReplaceCount uns(3); dcl-s cc uns(5); dcl-s string varchar(2048); dcl-s ParmArry varchar(100) dim(30); dcl-s parmlen uns(3); ApiErrDS.BytesReturned = 0; string = %trimr(pString); // replace any quote place holders with actual quotes string = %scanrpl('&q':qs: string); string = %scanrpl('&Q':qs: string); // Load replacement value parms into array // so it is easier to process in the next step ReplaceCount = %parms - 1; 1b if ReplaceCount >= 1; ParmArry(1) = pParm01; 1e endif; 1b if ReplaceCount >= 2; ParmArry(2) = pParm02; 1e endif; 1b if ReplaceCount >= 3; ParmArry(3) = pParm03; 1e endif; 1b if ReplaceCount >= 4; ParmArry(4) = pParm04; 1e endif; 1b if ReplaceCount >= 5; ParmArry(5) = pParm05; 1e endif; 1b if ReplaceCount >= 6; ParmArry(6) = pParm06; 1e endif; 1b if ReplaceCount >= 7; ParmArry(7) = pParm07; 1e endif; 1b if ReplaceCount >= 8; ParmArry(8) = pParm08; 1e endif; 1b if ReplaceCount >= 9; ParmArry(9) = pParm09; 1e endif; 1b if ReplaceCount >= 10; ParmArry(10) = pParm10; 1e endif; 1b if ReplaceCount >= 11; ParmArry(11) = pParm11; 1e endif; 1b if ReplaceCount >= 12; ParmArry(12) = pParm12; 1e endif; 1b if ReplaceCount >= 13; ParmArry(13) = pParm13; 1e endif; 1b if ReplaceCount >= 14; ParmArry(14) = pParm14; 1e endif; 1b if ReplaceCount >= 15; ParmArry(15) = pParm15; 1e endif; 1b if ReplaceCount >= 16; ParmArry(16) = pParm16; 1e endif; 1b if ReplaceCount >= 17; ParmArry(17) = pParm17; 1e endif; 1b if ReplaceCount >= 18; ParmArry(18) = pParm18; 1e endif; 1b if ReplaceCount >= 19; ParmArry(19) = pParm19; 1e endif; 1b if ReplaceCount >= 20; ParmArry(20) = pParm20; 1e endif; 1b if ReplaceCount >= 21; ParmArry(21) = pParm21; 1e endif; 1b if ReplaceCount >= 22; ParmArry(22) = pParm22; 1e endif; 1b if ReplaceCount >= 23; ParmArry(23) = pParm23; 1e endif; 1b if ReplaceCount >= 24; ParmArry(24) = pParm24; 1e endif; 1b if ReplaceCount >= 25; ParmArry(25) = pParm25; 1e endif; 1b if ReplaceCount >= 26; ParmArry(26) = pParm26; 1e endif; 1b if ReplaceCount >= 27; ParmArry(27) = pParm27; 1e endif; 1b if ReplaceCount >= 28; ParmArry(28) = pParm28; 1e endif; 1b if ReplaceCount >= 29; ParmArry(29) = pParm29; 1e endif; 1b if ReplaceCount = 30; ParmArry(30) = pParm30; 1e endif; //--------------------------------------------------------- // Load all replacement values into string //--------------------------------------------------------- cc = %scan('&': string); 1b for xx = 1 to ReplaceCount; parmlen = %len(ParmArry(xx)); 2b if parmlen = 0; parmlen = 1; ParmArry(xx) = ' '; 2e endif; string=%replace(%subst(ParmArry(xx):1:ParmLen): string: cc: 1); // avoid cc being past length of varchar; 2b if xx < ReplaceCount; 3b monitor; cc = %scan('&': string: cc + ParmLen); 3x on-error; string = 'Too many replacement values specified.'; 3v leave; 3e endmon; 2e endif; 1e endfor; return string; end-proc; //---------------------------------------------------------- // upper case first letter of each word or following / ( or & //--------------------------------------------------------- dcl-proc f_CamelCase export; dcl-pi *n char(50); pstring char(50); end-pi; dcl-s string char(50); dcl-s nextcharptr pointer; dcl-s nextchar char(1) based(nextcharptr); dcl-s isfirst ind; dcl-s xx uns(3); string = pstring; nextcharptr = %addr(string) -1; 1b for xx = 1 to 50; nextcharptr += 1; 2b if nextchar in %list(' ': '(': '/': '-': '&'); isfirst = *on; 2e endif; 2b if xx = 1 or isfirst; 3b if not (nextchar in %list(' ': '(': '/': '-': '&')); isfirst = *off; nextchar = %upper(nextchar); 3e endif; 2x else; nextchar = %lower(nextchar); 2e endif; 1e endfor; return string; end-proc; //--------------------------------------------------------- // return centered text for any length Parm < 101 //--------------------------------------------------------- dcl-proc f_CenterText export; dcl-pi *n char(100) opdesc; p_String char(100) const options(*varsize); p_Length uns(3) const options(*nopass); end-pi; dcl-s xx uns(3); dcl-s centerstring char(100); // Get length of parameters dcl-pr CEEGSI extproc(*dclcase); *n int(10) const; // position *n int(10); // data type *n int(10); // parm length *n int(10); // max length *n char(12) options(*omit); // feedback end-pr; dcl-s MaxLen int(10); dcl-s DataType int(10); dcl-s ParmLen int(10); 1b if %parms = %parmnum(p_Length); ParmLen = p_Length; 1x else; CEEGSI(1: DataType: ParmLen: MaxLen: *omit); 1e endif; xx = %uns((ParmLen - %len(%trimr(%subst(p_String: 1: ParmLen)))) / 2) + 1; %subst(centerstring: xx) = %subst(p_String: 1: ParmLen); return centerstring; end-proc; //--------------------------------------------------------- // Send error messages for validity checking programs //--------------------------------------------------------- dcl-proc f_SndEscapeMsg export; dcl-pi *n; p_MsgTxt char(75) value; end-pi; p_MsgTxt = '0000' + p_MsgTxt; callp QMHSNDPM( 'CPD0006': 'QCPFMSG *LIBL': p_MsgTxt: %size(p_MsgTxt): '*DIAG': '*CTLBDY': 1: ' ': ApiErrDS); p_MsgTxt = *blanks; callp QMHSNDPM( 'CPF0002': 'QCPFMSG *LIBL': p_MsgTxt: %size(p_MsgTxt): '*ESCAPE': '*CTLBDY': 1: ' ': ApiErrDS); //snd-msg *escape %msg('CPF0002':'QCPFMSG':p_MsgTxt); return; end-proc; //--------------------------------------------------------- // Check if IFS directory exists. //--------------------------------------------------------- dcl-proc f_CheckDir export; dcl-pi *n; p_IfsDir char(50); end-pi; 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; return; end-proc; //--------------------------------------------------------- // Retrieve error message replacement values //--------------------------------------------------------- dcl-proc f_RtvMsgAPI export; dcl-pi *n char(232); p_ErrMsgID char(7) const; p_MsgReplace char(112); p_MsgFileQual char(20) const options(*nopass); end-pi; dcl-s mMsgf char(20); dcl-s mMsgLen int(10) inz(%len(qmhrtvmds)); dcl-ds ApiErrDS qualified; BytesProvided int(10) pos(1) inz(%size(ApiErrDS)); BytesReturned int(10) pos(5) inz(0); ErrMsgId char(7) pos(9); MsgReplaceVal char(112) pos(17); end-ds; dcl-ds QmhrtvmDS qualified inz; MessageRtvLen int(10) pos(9); MessageRtv char(232) pos(25); end-ds; dcl-pr Qmhrtvm extpgm('QMHRTVM'); // retrieve messages *n char(256); // message retrieved *n int(10); // length Of message *n char(8) const; // api format *n char(7) const; // message indentifier *n char(20) const; // msgf and lib *n char(100) const; // replacement data *n int(10) const; // replace data length *n char(10) const; // substitution char *n char(10) const; // format control char *n like(ApiErrDS); end-pr; 1b if %parms = %parmnum(p_MsgFileQual); mMsgf = p_MsgFileQual; 1x else; mMsgf = 'QCPFMSG *LIBL'; 2b if %subst(p_ErrMsgID: 1: 2) = 'RN'; mMsgf = 'QRPGLEMSG QDEVTOOLS'; 2e endif; 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; // 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-proc; //--------------------------------------------------------- // return member description //--------------------------------------------------------- dcl-proc f_Qusrmbrd export; dcl-pi *n char(256); p_FileQual char(20) const; p_Mbr char(10) const; p_ApiFormat char(8) const; end-pi; dcl-pr Qusrmbrd extpgm('QUSRMBRD'); // retrieve mbr desc api *n char(256) options(*varsize); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // file and lib *n char(10) const; // mbr *n char(1) const; // overrides *n like(ApiErrDS); end-pr; callp Qusrmbrd( QusrmbrdDS: 256: p_ApiFormat: p_FileQual: p_Mbr: '0': ApiErrDS); return QusrmbrdDS; end-proc; //--------------------------------------------------------- // Check if member exists. If not, pull in // substitution variables and send escape message //--------------------------------------------------------- dcl-proc f_CheckMbr export; dcl-pi *n; p_FileQual char(20) const; p_Mbr char(10) const; end-pi; f_Qusrmbrd(p_FileQual: p_Mbr: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId +': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; return; end-proc; //--------------------------------------------------------- // Execute Qusrobjd API, included in copy is DS to extract values. // If format not passed, default OBJD0200. //--------------------------------------------------------- dcl-proc f_Qusrobjd export; dcl-pi *n char(480); p_ObjQual char(20) const; p_ObjTyp char(10) const; p_ApiFormat char(8) const options(*nopass); end-pi; dcl-s LocalApiFormat char(8); dcl-pr Qusrobjd extpgm('QUSROBJD'); // object description *n char(472) options(*varsize); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // object and lib *n char(10) const; // object type *n like(ApiErrDS); end-pr; 1b if %parms = %parmnum(p_ApiFormat); LocalApiFormat = p_ApiFormat; 1x else; LocalApiFormat = 'OBJD0200'; 1e endif; callp QUSROBJD( QusrobjDS: %len(QusrobjDS): LocalApiFormat: p_ObjQual: p_ObjTyp: ApiErrDS); return QUSROBJDS; end-proc; //--------------------------------------------------------- // Check if object exists. //--------------------------------------------------------- dcl-proc f_CheckObj export; dcl-pi *n; p_ObjQual char(20) const; p_ObjTyp char(10) const; end-pi; 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-proc; //--------------------------------------------------------- //--------------------------------------------------------- dcl-proc f_ReturnZeroIfBetweenQuotes export; dcl-pi *n uns(3); TestPos uns(3); string varchar(94); end-pi; dcl-s QuotePos1 uns(3); dcl-s QuotePos2 uns(3); dcl-s aa uns(3); 1b if TestPos = 0; return TestPos; 1e endif; // Find position of Quotes (if any) QuotePos2 = 0; QuotePos1 = %scan(qs: string); 1b if QuotePos1 > 0; QuotePos2 = %scan(qs: string: QuotePos1 + 1); // also return 0 if quote then end continuation character 2b if not f_IsIgnoreLine(string); // skip comments aa = %len(string); 3b if aa > 0; 4b if %subst(string: aa: 1) in %list('+': '-'); QuotePos2 = aa; 4e endif; 3e endif; 2e endif; 1e endif; 1b if QuotePos2 > 0 and TestPos > QuotePos1 and TestPos < QuotePos2; return 0; 1x else; return TestPos; 1e endif; end-proc; //--------------------------------------------------------- //--------------------------------------------------------- dcl-proc f_ReturnZeroIfAfterComments export; dcl-pi *n uns(3); TestPos uns(3); string varchar(94); end-pi; dcl-s SlashSlash uns(3); 1b if TestPos = 0; return TestPos; 1e endif; SlashSlash = %scan(' //':string); SlashSlash = f_ReturnZeroIfBetweenQuotes(SlashSlash:String); 1b if SlashSlash = 0; SlashSlash = 100; 1e endif; 1b if SlashSlash < TestPos; return 0; 1x else; return TestPos; 1e endif; end-proc; //--------------------------------------------------------- // check for END-on same line as DCL-(see entry spec of JCRGMBLJ) // the LIKEDS or LIKEREC does not need END-DS //--------------------------------------------------------- dcl-proc f_CheckSameLineEnd export; dcl-pi *n char(10); Opcode char(10); string varchar(94); end-pi; dcl-s xx uns(3); 1b if Opcode in %list('DCL-DS': 'DCL-PI': 'DCL-PR'); xx = %scan('END-':string); 2b if xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0; return *blanks; 2e endif; 1e endif; // the LIKEDS or LIKEREC do not need END-DS 1b if Opcode = 'DCL-DS'; xx = %scan('LIKEDS':string); 2b if xx = 0; xx = %scan('LIKEREC':string); 2e endif; 2b if xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0; return *blanks; 2e endif; 1e endif; return opcode; end-proc; //--------------------------------------------------------- // return LIB/OBJ for 'OBJ LIB ' passed in //--------------------------------------------------------- dcl-proc f_GetQual export; dcl-pi *n varchar(21); p_String char(20) const; end-pi; return %trimr(%subst(p_String: 11: 10)) + '/' + %trimr(%subst(p_String: 1: 10)); end-proc; //--------------------------------------------------------- // Build command string to create command. //--------------------------------------------------------- dcl-proc f_CrtCmdString export; dcl-pi *n varchar(500); p_CmdQual char(20) const; end-pi; dcl-s string varchar(500); dcl-s LimitUser char(10) inz('YES'); dcl-pr Qcdrcmdi extpgm('QCDRCMDI'); // command definitions *n like(qcdrcmdiDS); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // file and lib *n like(ApiErrDS); end-pr; // extracted command definition fields dcl-ds qcdrcmdiDS len(400) qualified; Cmd char(10) pos(9); Cmdlib char(10) pos(19); Cpgm char(10) pos(29); Clib char(10) pos(39); Sfile char(10) pos(49); Slib char(10) pos(59); Smbr char(10) pos(69); Vpgm char(10) pos(79); Vlib char(10) pos(89); Mode char(3) pos(99); ModeProd char(1) pos(99); ModeDebug char(1) pos(100); ModeService char(1) pos(101); Alw char(9) pos(109); AlwBpgm char(1) pos(109); AlwIpgm char(1) pos(110); AlwExec char(1) pos(111); AlwInteract char(1) pos(112); AlwBatch char(1) pos(113); AlwBrexx char(1) pos(114); AlwIrexx char(1) pos(115); AlwBmod char(1) pos(116); AlwImod char(1) pos(117); Limit char(1) pos(124); Pmfil char(10) pos(129); Pmlib char(10) pos(139); Msfil char(10) pos(149); Mslib char(10) pos(159); Hlpnl char(10) pos(169); Hlib char(10) pos(179); Hlpid char(10) pos(189); Ovpgm char(10) pos(239); Ovlib char(10) pos(249); Text char(50) pos(265); end-ds; // Extract command definitions callp QCDRCMDI( qcdrcmdiDS: %size(qcdrcmdiDS): 'CMDI0100': p_CmdQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; //try with *libl callp QCDRCMDI( qcdrcmdiDS: %size(qcdrcmdiDS): 'CMDI0100': %subst(p_CmdQual:1:10) + '*LIBL': ApiErrDS); 1e endif; 1b if qcdrcmdiDS.LIMIT = '0'; LimitUser = '*NO'; 1e endif; string = %trimr(f_BuildString( '?CRTCMD ??CMD(&) ??PGM(&) ??SRCFILE(&) ??SRCMBR(&) + ??ALWLMTUSR(&) ??HLPID(&)': f_GetQual(qcdrcmdiDS.CMD + qcdrcmdiDS.CMDLIB): f_GetQual(qcdrcmdiDS.CPGM + qcdrcmdiDS.CLIB): f_GetQual(qcdrcmdiDS.SFILE + qcdrcmdiDS.SLIB): qcdrcmdiDS.SMBR: LimitUser: qcdrcmdiDS.HLPID)); // Mode where allowed to run string += ' ??MODE('; 1b if qcdrcmdiDS.MODE = '111'; string += '*ALL'; 1x else; 2b if qcdrcmdiDS.ModePROD = '1'; string += ' *PROD'; 2e endif; 2b if qcdrcmdiDS.ModeDEBUG = '1'; string += ' *DEBUG'; 2e endif; 2b if qcdrcmdiDS.ModeSERVICE = '1'; string += ' *SERVICE'; 2e endif; 1e endif; string += ')'; string += ' ??ALLOW('; 1b if qcdrcmdiDS.ALW = '111111111'; string += '*ALL'; 1x else; 2b if qcdrcmdiDS.AlwBPGM = '1'; string += ' *BPGM'; 2e endif; 2b if qcdrcmdiDS.AlwIPGM = '1'; string += ' *IPGM'; 2e endif; 2b if qcdrcmdiDS.AlwEXEC = '1'; string += ' *EXEC'; 2e endif; 2b if qcdrcmdiDS.AlwINTERACT = '1'; string += ' *INTERACT'; 2e endif; 2b if qcdrcmdiDS.AlwBATCH = '1'; string += ' *BATCH'; 2e endif; 2b if qcdrcmdiDS.AlwBREXX = '1'; string += ' *BREXX'; 2e endif; 2b if qcdrcmdiDS.AlwIREXX = '1'; string += ' *IREXX'; 2e endif; 2b if qcdrcmdiDS.AlwBMOD = '1'; string += ' *BMOD'; 2e endif; 2b if qcdrcmdiDS.AlwIMOD = '1'; string += ' *IMOD'; 2e endif; 1e endif; string += ')'; //--------------------------------------------------------- 1b if not (qcdrcmdiDS.VPGM in %list(' ': '*NONE')); string += ' ??VLDCKR(' + f_GetQual(qcdrcmdiDS.VPGM + qcdrcmdiDS.VLIB) + ')'; 1e endif; 1b if not (qcdrcmdiDS.PMFIL in %list(' ':'*NONE')); string += ' ??PMTFILE(' + f_GetQual(qcdrcmdiDS.PMFIL + qcdrcmdiDS.PMLIB) + ')'; 1e endif; 1b if not (qcdrcmdiDS.HLPNL in %list(' ': '*NONE')); string += ' ??HLPPNLGRP(' + f_GetQual(qcdrcmdiDS.HLPNL + qcdrcmdiDS.HLIB) + ')'; 1e endif; 1b if not (qcdrcmdiDS.OVPGM in %list(' ': '*NONE')); string += ' ??PMTOVRPGM(' + f_GetQual(qcdrcmdiDS.OVPGM + qcdrcmdiDS.OVLIB) + ')'; 1e endif; string += ' ??TEXT(*SRCMBRTXT)'; return string; end-proc; //----------------------------- // note to future self, this must run in function. // I tried it first in subroutine, it would work correctly for // first 6 or so records, then it would quit working. // Must need something initialized that I could not find. //----------------------------- dcl-proc f_ConvertCcsid export; dcl-pi *n char(1024); istring char(1024) const; end-pi; dcl-ds HomeDirectoryDS qualified; ccsid int(10) pos(1); country char(2) pos(5); language char(3) pos(7); reserved char(3) pos(10); flags int(10) pos(13); numberbytes int(10) pos(17); delimiter char(2) pos(21); reserved2 char(10) pos(23); name char(1024) pos(33); end-ds; dcl-ds iconvds qualified; icorv int(10) pos(1); icoc int(10) dim(12) pos(5); end-ds; dcl-ds qtqcodeds template; ccsid int(10) pos(1); conversionAlt int(10) pos(5); substitutionAlt int(10) pos(9); shiftstateAlt int(10) pos(13); inputlength int(10) pos(17); mixeddata int(10) pos(21); reserved char(8) pos(25); end-ds; // Open Conversion Descriptor dcl-pr QtqIconvOpen like(iconvds) extproc(*dclcase); *n like(qtqcodeds) const; // ccsidTo *n like(qtqcodeds) const; // ccsidFrom end-pr; // Convert CCSID from Input Buffer to Output Buffer dcl-pr iconv extproc(*dclcase); *n like(iconvds) value; // pconvdesc *n pointer; // pinbuffer *n int(10); // pinbytes *n pointer; // poutbuffer *n int(10); // poutbytes end-pr; // Close Conversion Descriptor dcl-pr iconv_close int(10) extproc(*dclcase); *n like(iconvds) value; end-pr; dcl-ds to likeds(qtqcodeds); dcl-ds from likeds(qtqcodeds); dcl-s inBuf char(125); dcl-s inBufSize int(10); dcl-s outBuf char(125); dcl-s outBufSize int(10); dcl-s inBufPtr pointer; dcl-s outBufPtr pointer; HomeDirectoryDs = istring; to = *allx'00'; to.ccsid = 37; to.shiftstateAlt = 1; from = *allx'00'; from.ccsid = HomeDirectoryDS.ccsid; from.shiftstateAlt = 1; iconvds = QtqIconvOpen(to: from); 1b if (iconvds.ICORV < *zeros); // error occurred 1e endif; //------------------------------------------------ outbuf = *blanks; inBufPtr = %addr(inBuf); outBufPtr = %addr(outBuf); outBufSize = %size(outBuf); 1b if HomeDirectoryDS.numberbytes > %len(HomeDirectoryDS.name); HomeDirectoryDS.numberbytes = %len(HomeDirectoryDS.name); 1e endif; inBuf = %subst(HomeDirectoryDS.name:1:HomeDirectoryDS.numberbytes); inBufSize = HomeDirectoryDS.numberbytes; iconv(iconvds: inBufPtr: inBufSize: outBufPtr: outBufSize); return %subst(outbuf:1:outBufSize); iconv_close(iconvds); end-proc; //--------------------------------------------------------- // Accept API time stamp and return data structure //--------------------------------------------------------- dcl-proc f_DecodeApiTimeStamp export; dcl-pi *n char(16); p_ApiStamp char(8); end-pi; dcl-pr Qwccvtdt extpgm('QWCCVTDT'); // api date converter *n char(10) const; // from format *n char(8); // api date stamp *n char(10) const; // to format *n char(16); // to date *n like(ApiErrDS); end-pr; dcl-s string char(16); callp QWCCVTDT( '*DTS': p_ApiStamp: '*MDY': string: ApiErrDS); return string; end-proc; //--------------------------------------------------------- // Use complex process command as apierrds is consistent // for use with f_RtvMsgApi. (ie can send formatted error messages). // qcmdexec psds retrieves message with replacement values embedded. //--------------------------------------------------------- dcl-proc f_RunCmd export; dcl-pi *n; p_String varchar(2048) const options(*trim); end-pi; dcl-s ChangedSource char(1); dcl-s ChangedLen int(10); dcl-pr QCAPCMD extpgm('QCAPCMD'); // Process Commands *n char(2048) const options(*varsize); *n int(10) const; // Length of source *n like(cpop0100ds); // Options block *n int(10) const; // Options block len *n char(8) const; // Options format *n char(1); // Changed command *n int(10) const; // Length available *n int(10); // Length of changed *n like(apierrds); // Error Parm end-pr; dcl-ds cpop0100DS qualified; *n int(10) pos(1) inz(0); // TypeProcess *n char(1) pos(5) inz('0'); // DBCShandling *n char(1) pos(6) inz('2'); // PrompterAct *n char(1) pos(7) inz('0'); // CmdSyntax *n char(4) pos(8) inz(x'00000000'); // MessageKey *n int(10) pos(12) inz(0); // job ccsid *n char(5) pos(16) inz(x'0000000000'); // reserved end-ds; callp QCAPCMD( p_string: %len(p_string): cpop0100DS: %len(cpop0100ds): 'CPOP0100': ChangedSource: 0: ChangedLen: ApiErrDS); return; end-proc; //--------------------------------------------------------- // Send completion messages //--------------------------------------------------------- dcl-proc f_SndCompMsg export; dcl-pi *n; p_MsgTxt char(75) const; end-pi; callp QMHSNDPM( ' ': ' ': p_MsgTxt: 75: '*INFO': '*CTLBDY': 1: ' ': ApiErrDS); return; end-proc; //--------------------------------------------------------- // Display last spooled file and send completion message //--------------------------------------------------------- dcl-proc f_DisplayLastSplf export; dcl-pi *n; p_ProgName char(10) const; p_OutPut char(8) const; end-pi; // Retrieve Identity of Last Spooled File Created dcl-pr QSPRILSP extpgm('QSPRILSP'); *n like(LastSplfInfoDS); *n int(10) const; *n char(8) const; *n like(ApiErrDS); end-pr; dcl-ds LastSplfInfoDS len(70) qualified inz; SplfName char(10) pos(9); SplfNum int(10) pos(45); end-ds; callp QSPRILSP( LastSplfInfoDS: %len(LastSplfInfoDS): 'SPRL0100': ApiErrDS); 1b if p_OutPut = '*'; f_RunCmd('DSPSPLF FILE('+ LastSplfInfoDS.SplfName + ') SPLNBR(*LAST)'); 1e endif; f_SndCompMsg(f_BuildString('Splf & number & generated by &.': LastSplfInfoDS.SplfName: %char(LastSplfInfoDS.SplfNum): p_ProgName)); return; end-proc; //--------------------------------------------------------- // Delete file overrides //--------------------------------------------------------- dcl-proc f_DltOvr export; dcl-pi *n; p_SplfName char(10) const; end-pi; f_RunCmd('DLTOVR FILE(' + p_SplfName + ') LVL(*JOB)'); return; end-proc; //--------------------------------------------------------- // If member exists, return *on; //--------------------------------------------------------- dcl-proc f_IsValidMbr export; dcl-pi *n ind; p_FileQual char(20) const; p_Mbr char(10) const options(*nopass); end-pi; dcl-s mbrVar char(10); 1b if %parms = %parmnum(p_Mbr); mbrVar = p_Mbr; 1x else; mbrVar = '*FIRST'; 1e endif; QusrmbrdDS = f_Qusrmbrd(p_FileQual: mbrVar: 'MBRD0100'); return (ApiErrDS.BytesReturned = 0); end-proc; //------------------------------------------------------------------ // must check ... is not between ( ) as in inz('...') //------------------------------------------------------------------ dcl-proc f_EllipsisLoc export; dcl-pi *n uns(3); string char(74); end-pi; dcl-s Dots uns(3); // ignore ... in the keywords section 1b if %len(%trimr(string)) > 35 and %subst(string:1:35) = *blanks; return 0; 1e endif; Dots = %scan('...':string); 1b If Dots > 0 and %scan('(':string) > 0 and Dots > %scan('(':string); return 0; 1e endif; return Dots; end-proc; //--------------------------------------------------------- // return edit for date/time format printing //--------------------------------------------------------- dcl-proc f_BuildEditWord export; dcl-pi *n char(28); p_String char(28) const; p_DateType char(1) const; end-pi; dcl-s string varchar(28); 1b if p_DateType = 'Z'; return qs + ' - - - . . . ' + qs; 1x elseif p_DateType = 'T'; string = %upper(p_String); 2b if string in %list('TIMFMT(*USA)': '*USA'); return qs + ' . XM' + qs; 2x elseif string in %list('TIMFMT(*HMS)':'TIMFMT(*JIS)':'*HMS':'*JIS'); return qs + ' : : ' + qs; 2x elseif string in %list('TIMFMT(*ISO)':'TIMFMT(*EUR)':'*ISO':'*EUR'); return qs + ' . . ' + qs; 2x else; return qs + ' : : ' + qs; 2e endif; 1x elseif p_DateType = 'L' or p_DateType = 'D'; string = %upper(p_String); 2b if string in %list('DATFMT(*MDY)': 'DATFMT(*YMD)': 'DATFMT(*DMY)':'*MDY':'*YMD':'*DMY'); return qs + ' / / ' + qs; 2x elseif string in %list('DATFMT(*JUL)': '*JUL'); return qs + ' / ' + qs; 2x elseif string in %list('DATFMT(*ISO)':'DATFMT(*JIS)':'*ISO':'*JIS'); return qs + ' - - ' + qs; 2x elseif string in %list('DATFMT(*USA)': '*USA': ' '); return qs + ' / / ' + qs; 2x elseif string in %list('DATFMT(*EUR)': '*EUR'); return qs + ' . . ' + qs; // if no hit return *ISO Default 2x else; return qs + ' - - ' + qs; 2e endif; 1e endif; return p_String; end-proc; //--------------------------------------------------------- // return size of memory to allocate for QDBRTVFD call. // calling programs must check ApiErrDS.BytesReturned //--------------------------------------------------------- dcl-proc f_GetAllocatedSize export; dcl-pi *n int(10); // returned size of data p_FileQual char(20) const; p_RcdFmt char(10) const; end-pi; dcl-ds GetAllocSizeDS qualified; SizeReturned int(10) pos(5); end-ds; callp QDBRTVFD( GetAllocSizeDS: %len(GetAllocSizeDS): ReturnFileQual: 'FILD0100': p_FileQual: p_RcdFmt: '0': '*FILETYPE': '*EXT': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; return 1; 1x else; return GetAllocSizeDS.SizeReturned; 1e endif; end-proc; //--------------------------------------------------------- // return HH:MM:SS time from 13 digit API date/time //--------------------------------------------------------- dcl-proc f_GetApiHMS export; dcl-pi *n char(8); p_DateTime char(13); end-pi; 1b if %subst(p_DateTime: 8: 1) in %list(' ': x'00'); return ' '; 1e endif; return %subst(p_DateTime: 8: 2) + ':' + %subst(p_DateTime: 10: 2) + ':' + %subst(p_DateTime: 12: 2); end-proc; //--------------------------------------------------------- // return *ISO- from 13 digit API date/time //--------------------------------------------------------- dcl-proc f_GetApiISO export; dcl-pi *n char(10); p_DateTime char(13) const; end-pi; dcl-s century char(2); 1b if %subst(p_DateTime: 1: 1) in %list(' ': x'00'); return ' '; 1e endif; 1b if %subst(p_DateTime: 1: 1) = '1'; century = '20'; 1x else; century = '19'; 1e endif; return century + %subst(p_DateTime: 2: 2) + '-' + %subst(p_DateTime: 4: 2) + '-' + %subst(p_DateTime: 6: 2); end-proc; //--------------------------------------------------------- // return card color attribute //--------------------------------------------------------- dcl-proc f_GetCardColor export; dcl-pi *n char(1); //hex value p_CardSuite char(1); // H S C D end-pi; 1b if p_CardSuite = 'H'; return %bitor(RED: RI); 1x elseif p_CardSuite = 'S'; return %bitor(BLUE: RI); 1x elseif p_CardSuite = 'C'; return %bitor(YELLOW: RI); 1x elseif p_CardSuite = 'D'; return %bitor(WHITE: RI); 1e endif; end-proc; //--------------------------------------------------------- // return A,K,Q,J,10 for numeric values //--------------------------------------------------------- dcl-proc f_GetCardFace export; dcl-pi *n char(2); p_CardNumVal uns(3); end-pi; 1b if p_CardNumVal = 01; return 'A '; 1x elseif p_CardNumVal = 11; return 'J '; 1x elseif p_CardNumVal = 12; return 'Q '; 1x elseif p_CardNumVal = 13; return 'K '; 1x else; return %char(p_CardNumVal); 1e endif; end-proc; //--------------------------------------------------------- // date, time, procptr and object class types may require a suffix //--------------------------------------------------------- dcl-proc f_GetDataTypeKeyWords export; dcl-pi *n char(16); datatype char(1); length uns(10); decimals char(2); pSuffix varchar(37) options(*nopass); end-pi; dcl-s suffix varchar(37); dcl-s keyword char(20); keyword = *blanks; 1b if %parms = %parmnum(pSuffix); suffix = pSuffix; 1e endif; // these keywords do not need length 1b if datatype = 'D' // date definition or datatype = 'L'; // file definition return 'date' + suffix + ';'; 1x elseif datatype = 'N'; return 'ind;'; 1x elseif datatype = 'T'; return 'time' + suffix + ';'; 1x elseif datatype = 'Z'; return 'timestamp;'; 1x elseif datatype = '*'; return 'pointer' + suffix + ';'; 1x elseif datatype = 'O'; return 'object' + suffix + ';'; 1x elseif datatype = '7'; return 'xml' + suffix + ';'; // these keywords will have length and possible decimal positions 1x elseif datatype = 'A'; keyword = 'char('; 1x elseif datatype = 'V'; keyword = 'varchar('; 1x elseif datatype = 'B'; keyword = 'bindec('; 1x elseif datatype = 'F'; keyword = 'float('; 1x elseif datatype = 'G'; keyword = 'graph('; 1x elseif datatype = 'I'; keyword = 'int('; 1x elseif datatype = 'P'; keyword = 'packed('; 1x elseif datatype = 'S'; keyword = 'zoned('; 1x elseif datatype = 'U'; keyword = 'uns('; 1x elseif datatype = 'C'; keyword = 'ucs2('; 1x elseif datatype = '&'; // data structures return len() (see jcrhfdr) keyword = 'len('; // type HEX is in some IBM security audit journals 1x elseif datatype = 'H'; keyword = 'hex('; 1x elseif datatype = '3'; keyword = 'dbclob('; 1e endif; 1b if decimals in %list(' ': ' 0': '00'); KeyWord = %trimr(KeyWord) + %char(length) + ');'; 1x else; KeyWord = %trimr(KeyWord) + %char(length) + ': ' + %trim(decimals) + ');'; 1e endif; return keyword; end-proc; //--------------------------------------------------------- // return right justified day name from date field. use today if no parm //--------------------------------------------------------- dcl-proc f_GetDayName export; dcl-pi *n char(9); p_DateISO date(*ISO) const options(*NoPass); end-pi; // Calculate Day of Week from Lilian Date dcl-pr CEEDYWK extproc(*dclcase); *n int(10); // lilian date *n int(10); // dow number *n char(12) const options(*omit); end-pr; dcl-s xx int(10); ApiErrDS.BytesReturned = 0; //---------------------------------------------- 1b if %parms = %parmnum(p_DateISO); callp CEEDAYS(%char(p_DateISO: *iso0): Pic: Lilian: *OMIT); 1x else; callp CEEDAYS(%char(%date(): *iso0): Pic: Lilian: *OMIT); 1e endif; callp CEEDYWK(Lilian: xx: *OMIT); 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; return 'Bad Date'; 1e endif; end-proc; //--------------------------------------------------------- // Search directory for email address // returns *blank if user not exists. // returns @ if user does not have email address (wrkdire) //--------------------------------------------------------- dcl-proc f_GetEmail export; dcl-pi *n char(150); p_User char(10) const options(*nopass); end-pi; dcl-s xx uns(3); dcl-s curruser char(10) inz(*user); dcl-s smtpusrid varchar(64); dcl-s smtpdmn varchar(256); dcl-pr p_QOKSCHD extpgm('QOKSCHD'); // search directory *n like(srcv0100DS); // receiver *n int(10) const; // length *n char(8) const; // format name of receiver *n char(10) const; // function *n char(1) const; // keep temporary resource indicator *n like(sreq0100DS); // request variable *n int(10) const; // length *n char(8) const; // format name of request variable *n like(ApiErrDS); end-pr; dcl-ds sreq0100DS qualified inz; // search parameters *n int(10) pos(1); // ccsid *n int(10) pos(5); // character set of input *n int(10) pos(9); // code page *n char(4) pos(13); // wild card *n char(1) pos(17) inz('0'); // convert data *n char(1) pos(18) inz('0'); // search data *n char(1) pos(19) inz('0'); // run verify *n char(1) pos(20) inz('0'); // continuation handle *n char(16) pos(21); // resource handle *n char(8) pos(37) inz('SREQ0101'); // format name of search array *n int(10) pos(45) inz(110); // offset to search array *n int(10) pos(49) inz(1); // number elements to return *n char(8) pos(53) inz('SREQ0103'); // format of names to return *n int(10) pos(61) inz(100); // offset to fields array to return *n int(10) pos(65) inz(1); // number elements to return *n char(8) pos(69) inz('SRCV0101'); // format name array of users *n int(10) pos(77) inz(1); // number users to return *n char(8) pos(81) inz('SRCV0111'); // format fields for users *n char(8) pos(89); // format order to return fields *n char(1) pos(97) inz('0'); // order specified *n char(3) pos(98); // reserved *n char(10) pos(101) inz('*SMTP'); SearchRequestArry like(sreq0101ds); end-ds; dcl-ds sreq0101ds qualified inz; // search request array *n int(10) pos(1) inz(%size(sreq0101ds)); // length of entry *n char(1) pos(5) inz('1'); // compare value *n char(10) pos(6) inz('USER'); // field *n char(7) pos(16) inz('*IBM'); // product ID *n char(1) pos(23) inz('0'); // not case senstive *n char(1) pos(24); // reserved *n int(10) pos(25) inz(10); // length of value ValueToMatch char(10) pos(29); end-ds; dcl-ds srcv0100DS len(5000) qualified inz; // receiver OffsetToUsersArry int(10) pos(9); EntriesReturned int(10) pos(13); end-ds; dcl-ds srcv0101ds qualified based(srcv0101Ptr); NumFieldsReturned int(10) pos(5); end-ds; dcl-ds FieldDS qualified based(srcv0111Ptr); Name char(10) pos(1); Len int(10) pos(29); Value char(256) pos(33); end-ds; 1b if %parms = %parmnum(p_User); sreq0101ds.ValueToMatch = p_User; 1x else; sreq0101ds.ValueToMatch = curruser; 1e endif; sreq0100DS.SearchRequestArry = sreq0101ds; callp p_QOKSCHD( srcv0100DS: %size(srcv0100DS): 'SRCV0100': '*SEARCH': '0': sreq0100DS: %size(sreq0100DS): 'SREQ0100': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0 or srcv0100DS.EntriesReturned = 0; return *blanks; 1e endif; srcv0101Ptr = %addr(srcv0100DS) + srcv0100DS.OffsetToUsersArry; srcv0111Ptr = srcv0101Ptr + %size(srcv0101DS); 1b for xx = 1 to srcv0101DS.NumFieldsReturned; 2b if FieldDS.Name = 'SMTPUSRID'; smtpusrid = %subst(FieldDS.Value: 1: FieldDS.Len); 2x elseif FieldDS.Name = 'SMTPDMN'; smtpdmn = %subst(FieldDS.Value: 1: FieldDS.Len); 2e endif; srcv0111Ptr += (FieldDS.Len + 32); // next offset 1e endfor; return smtpusrid + '@' + smtpdmn; end-proc; //--------------------------------------------------------- // If object exists return *on; //--------------------------------------------------------- dcl-proc f_IsValidObj export; dcl-pi *n ind; p_ObjNam char(10) const; p_ObjLib char(10) const; p_ObjTyp char(10) const; end-pi; f_QUSROBJD(p_ObjNam + p_ObjLib: p_ObjTyp: 'OBJD0100'); return (ApiErrDS.BytesReturned = 0); end-proc; //--------------------------------------------------------- // return name of data base utility installed. // thanks to Peter Lee for adding Thomas Raddaz PEEK command //--------------------------------------------------------- dcl-proc f_GetFileUtil export; dcl-pi *n char(6) end-pi; 1b if f_IsValidObj('DBU': '*LIBL': '*CMD'); return 'DBU'; 1x elseif f_IsValidObj('PEEK': '*LIBL': '*CMD'); return 'PEEK'; 1x elseif f_IsValidObj('WRKDBF': '*LIBL': '*CMD'); return 'WRKDBF'; 1x else; return 'STRDFU'; 1e endif; end-proc; //--------------------------------------------------------- // return *on if compile array is found at source line //--------------------------------------------------------- dcl-proc f_IsCompileTimeArray export; dcl-pi *n ind; SrcPos13 char(3); end-pi; return SrcPos13 in %list('** ': '**C': '**c'); end-proc; //--------------------------------------------------------- // return *on if comment line in source //--------------------------------------------------------- dcl-proc f_IsIgnoreLine export; dcl-pi *n ind; string varchar(94); end-pi; dcl-s FirstChar uns(3); dcl-s SlashSlash uns(3); 1b if %len(string) = 0; // blank line return *on; 1x elseif %subst(string:1:1) in %list('*': '/'); return *on; 1x else; SlashSlash = %scan('//': string); FirstChar = %check (' ': string); 2b if SlashSlash = FirstChar; return *on; 2e endif; 1e endif; return *off; end-proc; //--------------------------------------------------------- // return list of procedures local to the source member //--------------------------------------------------------- dcl-proc f_GetInternalProcNames export; dcl-pi *n like(ProcNamesDS); p_SrcMbr char(10); p_SrcFilQual char(20); end-pi; dcl-f InputSrc disk(112) extfile(extIfile) extmbr(p_SrcMbr) usropn; dcl-s extIfile char(21); dcl-s xx uns(3); dcl-s Dots uns(3); dcl-s string varchar(94); dcl-s IsExtract ind; dcl-s prname char(74); dcl-ds ProcNamesDS qualified; Cnt uns(5); Names char(74) dim(500); end-ds; dcl-ds InputDS len(112) qualified; CompileArry char(3) pos(13); SpecType char(1) pos(18); Src74 char(74) pos(19); end-ds; ProcNamesDS.Cnt = 0; ProcNamesDS.Names(*) = *blanks; extIfile = f_GetQual(p_SrcFilQual); open InputSrc; read InputSrc InputDS; 1b dow not %eof; 2b if not f_IsCompileTimeArray(InputDS.CompileArry); string = %trimr(InputDS.Src74); 3b if not f_IsIgnoreLine(string); IsExtract = *off; xx = %scan('DCL-PROC':%upper(string)); 4b if (xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0); IsExtract = *on; %subst(InputDS.Src74: xx: 8) = *blanks; 4e endif; 4b if %upper(InputDS.SpecType) = 'P'; IsExtract = *on; 4e endif; 4b if IsExtract; Dots = f_EllipsisLoc(InputDS.Src74); 5b if Dots = 0; prname = %triml(InputDS.Src74); prname = %scanrpl(';':'': prname); // drop any keywords after space in name xx = %scan(' ':prname); 6b if xx > 0; %subst(prname:xx) = *blanks; 6e endif; 6b if %upper(prname) in %list('B': 'E'); prname = *blanks; 6e endif; 5x else; prname = %trim(%subst(InputDS.Src74:1:Dots-1)); 5e endif; 5b if prname > *blanks; 6b if ProcNamesDS.Cnt = 0 or %lookup(prname: ProcNamesDS.Names: 1: ProcNamesDS.Cnt) = 0; ProcNamesDS.Cnt += 1; ProcNamesDS.Names(ProcNamesDS.Cnt) = prname; 6e endif; 5e endif; 4e endif; 3e endif; 2e endif; read InputSrc InputDS; 1e enddo; close InputSrc; return ProcNamesDS; end-proc; //--------------------------------------------------------- // extract parameter name, lookup in global fieldname array, return index // look for four possible scenarios // C PARM fieldname // D fieldname // dcl-parm fieldname // fieldname //--------------------------------------------------------- dcl-proc f_GetParmFieldsArryIndex export; dcl-pi *n uns(5); spec char(1); string varchar(94); end-pi; dcl-s xx uns(3); dcl-s slen uns(3); dcl-s Index uns(5); dcl-s ParmField char(100); slen = %len(string); // keep the scans valid with varying field //---------------------------------------------------- // C SPECS // either want 14 characters or to end of string // parm a 1 0 // parm abc //---------------------------------------------------- 1b if spec = 'C'; 2b if slen >= 44 and %subst(string:20:5) = 'PARM '; 3b if slen >= 57; ParmField = %subst(string:44:14); 3x else; ParmField = %subst(string:44); 3e endif; exsr srGetIndex; 2e endif; //---------------------------------------------------- // D SPECS slam to left and strip any ... // Dfieldname // D fieldname // Dfieldname... // D fieldname... // D 2a // check for this //---------------------------------------------------- 1x elseif spec = 'D'; 2b if slen > 15 and %subst(string:1:15) = *blanks; return 0; 2e endif; ParmField = %triml(string); ParmField = %scanrpl('...':' ':ParmField); xx = %scan(' ':ParmField); %subst(ParmField:xx) = *blanks; exsr srGetIndex; 1x else; //---------------------------------------------------- // dcl-parm fieldname; // dcl-parm fieldname char(10); //--------------------------------------------------------- string = %scanrpl('DCL-PARM':' ':string); ParmField = %triml(string); xx = %scan(' ':ParmField); %subst(ParmField:xx) = *blanks; exsr srGetIndex; 1e endif; return 0; begsr srGetIndex; index = %lookup(ParmField: FieldsArry(*).Name: 1: FieldsArryCnt); return Index; endsr; end-proc; //--------------------------------------------------------- // Determine PEP or Procedure Entry Point. // Check for first procedure interface or *ENTRY . //--------------------------------------------------------- dcl-proc f_GetProcedureEntryPoint export; dcl-pi *n char(6); spec char(1); string varchar(94); end-pi; dcl-s xx uns(3); dcl-s slen uns(3); dcl-s pOpCode char(10); //---------------------------------------------------- // no *entry or procedure interface if an // O or P spec or a DCL-PROC is found first //--------------------------------------------------------- 1b if spec = 'O' or spec = 'P'; return 'NO-PEP'; 1e endif; xx = %scan('DCL-PROC':string); 1b if xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0; return 'NO-PEP'; 1e endif; //---------------------------------------------------- slen = %len(string); // keep the scans valid with varying field 1b if spec = 'D' and slen >= 19 and %subst(string:17:3) = ' PI'; return 'DCL-PI'; 1e endif; 1b if spec = 'C' and slen >= 14 and %subst(string:6:8) = '*ENTRY'; return '*ENTRY'; 1e endif; xx = %scan('DCL-PI ':string); 1b if xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0; pOpcode = 'DCL-PI'; 2b if f_CheckSameLineEnd(pOpcode: string) = *blanks; return 'NO-PEP'; 2x else; return 'DCL-PI'; 2e endif; 1e endif; return ' '; end-proc; //--------------------------------------------------------- // return value is random number between 1 and upper range // Api CEERAN0 was returning the same sequence on different days. // instead use C rand function with seed Lilian date + millisecoonds // no repeated sequences so far //--------------------------------------------------------- dcl-proc f_GetRandom export; dcl-pi *n uns(3); p_UpperLimit uns(3) const; end-pi; dcl-pr rand int(10) extproc(*dclcase) end-pr; dcl-pr srand extproc(*dclcase); *n uns(10) value; // Seed end-pr; dcl-s onetime ind static inz(*on); 1b if onetime; callp CEEDAYS(%char(%date(): *iso0): pic :Lilian: *OMIT); SRand((Lilian * 1000) + (%subdt(%timestamp():*MS) / 1000)); onetime = *off; 1e endif; return %rem(Rand(): p_UpperLimit) + 1; end-proc; //--------------------------------------------------------- // Create user space, change attributes to allow automatic extendibility, // returning pointer to user space. //--------------------------------------------------------- dcl-proc f_Quscrtus export; dcl-pi *n pointer; p_UserSpace char(20); end-pi; dcl-s uPtr pointer; dcl-s ReturnLib char(10); dcl-pr Quscrtus extpgm('QUSCRTUS'); // create user space *n char(20); // user space *n char(10) const; // extended attribute *n int(10) const; // length of space *n char(1) const; // hex0 initialize *n char(10) const; // use authority *n char(50) const; // text *n char(10) const; // replace object *n like(ApiErrDS); *n char(10) const; // domain *n int(10) const; // transfer size *n char(1) const; // optimum space end-pr; dcl-pr Quscusat extpgm('QUSCUSAT'); // change space attribute *n char(10); // return library *n char(20); // user space *n like(QuscusatDS); // key to change *n like(ApiErrDS); end-pr; dcl-ds QuscusatDS qualified; *n int(10) pos(1) inz(2); // number of records *n int(10) pos(5) inz(2); // key to set initial value *n int(10) pos(9) inz(1); // key length *n char(1) pos(13) inz(x'00'); // key data *n int(10) pos(14) inz(3); // key to set auto extend *n int(10) pos(18) inz(1); // key length *n char(1) pos(22) inz('1'); // key data end-ds; 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-proc; //--------------------------------------------------------- // Return DSPF field names row and columns //--------------------------------------------------------- dcl-proc f_GetRowColumn export; dcl-pi *n char(6); p_FieldName char(10) const; p_File char(10); p_Lib char(10); p_RcdFmt char(10); end-pi; dcl-s UserSpaceName char(20) inz('JCRCMDSSRVQTEMP '); dcl-s PreviousFile char(10) static; dcl-s PreviousLib char(10) static; dcl-s PreviousRcdFmt char(10) static; dcl-ds CsrRowColDS; CsrRow zoned(3); CsrCol zoned(3); end-ds; 1b if not(p_File = PreviousFile and p_Lib = PreviousLib and p_RcdFmt = PreviousRcdFmt); PreviousFile = p_File; PreviousLib = p_Lib; PreviousRcdFmt = p_RcdFmt; ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QUSLFLD( UserSpaceName: 'FLDL0100': p_File + p_Lib: p_RcdFmt: '0': ApiErrDS); 1e endif; QuslfldPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if p_FieldName = QuslfldDS.FieldName; csrrow = QuslfldDS.ScreenFieldRow; csrcol = QuslfldDS.ScreenFieldCol; 1v leave; 2e endif; QuslfldPtr += ApiHead.ListEntrySize; 1e endfor; return CsrRowColDS; end-proc; //--------------------------------------------------------- // return *on input file/lib/mbr same as output file/lib/mbr //--------------------------------------------------------- dcl-proc f_IsSameMbr export; dcl-pi *n ind; p_InFileQual char(20); p_InMbr char(10); p_OutFileQual char(20); p_OutMbr char(10); end-pi; dcl-s InLib char(10); 1b if p_OutMbr = p_InMbr and %subst(p_OutFileQual: 1: 10) = %subst(p_InFileQual: 1: 10) and f_IsValidMbr(p_OutFileQual: p_OutMbr); QusrmbrdDS = f_Qusrmbrd(p_InFileQual: p_InMbr: 'MBRD0100'); InLib = QusrmbrdDS.Lib; QusrmbrdDS = f_Qusrmbrd(p_OutFileQual: p_OutMbr: 'MBRD0100'); 2b if QusrmbrdDS.Lib = InLib; return *on; 2e endif; 1e endif; return *off; end-proc; //--------------------------------------------------------- // Validate extracted member type against (up to) 4 types passed in as parms. Must pass // in at least one type. Usually do not change function parameters, but in this // case all programs using this function benefit from having actual library // returned if library is '*LIBL'. //--------------------------------------------------------- dcl-proc f_IsValidSrcType export; dcl-pi *n ind; p_FileQual char(20); p_Mbr char(10) const; p_Type1 char(10) const; p_Type2 char(10) const options(*nopass); p_Type3 char(10) const options(*nopass); p_Type4 char(10) const options(*nopass); end-pi; QusrmbrdDS.MbrType = *blanks; QusrmbrdDS = f_Qusrmbrd(p_FileQual: p_Mbr: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; 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 >= %parmnum(p_Type2) and QusrmbrdDS.MbrType = p_Type2 or %parms >= %parmnum(p_Type3) and QusrmbrdDS.MbrType = p_Type3 or %parms = %parmnum(p_Type4) and QusrmbrdDS.MbrType = p_Type4; return *on; 1x else; return *off; 1e endif; end-proc; //--------------------------------------------------------- // Add member to existing file //--------------------------------------------------------- dcl-proc f_SrcFileAddPfm export; dcl-pi *n; p_NewFileQual char(20) const; p_NewMbr char(10) const; p_MbrType char(8) const; p_MbrText char(50) const options(*nopass); p_OrgFileQual char(20) const options(*nopass); p_OrgMbr char(10) const options(*nopass); end-pi; // get original member text 1b if %parms = %parmnum(p_OrgMbr); 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(p_NewFileQual: p_NewMbr); f_RunCmd(f_BuildString('ADDPFM FILE(&) MBR(&) + SRCTYPE(&) TEXT(&q&&q)': f_GetQual(p_NewFileQual): p_NewMbr: QusrmbrdDS.MbrType: QusrmbrdDS.Text)); 1x else; f_RunCmd(f_BuildString( 'CHGPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)': f_GetQual(p_NewFileQual): p_NewMbr: QusrmbrdDS.MbrType: QusrmbrdDS.Text)); f_RunCmd(f_BuildString('CLRPFM FILE(&) MBR(&)': f_GetQual(p_NewFileQual):p_NewMbr)); 1e endif; return; end-proc; //--------------------------------------------------------- //--------------------------------------------------------- dcl-proc f_GetFileLevelID export; dcl-pi *n char(13); p_FileQual char(20) const; p_RcdFmt char(10) const options(*nopass); end-pi; dcl-s RcdFmt char(10); 1b if %parms = %parmnum(p_RcdFmt); RcdFmt = p_RcdFmt; 1x else; RcdFmt = '*FIRST'; 1e endif; callp QDBRTVFD( fild0200DS: %len(fild0200DS): ReturnFileQual: 'FILD0200': p_FileQual: RcdFmt: '0': '*FILETYPE': '*EXT': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; return fild0200DS.LevelID; end-proc; //--------------------------------------------------------- // Validity check / create OutFile //--------------------------------------------------------- dcl-proc f_OutFileCrtDupObj export; dcl-pi *n; p_FileQual char(20) const; p_MbrOpt char(22) const; p_FromObj char(10) const; end-pi; dcl-s RealMbr char(10); dcl-ds OutFileDS; OutFile char(10); OutLib char(10); end-ds; dcl-ds MbrOptDS; NumEntries int(5); OutMbr char(10); OutMbrOpt char(10); end-ds; 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 // changed because JCRHFD needs to use jcrsmltf name 1b if OutFile = p_FromObj; // f_SndEscapeMsg('Select OutFile name other than ' + // %trimr(p_FromObj) + '.'); 1e endif; //--------------------------------------------------------- 1b if not(OutLib = '*LIBL' or OutLib = '*CURLIB' or f_IsValidObj(OutLib: 'QSYS': '*LIB')); f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; //--------------------------------------------------------- ApiErrDS.ErrMsgId = *blanks; f_IsValidMbr(p_FileQual: OutMbr); 1b if ApiErrDS.ErrMsgId = 'CPF9812'; 2b if OutLib = '*LIBL'; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 2x else; f_RunCmd( f_BuildString('CRTDUPOBJ OBJ(&) FROMLIB(*LIBL) + OBJTYPE(*FILE) TOLIB(&) NEWOBJ(&) + DATA(*NO) CST(*NO) TRG(*NO)': p_FromObj: OutLib: OutFile)); 3b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': Error occurred on CRTPF'); 3e endif; // note ddl created files can not have all members removed 3b if OutMbr = '*FIRST'; RealMbr = OutFile; 3e endif; f_RunCmd( f_BuildString('RNMM FILE(&/&) MBR(&) NEWMBR(&)': OutLib: OutFile: p_FromObj: RealMbr)); 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_RunCmd( f_BuildString('CLRPFM FILE(&/&) MBR(&)': OutLib: OutFile: RealMbr)); 1e endif; // compare record format ID for level check issues 1b if not(f_GetFileLevelID(p_FromObj + '*LIBL') = f_GetFileLevelID(OutFile + OutLib)); f_SndEscapeMsg( f_BuildString('CPF4131: Level check on file & in library &.': OutFile: OutLib)); 1e endif; return; //--------------------------------------------------------- begsr srAddPfm; ApiErrDS.ErrMsgId = *blanks; RealMbr = OutMbr; 1b if OutMbr = '*FIRST'; RealMbr = OutFile; 1e endif; f_RunCmd(f_BuildString('ADDPFM &/& &': OutLib: OutFile: realMbr)); 1b if (ApiErrDS.ErrMsgId = 'CPF7306'); f_SndEscapeMsg('Members for OutFile more than MAX allowed.'); 1e endif; endsr; end-proc; //--------------------------------------------------------- // Override prtf with outq and/or user data //--------------------------------------------------------- dcl-proc f_OvrPrtf export; dcl-pi *n; p_SplfName char(10) const; p_Outq char(20) const; p_UsrDta char(10) const; end-pi; dcl-s soutq char(21); f_DltOvr(p_SplfName); 1b if %subst(p_Outq:11:10) = *blanks; soutq = p_outq; // *job 1x else; soutq = f_GetQual(p_outq); 1e endif; f_RunCmd('OVRPRTF FILE(' + %trimr(p_SplfName) + ') OUTQ(' + %trimr(soutq) + ') USRDTA(' + p_UsrDta + ') OVRSCOPE(*JOB)'); return; end-proc; //--------------------------------------------------------- // return command prompt override string for program source lib/file/mbr //--------------------------------------------------------- dcl-proc f_PromptOverrideGetSource export; dcl-pi *n char(5700); p_PgmQual char(20); end-pi; dcl-ds AlphaBin qualified; *n uns(5) inz(5700); end-ds; // retrieve program information API to get attribute callp QCLRPGMI( QclrpgmiDS: %len(QclrpgmiDS): 'PGMI0100': p_PgmQual: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; QclrpgmiDS.SrcFil = 'OBJECTxxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; // If ILE, get pointer ILE user space 1x elseif QclrpgmiDS.PgmType = 'B'; ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QBNLPGMI( UserSpaceName: 'PGML0100': p_PgmQual: ApiErrDS); 2b if ApiErrDS.BytesReturned > 0; //Src not available QclrpgmiDS.SrcFil = 'SOURCExxxx'; QclrpgmiDS.SrcLib = 'NOTxxxxxxx'; QclrpgmiDS.SrcMbr = 'FOUNDxxxxx'; QclrpgmiDS.SrcAttrb = 'xxxxxxxxxx'; 2x else; QbnlpgmiPTR = ApiHeadPtr + ApiHead.OffsetToList; QclrpgmiDS.SrcFil = QbnlpgmiDS.SrcFil; QclrpgmiDS.SrcLib = QbnlpgmiDS.SrcLib; QclrpgmiDS.SrcMbr = QbnlpgmiDS.SrcMbr; QclrpgmiDS.SrcAttrb = QbnlpgmiDS.SrcAttrb; 2e endif; 1e endif; // build prompt string to return to command return f_BuildString('&??SRCFIL(&) ??SRCLIB(&) ??SRCMBR(&) ??PGMATR(&)': AlphaBin: QclrpgmiDS.SrcFil: QclrpgmiDS.SrcLib: QclrpgmiDS.SrcMbr: QclrpgmiDS.SrcAttrb); end-proc; //--------------------------------------------------------- // Receive program messages //--------------------------------------------------------- dcl-proc f_qmhrcvpm export; dcl-pi *n char(75); p_CallStack int(10) const; end-pi; dcl-pr Qmhrcvpm ExtPgm('QMHRCVPM'); // receive pgm messages *n like(rcvm0100DS); *n int(10) const; *n char(8) const; *n char(10) const; *n int(10) const; *n char(10) const; *n char(4) const; *n int(10) const; *n char(10) const; *n like(ApiErrDS); end-pr; dcl-ds rcvm0100DS qualified; BytesReturned int(10) pos(1); BytesAvail int(10) pos(5); LenOfMsg int(10) pos(41); MessageText char(100) pos(49); end-ds; callp QMHRCVPM( rcvm0100DS: %len(rcvm0100DS): 'RCVM0100': '*': p_CallStack: '*LAST': ' ': 10: '*REMOVE': ApiErrDS); return rcvm0100DS.MessageText; end-proc; //--------------------------------------------------------- // Remove all messages from error message subfile //--------------------------------------------------------- dcl-proc f_RmvSflMsg export; dcl-pi *n; p_ProgName char(10) const; end-pi; dcl-pr Qmhrmvpm ExtPgm('QMHRMVPM'); *n char(10) const; *n int(10) const; *n char(4) const; *n char(10) const; *n like(ApiErrDS); end-pr; callp Qmhrmvpm( p_ProgName: 0: ' ': '*ALL': ApiErrDs); return; end-proc; //--------------------------------------------------------- // Send message to error message subfile // use local apierrds so as not to overlay global error reporting when message sent //--------------------------------------------------------- //dcl-proc f_SndSflMsg export; // dcl-pi *n; // p_ProgName char(10) const; // p_MsgTxt char(75) const; // p_MsgID char(7) const options(*nopass); // p_MsgFile char(10) const options(*nopass); // p_MsgLib char(10) const options(*nopass); // end-pi; // // dcl-ds ApiErrDS qualified; // BytesProvided int(10) pos(1) inz(%size(ApiErrDS)); // BytesReturned int(10) pos(5) inz(0); // ErrMsgId char(7) pos(9); // MsgReplaceVal char(112) pos(17); // end-ds; // // dcl-s MsgID char(7); // dcl-s MsgFileQual char(20); // 1b // if %parms = %parmnum(p_MsgTxt); // msgid = *blanks; // MsgFileQual = *blanks; 1x // else; // msgid = p_MsgID; // 2b // if %parms = %parmnum(p_MsgFile); // 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-proc; // //--------------------------------------------------------- // Execute selected command for Files //--------------------------------------------------------- dcl-proc f_RunOptionFile export; dcl-pi *n; p_Option packed(1) const; p_File char(10) const; p_Lib char(10) const; p_RcdFmt char(10) const; p_Mbr char(10) const; p_ProgId char(10); end-pi; dcl-s p_FileQual char(21); dcl-s Msg char(75); dcl-ds anymbrs likeds(Fild0100ds); dcl-s futil char(6); // data file utility name p_FileQual = f_GetQual(p_File + p_Lib); 1b if p_Option = 1; f_RunCmd(f_BuildString('JCRFFD FILE(&) RCDFMT(&) OUTPUT(*)': p_FileQual: p_RcdFmt)); msg = 'Field Descriptions for ' + %trimr(p_FileQual) + ' - completed'; 1x elseif p_Option = 2; callp QDBRTVFD( anymbrs: 500: ReturnFileQual: 'FILD0100': p_File + p_Lib: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); 2b if ApiErrDS.BytesReturned = 0 and anymbrs.NumMbrs = 0; msg = 'File ' + %trimr(p_FileQual) + ' has no members.'; 2x else; //------------------------------------------------------ // execute (if installed) DBU, PEEK, WRKDBF, or default STRDFU //------------------------------------------------------ futil = f_GetFileUtil(); 3b if futil = 'DBU'; f_RunCmd('DBU FILE('+p_FileQual+') MBR('+p_Mbr+')'); 3x elseif futil = 'PEEK'; f_RunCmd('PEEK ' + p_FileQual); 3x elseif futil = 'WRKDBF'; f_RunCmd('WRKDBF ' + p_FileQual); 3x else; f_RunCmd('STRDFU OPTION(5) FILE(' + p_FileQual + ') MBR(' + p_Mbr + ')'); 3e endif; msg=%trimr(futil)+' for '+%trimr(p_FileQual)+' - completed'; 2e endif; 1x elseif p_Option = 3; f_RunCmd('JCRFD ' + p_FileQual); msg = 'File Description for ' + %trimr(p_FileQual) + ' - completed'; 1x elseif p_Option = 4; f_RunCmd(f_BuildString('RMVM FILE(&) MBR(&)': p_FileQual: p_Mbr)); msg = 'Member ' + %trimr(p_mbr) + ' has been removed'; 2b if ApiErrDS.BytesReturned > 0; msg = ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); 2e endif; 1x elseif p_Option = 5; f_RunCmd(f_BuildString('WRKMBRPDM FILE(&) MBR(&)': p_FileQual: p_Mbr)); msg = 'Work with member ' + %trimr(p_mbr) + ' - completed'; 1x elseif p_Option = 7; f_RunCmd('WRKOBJ *ALL/' + p_File + 'OBJTYPE(*FILE)'); msg = 'Wrkobj *all/' + %trimr(p_file) + ' - completed'; 1x elseif p_Option = 9; f_RunCmd(f_BuildString('CLRPFM FILE(&) MBR(&)': p_FileQual: p_Mbr)); msg = 'Member ' + %trimr(p_mbr) + ' has been cleared'; 1x else; msg = 'Option ' + %char(p_Option) + ' is not available'; 1e endif; snd-msg msg %target(p_ProgId); return; end-proc; //--------------------------------------------------------- // Execute selected command for Jobs //--------------------------------------------------------- dcl-proc f_RunOptionJob export; dcl-pi *n; p_Option packed(2); p_JobName char(10); p_JobUser char(10); p_JobNum char(6); p_ProgId char(10); end-pi; dcl-s JobString varchar(33); dcl-s Msg char(75); dcl-pr p_JCRJOBSIOR extpgm('JCRJOBSIOR'); *n char(10); *n char(10); *n char(6); end-pr; JobString = %trimr(f_BuildString('JOB(&/&/&)': p_JobNum: p_JobUser: p_JobName)); 1b if p_Option = 2; f_RunCmd('?CHGJOB ' + JobString); msg = 'Chgjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 3; f_RunCmd('STRSRVJOB ' + JobString); msg = 'Strsrvjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 4; f_RunCmd('ENDJOB ' + JobString + ' OPTION(*IMMED)'); msg = 'Endjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 5; f_RunCmd('DSPJOB ' + JobString); msg = 'Dspjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 6; f_RunCmd('HLDJOB ' + JobString); msg = 'Hldjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 7; f_RunCmd('RLSJOB ' + JobString); msg = 'Rlsjob for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 8; f_RunCmd('DSPJOB ' + JobString + ' OPTION(*SPLF)'); msg = 'Wrksplf for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 9; callp(e) p_JCRJOBSIOR(p_JobName: p_JobUser: p_JobNum); msg = 'Job File I/O for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 10; f_RunCmd('?STRDBG'); msg = 'STRDBG for ' + %trimr(p_JobName) + ' - started'; 1x elseif p_Option = 15; f_RunCmd('ENDSRVJOB'); msg = 'ENDSRVJOB for ' + %trimr(p_JobName) + ' - completed'; 1x elseif p_Option = 20; f_RunCmd('ENDDBG'); msg = 'ENDDBG ' + %trimr(p_JobName) + ' - completed'; 1x else; msg = 'Option ' + %char(p_Option) + ' is not available.'; 1e endif; snd-msg msg %target(p_ProgId); return; end-proc; //--------------------------------------------------------- // Execute selected command for Spooled Files //--------------------------------------------------------- dcl-proc f_RunOptionSplf export; dcl-pi *n; p_Option char(1); p_SplfName char(10); p_SplfNum char(6); p_JobName char(10); p_JobUser char(10); p_JobNum char(6); p_ProgId char(10); end-pi; dcl-s Msg char(75); dcl-s SpoolString varchar(120); dcl-s Email char(150); SpoolString = %trimr(f_BuildString ('FILE(&) JOB(&/&/&) SPLNBR(&)': p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); //------------------------------- 1b if p_Option = '1'; f_RunCmd('?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; 1x elseif p_Option = 'S'; email = f_GetEmail(); SpoolString = %trimr(f_BuildString ('SPLF(&) JOB(&/&/&) SPLFN(&)': p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); f_RunCmd('?SNDSPLF ' + SpoolString + ' ??TOLIST(' + %trimr(Email) + ') ' + ' ??FRADR(' + %trimr(Email) + ') ' + ' ??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; 1x elseif p_Option = 'E'; email = f_GetEmail(); SpoolString = %trimr(f_BuildString ('RECIPIENT(&) ATTLIST((* *PDF *N & &/&/& &))': Email: p_SplfName: p_JobNum: p_JobUser: p_JobName: p_SplfNum)); f_RunCmd('?ESEND/ESNDMAIL ' + SpoolString); 2b if ApiErrDS.BytesReturned = 0; msg = 'Esend ' + %trimr(p_SplfName) + ' - completed'; 2x else; msg = 'Esend ' + %trimr(p_SplfName) + ' - Canceled'; 2e endif; 1x elseif p_Option = '2'; f_RunCmd('?CHGSPLFA ' + SpoolString); 2b if ApiErrDS.BytesReturned = 0; msg = 'Change ' + %trimr(p_SplfName) + ' - completed'; 2x else; msg = 'Change ' + %trimr(p_SplfName) + ' - Canceled'; 2e endif; 1x elseif p_Option = '3'; f_RunCmd('HLDSPLF ' + SpoolString); msg = 'Hold Spooled File ' + %trimr(p_SplfName) + ' - completed'; 1x elseif p_Option = '4'; f_RunCmd('DLTSPLF ' + SpoolString); msg = 'Delete Spooled File ' + %trimr(p_SplfName) + ' - completed'; 1x elseif p_Option = '5'; f_RunCmd('DSPSPLF ' + SpoolString); msg = 'Display Spooled File ' + %trimr(p_SplfName) + ' - completed'; 1x elseif p_Option = '6'; f_RunCmd('RLSSPLF ' + SpoolString); msg = 'Release Spooled File ' + %trimr(p_SplfName) + ' - completed'; 1x elseif p_Option = '8'; f_RunCmd('WRKSPLFA ' + SpoolString); msg = 'Work Spooled File Attributes ' + %trimr(p_SplfName) + ' - completed'; 1x elseif p_Option = '9'; f_RunCmd('?CPYSPLF ' + SpoolString + ' ??TOFILE( )'); 2b if ApiErrDS.BytesReturned = 0; msg = 'Copy ' + %trimr(p_SplfName) + ' - completed'; 2x else; msg = 'Copy ' + %trimr(p_SplfName) + ' - Canceled'; 2e endif; 1x elseif p_Option = 'H'; f_RunCmd('?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; 1x else; msg = 'Invalid Option Selected.'; 1e endif; snd-msg msg %target(p_ProgId); return; end-proc; //--------------------------------------------------------- // return shuffled deck of 52 cards (numeric values and suite info) //--------------------------------------------------------- dcl-proc f_ShuffleDeck export; dcl-pi *n char(2) dim(52); end-pi; dcl-s aa uns(3); dcl-s bb uns(3); dcl-s cc uns(3) inz(0); dcl-s ShuffledDeck char(2) dim(52); dcl-ds NewDeck len(2) dim(52) inz qualified; NewCard uns(3); NewSuite char(1); end-ds; // load fresh deck 1b for aa = 1 to 4; 2b for bb = 1 to 13; 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. 1b for aa = 52 downto 1; bb = f_GetRandom(aa); ShuffledDeck(aa) = NewDeck(bb); // replace just dealt card with current last card NewDeck(bb) = NewDeck(aa); 1e endfor; return ShuffledDeck; end-proc; //--------------------------------------------------------- // Send Status messages //--------------------------------------------------------- dcl-proc f_SndStatMsg export; dcl-pi *n; p_MsgTxt char(75) const; end-pi; callp QMHSNDPM( 'CPF9898': 'QCPFMSG *LIBL': p_MsgTxt: 75: '*STATUS': '*EXT': 1: ' ': ApiErrDS); return; end-proc; //--------------------------------------------------------- // uses new v7r1 qzipzip api to zip on IFS drive // jcrcompost added this entry cause IBM forgot. // ADDBNDDIRE BNDDIR(QUSAPIBD) OBJ((QZIPUTIL)) //--------------------------------------------------------- dcl-proc f_ZipIFS export; dcl-pi *n; p_SrcMbr char(10); p_SrcAttr char(10); p_IfsDir char(50); end-pi; dcl-pr QzipZip extproc(*cwiden:*dclcase); *n likeds(FileToZip); *n likeds(ZipFile); *n char(8) const; *n like(zipoptions); *n like(ApiErrds); end-pr; dcl-ds ZipOptions qualified align; *n char(10) pos(1) inz('*NONE'); // verbose *n char(6) pos(11) inz('*ALL'); // subtree *n char(512) pos(17) inz(*blanks); // comment *n uns(10) pos(529) inz(0); // comment length end-ds; dcl-ds FileToZip qualified; *n int(10) inz(0) pos(1); // ccsid *n char(2) inz(*allx'00') pos(5); // country *n char(3) inz(*allx'00') pos(7); // language *n char(3) inz(*allx'00') pos(10); // reserved *n int(10) inz(0) pos(13); // type pathlength int(10) inz(0) pos(17); *n char(2) inz('/ ') pos(21); // delimiter *n char(10) inz(*allx'00') pos(23); // reserved pathname char(128) inz(*blanks) pos(33); end-ds; dcl-ds ZipFile likeds(FileToZip); ZipFile = FileToZip; // load original ds inz values to likeds FileToZip.pathname = %trimr(p_IfsDir) + %trimr(p_SrcMbr) + '.' + p_SrcAttr; ZipFile.pathname = %trimr(p_IfsDir) + '/' + %trimr(p_SrcMbr) + '.zip'; FileToZip.pathlength = %len(%trimr(FileToZip.pathname)); ZipFile.pathlength = %len(%trimr(ZipFile.pathname)); QzipZip(FileToZip: ZipFile: 'ZIP00100': ZipOptions: ApiErrds); return; end-proc; ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&L) DCL VAR(&L) TYPE(*CHAR) LEN(10) /* install library */ DCL VAR(&F) TYPE(*CHAR) LEN(10) VALUE('JCRCMDS') DCL VAR(&N) TYPE(*CHAR) LEN(10) DCL VAR(&MBRTYPE) TYPE(*CHAR) LEN(10) DCL VAR(&MBRTEXT) TYPE(*CHAR) LEN(50) DCL VAR(&FLAG) TYPE(*CHAR) LEN(10) DCL VAR(&STRING) TYPE(*CHAR) LEN(200) /*---------------------------------------------------*/ /*---------------------------------------------------*/ /* one time so zip utilities will compile */ /* this omission will hopefully be fixed in a PTF */ ADDBNDDIRE BNDDIR(QUSAPIBD) OBJ((QZIPUTIL)) /*---------------------------------------------------*/ /*---------------------------------------------------*/ RMVLIBLE LIB(&L) MONMSG MSGID(CPF0000) ADDLIBLE LIB(&L) POSITION(*FIRST) CHGCURLIB CURLIB(&L) /* so DDL will create correctly */ /*-------------------------------------------------------------------*/ /* 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(*SOURCE) STGMDL(*TERASPACE) CRTSRVPGM SRVPGM(&L/JCRCMDSSRV) SRCFILE(&L/&F) + SRCMBR(JCRCMDSBND) TEXT('JCRCMDS service + program') OPTION(*DUPPROC) + STGMDL(*TERASPACE) ARGOPT(*NO) IPA(*NO) DLTMOD MODULE(&L/JCRCMDSSRV) CRTBNDDIR BNDDIR(&L/JCRCMDSDIR) TEXT('utility binding + directory') ADDBNDDIRE BNDDIR(&L/JCRCMDSDIR) OBJ((&L/JCRCMDSSRV + *SRVPGM *DEFER)) POSITION(*FIRST) DLTF FILE(&L/JCRBNDFB) MONMSG MSGID(CPF0000) DSPBNDDIR BNDDIR(&L/JCRCMDSDIR) OUTPUT(*OUTFILE) + OUTFILE(&L/JCRBNDFB) /*- 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') /*-------------------------------------------------------------------*/ /* spin though member list-----------------------------------------*/ SUBR SUBR(srSpinMbr) RTVMBRD FILE(&L/&F) MBR(*FIRSTMBR *SAME) RTNMBR(&N) + SRCTYPE(&MBRTYPE) TEXT(&MBRTEXT) LOOP: CALLSUBR SUBR(SRPROCESS) RTVMBRD FILE(&L/&F) MBR(&N *NEXT) RTNMBR(&N) + SRCTYPE(&MBRTYPE) TEXT(&MBRTEXT) MONMSG MSGID(CPF3049 CPF3019) EXEC(GOTO CMDLBL(DONE)) GOTO CMDLBL(LOOP) DONE: ENDSUBR /*-------------------------------------------------------------------*/ SUBR SUBR(SRPROCESS) 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 = 'DDL' *OR &MBRTYPE = 'DSPF' + *OR &MBRTYPE = 'PRTF' *OR &MBRTYPE = + 'PF') THEN(DO) DLTF FILE(&L/&N) MONMSG MSGID(CPF0000) SELECT WHEN COND(&MBRTYPE = 'DDL') THEN(RUNSQLSTM + SRCFILE(&L/&F) SRCMBR(&N) COMMIT(*NONE)) 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(DO) /* compile menu CLs after commands are created */ IF COND(&N *NE 'JCRSUNDRYC' *AND &N *NE + 'JCRXMLC') THEN(DO) CRTBNDCL PGM(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) + DBGVIEW(*SOURCE) ENDDO ENDDO WHEN COND(&MBRTYPE = 'RPGLE') THEN(CRTBNDRPG + PGM(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) + DBGVIEW(*SOURCE)) /*------------------------------------------------------------------------*/ /* Executing QCMDEXC allows JCRCOMPOST to compile even if this system */ /* does not have the SQL compiler installed. Delete JCRDUMP command if so */ /*------------------------------------------------------------------------*/ WHEN COND(&MBRTYPE = 'SQLRPGLE') THEN(DO) CHGVAR VAR(&STRING) VALUE('CRTSQLRPGI OBJ(' *CAT + &L *TCAT '/' *CAT &N *TCAT ') SRCFILE(' + *CAT &L *TCAT '/' *CAT &F *TCAT ') + SRCMBR(' *CAT &N *TCAT ') COMMIT(*NONE) + DBGVIEW(*SOURCE)') CALL PGM(QCMDEXC) PARM(&STRING 200) MONMSG MSGID(CPF0000) EXEC(DO) DLTCMD CMD(&L/JCRDUMP) MONMSG MSGID(CPF0000) ENDDO ENDDO 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(*CMD) CRTCMD CMD(&L/JCRANZO) PGM(*LIBL/JCRANZOR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRANZOV) + HLPPNLGRP(*LIBL/JCRANZOH) HLPID(*CMD) CRTCMD CMD(&L/JCRANZP) PGM(*LIBL/JCRANZPC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRANZPV) + HLPPNLGRP(*LIBL/JCRANZPH) HLPID(*CMD) CRTCMD CMD(&L/JCRBND) PGM(*LIBL/JCRBNDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRBNDV) + HLPPNLGRP(*LIBL/JCRBNDH) HLPID(*CMD) CRTCMD CMD(&L/JCRCALL) PGM(*LIBL/JCRCALLR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRCALLV) + HLPPNLGRP(*LIBL/JCRCALLH) HLPID(*CMD) + PMTOVRPGM(*LIBL/JCRCALLO) CRTCMD CMD(&L/JCRDQD) PGM(*LIBL/JCRDQDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDQDH) HLPID(*CMD) CRTCMD CMD(&L/JCRDQE) PGM(*LIBL/JCRDQER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDQEH) HLPID(*CMD) CRTCMD CMD(&L/JCRMIKE) PGM(*LIBL/JCRMIKER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRMIKEH) HLPID(*CMD) CRTCMD CMD(&L/JCRDTAARA) PGM(*LIBL/JCRDTAARAR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALLIBV) + HLPPNLGRP(*LIBL/JCRDTAARAH) HLPID(*CMD) CRTCMD CMD(&L/JCRDUMP) PGM(*LIBL/JCRDUMPR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRDUMPH) HLPID(*CMD) CRTCMD CMD(&L/JCRDUPKEY) PGM(*LIBL/JCRDUPKEYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRDUPKEYH) HLPID(*CMD) CRTCMD CMD(&L/JCRFD) PGM(*LIBL/JCRFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFDV) + HLPPNLGRP(*LIBL/JCRFDH) HLPID(*CMD) CRTCMD CMD(&L/JCRDBR) PGM(*LIBL/JCRFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFDV) + HLPPNLGRP(*LIBL/JCRDBRH) HLPID(*CMD) CRTCMD CMD(&L/JCRFFD) PGM(*LIBL/JCRFFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFFDV) + HLPPNLGRP(*LIBL/JCRFFDH) HLPID(*CMD) CRTCMD CMD(&L/JCRDDL) PGM(*LIBL/JCRDDLR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRDDLV) + HLPPNLGRP(*LIBL/JCRDDLH) HLPID(*CMD) CRTCMD CMD(&L/JCRJOBD) PGM(*LIBL/JCRJOBDR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRJOBDH) + HLPID(*CMD) CRTCMD CMD(&L/JCRFSET) PGM(*LIBL/JCRFSETS) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFSETV) + HLPPNLGRP(*LIBL/JCRFSETH) HLPID(*CMD) CRTCMD CMD(&L/JCRGAMES) PGM(*LIBL/JCRGAMESC) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRGAMESH) + HLPID(*CMD) CRTCMD CMD(&L/JCRPRGEN) PGM(*LIBL/JCRPRGENR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPRGENV) + HLPPNLGRP(*LIBL/JCRPRGENH) HLPID(*CMD) + PMTOVRPGM(*LIBL/JCRPRGENO) CRTCMD CMD(&L/JCRHFD) PGM(*LIBL/JCRHFDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRHFDV) + HLPPNLGRP(*LIBL/JCRHFDH) HLPID(*CMD) CRTCMD CMD(&L/JCRIFSCPY) PGM(*LIBL/JCRIFSCPYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSCPYV) + HLPPNLGRP(*LIBL/JCRIFSCPYH) HLPID(*CMD) CRTCMD CMD(&L/JCRIFSMBR) PGM(*LIBL/JCRIFSMBRR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSMBRV) + HLPPNLGRP(*LIBL/JCRIFSMBRH) HLPID(*CMD) CRTCMD CMD(&L/JCRIFSSAV) PGM(*LIBL/JCRIFSSAVR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRIFSSAVV) + HLPPNLGRP(*LIBL/JCRIFSSAVH) HLPID(*CMD) CRTCMD CMD(&L/JCRIND) PGM(*LIBL/JCRINDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRINDV) + HLPPNLGRP(*LIBL/JCRINDH) HLPID(*CMD) CRTCMD CMD(&L/JCRJOBS) PGM(*LIBL/JCRJOBSR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRJOBSH) + HLPID(*CMD) /* keep jcrjob name for command */ CRTPRXCMD CMD(&L/JCRJOB) TGTCMD(&L/JCRJOBS) CRTCMD CMD(&L/JCRLKEY) PGM(*LIBL/JCRLKEYR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRFDV) + HLPPNLGRP(*LIBL/JCRLKEYH) HLPID(*CMD) CRTCMD CMD(&L/JCRLOG) PGM(*LIBL/JCRLOGR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRLOGH) + HLPID(*CMD) CRTCMD CMD(&L/JCRLSRC) PGM(*LIBL/JCRLSRCR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRLSRCV) + HLPPNLGRP(*LIBL/JCRLSRCH) HLPID(*CMD) CRTCMD CMD(&L/JCRMRBIG) PGM(*LIBL/JCRMRBIGR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRMRBIGH) + HLPID(*CMD) CRTCMD CMD(&L/JCRNETFF) PGM(*LIBL/JCRNETFFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNETFFV) + HLPPNLGRP(*LIBL/JCRNETFFH) HLPID(*CMD) CRTCMD CMD(&L/JCRNETFM) PGM(*LIBL/JCRNETFMR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNETFMV) + HLPPNLGRP(*LIBL/JCRNETFMH) HLPID(*CMD) CRTCMD CMD(&L/JCRNETQ) PGM(*LIBL/JCRNETQR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRNETQH) HLPID(*CMD) CRTCMD CMD(&L/JCRNOTPOP) PGM(*LIBL/JCRNOTPOPR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNOTPOPV) + HLPPNLGRP(*LIBL/JCRNOTPOPH) HLPID(*CMD) CRTCMD CMD(&L/JCRNUMB) PGM(*LIBL/JCRNUMBR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRNUMBV) + HLPPNLGRP(*LIBL/JCRNUMBH) HLPID(*CMD) CRTCMD CMD(&L/JCROBJD) PGM(*LIBL/JCROBJDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALLIBV) + HLPPNLGRP(*LIBL/JCROBJDH) HLPID(*CMD) CRTCMD CMD(&L/JCROLCK) PGM(*LIBL/JCROLCKR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCROLCKH) HLPID(*CMD) CRTCMD CMD(&L/JCRPARTI) PGM(*LIBL/JCRPARTIR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRPARTIH) + HLPID(*CMD) CRTCMD CMD(&L/JCRPATTR) PGM(*LIBL/JCRPATTRR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPATTRV) + HLPPNLGRP(*LIBL/JCRPATTRH) HLPID(*CMD) CRTCMD CMD(&L/JCRPRTF) PGM(*LIBL/JCRPRTFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPRTFV) + HLPPNLGRP(*LIBL/JCRPRTFH) HLPID(*CMD) CRTCMD CMD(&L/JCRSDENT) PGM(*LIBL/JCRSDENTR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/JCRSDENTH) HLPID(*CMD) CRTCMD CMD(&L/JCRRECRT) PGM(*LIBL/JCRRECRTR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) + HLPPNLGRP(*LIBL/JCRRECRTH) HLPID(*CMD) CRTCMD CMD(&L/JCRRFIL) PGM(*LIBL/JCRRFILR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRRFILV) + HLPPNLGRP(*LIBL/JCRRFILH) HLPID(*CMD) CRTCMD CMD(&L/JCRRFLD) PGM(*LIBL/JCRRFLDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRRFLDV) + HLPPNLGRP(*LIBL/JCRRFLDH) HLPID(*CMD) CRTCMD CMD(&L/JCRRTVRPG) PGM(*LIBL/JCRRTVRPGC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRRTVRPGV) + HLPPNLGRP(*LIBL/JCRRTVRPGH) HLPID(*CMD) CRTCMD CMD(&L/JCRSMLT) PGM(*LIBL/JCRSMLTRS) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRSMLTV) + HLPPNLGRP(*LIBL/JCRSMLTH) HLPID(*CMD) CRTCMD CMD(&L/JCRSPLF) PGM(*LIBL/JCRSPLFR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRSPLFV) + HLPPNLGRP(*LIBL/JCRSPLFH) HLPID(*CMD) CRTCMD CMD(&L/JCRSSQL) PGM(*LIBL/JCRSSQLC) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRSSQLH) + HLPID(*CMD) CRTCMD CMD(&L/JCRSCDE) PGM(*LIBL/JCRSCDER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRSCDEV) + HLPPNLGRP(*LIBL/JCRSCDEH) HLPID(*CMD) CRTCMD CMD(&L/JCRSUNDRY) PGM(*LIBL/JCRSUNDRYC) + SRCFILE(&L/&F) + HLPPNLGRP(*LIBL/JCRSUNDRYH) HLPID(*CMD) CRTCMD CMD(&L/JCRUFIND) PGM(*LIBL/JCRUFINDR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRUFINDV) + HLPPNLGRP(*LIBL/JCRUFINDH) HLPID(*CMD) CRTCMD CMD(&L/JCRUSPACE) PGM(*LIBL/JCRUSPACER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRUSPACEV) + HLPPNLGRP(*LIBL/JCRUSPACEH) HLPID(*CMD) CRTCMD CMD(&L/JCRUSERS) PGM(*LIBL/JCRUSERSR) + SRCFILE(&L/&F) HLPPNLGRP(*LIBL/JCRUSERSH) + HLPID(*CMD) CRTCMD CMD(&L/JCRUSRAUT) PGM(*LIBL/JCRUSRAUTR) + SRCFILE(&L/&F) + HLPPNLGRP(*LIBL/JCRUSRAUTH) HLPID(*CMD) CRTCMD CMD(&L/JCR4MAX) PGM(*LIBL/JCR4MAXC) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCR4MAXV) + HLPPNLGRP(*LIBL/JCR4MAXH) HLPID(*CMD) CRTCMD CMD(&L/JCRPROTO) PGM(*LIBL/JCRPROTOR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPROTOV) + HLPPNLGRP(*LIBL/JCRPROTOH) HLPID(*CMD) /* old fixed column convertor was requested to stay */ CRTCMD CMD(&L/JCR4PROTO) PGM(*LIBL/JCR4PROTOR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRPROTOV) + HLPPNLGRP(*LIBL/JCR4PROTOH) HLPID(*CMD) CRTCMD CMD(&L/JCRFREESS) PGM(*LIBL/JCRFREESSR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRRFILV) + HLPPNLGRP(*LIBL/JCRFREESSH) HLPID(*CMD) CRTCMD CMD(&L/JCR5FREE) PGM(*LIBL/JCR5FREER) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCR5FREEV) + HLPPNLGRP(*LIBL/JCR5FREEH) HLPID(*CMD) CRTCMD CMD(&L/XMLGEN) PGM(*LIBL/XMLGENR) + SRCFILE(&L/&F) VLDCKR(*LIBL/XMLGENV) + HLPPNLGRP(*LIBL/XMLGENH) HLPID(*CMD) 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(*CMD) CRTCMD CMD(&L/XMLSRCFIL) PGM(*LIBL/XMLSRCFILC) + SRCFILE(&L/&F) VLDCKR(*LIBL/XMLSRCFILV) + HLPPNLGRP(*LIBL/XMLSRCFILH) HLPID(*CMD) CRTCMD CMD(&L/XMLSCRIPT) PGM(*LIBL/XMLSCRIPTR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) + HLPPNLGRP(*LIBL/XMLSCRIPTH) HLPID(*CMD) CRTCMD CMD(&L/JCRXML) PGM(*LIBL/JCRXMLC) + SRCFILE(&L/&F) VLDCKR(*NONE) + HLPPNLGRP(*LIBL/JCRXMLH) HLPID(*CMD) CRTCMD CMD(&L/JCRROUGH) PGM(*LIBL/JCRROUGHR) + SRCFILE(&L/&F) VLDCKR(*LIBL/JCRROUGHV) + HLPPNLGRP(*LIBL/JCRROUGHH) HLPID(*CMD) /* compile menu CLs after commands are created */ CRTBNDCL PGM(&L/JCRSUNDRYC) SRCFILE(&L/&F) + SRCMBR(JCRSUNDRYC) DBGVIEW(*ALL) CRTBNDCL PGM(&L/JCRXMLC) SRCFILE(&L/&F) + SRCMBR(JCRXMLC) DBGVIEW(*ALL) ENDSUBR ENDPGM ]]> */ /*--------------------------------------------------------------------------*/ 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) STGMDL(*TERASPACE) CRTSRVPGM SRVPGM(&L/JCRCMDSSRV) SRCFILE(&L/&F) + SRCMBR(JCRCMDSBND) TEXT('JCRCMDS service + program') OPTION(*DUPPROC) + STGMDL(*TERASPACE) ARGOPT(*NO) IPA(*NO) DLTMOD MODULE(&L/JCRCMDSSRV) ENDPGM ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Expanded Data Base Relations') PARM KWD(MBR) TYPE(*CHAR) LEN(10) CONSTANT('*FIRST') PARM KWD(FILE) TYPE(FILE) MIN(1) CHOICE('Long or + Short File Name') PROMPT('File') FILE: QUAL TYPE(*NAME) LEN(130) 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(101) CONSTANT(' ') PARM KWD(MBRTYPE) TYPE(*CHAR) LEN(10) CONSTANT('*ALL') ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRDBRF; CREATE TABLE JCRDBRF ( JDBRPF CHAR(10) NOT NULL DEFAULT '' , JDBRPL CHAR(10) NOT NULL DEFAULT '' , JDBRLF CHAR(10) NOT NULL DEFAULT '' , JDBRLL CHAR(10) NOT NULL DEFAULT '') RCDFMT JCRDBRFR ; LABEL ON TABLE JCRDBRF IS 'Data base relations - outfile jcr' ; LABEL ON COLUMN JCRDBRF ( JDBRPF TEXT IS 'PF' , JDBRPL TEXT IS 'PF Lib' , JDBRLF TEXT IS 'Logical' , JDBRLL TEXT IS 'LF Lib' ); GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRDBRF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Displays subfile of data base relations. Logical select/omit statements can be included or excluded.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRDBR/FILE'.File - Help :XH3.File (FILE) :P.File whose data base relations are to be retrieved.:EHELP.:EPNLGRP. ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate Data Definition Mbr') 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(OBJTYPE) TYPE(*CHAR) LEN(10) RSTD(*YES) + DFT(TABLE) VALUES(TABLE VIEW CONSTRAINT + FUNCTION INDEX PROCEDURE SCHEMA ALIAS + TRIGGER TYPE VIEW) PROMPT('Database + Object Type') PARM KWD(DDLMBR) TYPE(*NAME) MIN(1) PROMPT('New + source member to generate') PARM KWD(DDLFIL) TYPE(SRCFILE) PROMPT('Source file') SRCFILE: QUAL TYPE(*NAME) DFT(QDDSSRC) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) + PROMPT('Library') ]]> .*-------------------------------------------------------------------- :P.Creates Data Definition Language source member from the selected data base object. :P.After member generation, prompt RUNSQLSTM to execute the member statements. :EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRDDL/FILE'.File - Help :XH3.File (FILE) :P.Name and library of file to have ddl specs created.:EHELP. :HELP NAME='JCRDDL/OBJTYPE'.Database Object Type - Help :XH3.ObjType (OBJTYPE) :P.Type of data base object.:EHELP. :HELP NAME='JCRDDL/DDLMBR'.New source member to generate - Help :XH3.New source member to generate (DDLMBR) :P.Member name to be generated by utility. If member exists, the contents will be replaced.:EHELP. :HELP NAME='JCRDDL/DDLFIL'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file that will contain the source member.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRDDLR - Generate data definition language member //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_SndCompMsg /define f_GetQual // *ENTRY /define p_JCRDDLR /COPY JCRCMDS,JCRCMDSCPY // Generate Data Definition Language dcl-pr QSQGNDDL extpgm('QSQGNDDL'); *n like(sqlr0100DS); *n int(10) const; *n char(8) const; *n like(apierrds); end-pr; dcl-ds sqlr0100DS qualified inz; ObjNam char(258) pos(1); ObjLib char(258) pos(259); ObjTyp char(10) pos(517); SrcFil char(10) pos(527); SrcLib char(10) pos(537); SrcMbr char(10) pos(547); SecLvl int(10) pos(557) inz(10); Replace char(1) pos(561) inz('1'); // clear source member Formatting char(1) pos(562) inz('0'); // no additonal formatting DateFormat char(3) pos(563) inz('ISO'); DateSeparator char(1) pos(566) inz('-'); TimeFormat char(3) pos(567) inz('ISO'); TimeSeparator char(1) pos(570) inz(':'); NamingOption char(3) pos(571) inz('SYS'); // lib/file DecimalPoint char(1) pos(574) inz('.'); StandardsOption char(1) pos(575) inz('0'); // db2 standards DropOption char(1) pos(576) inz('1'); // do not generate MessageLevel int(10) pos(577) inz(0); CommentOption char(1) pos(581) inz('0'); // no comments LabelOption char(1) pos(582) inz('1'); // generate label on HeaderOption char(1) pos(583) inz('1'); // generate header Reserved char(1) pos(584) inz(x'00'); end-ds; sqlr0100DS.ObjNam = %subst(p_InFileQual: 1: 10); sqlr0100DS.ObjLib = %subst(p_InFileQual: 11: 10); sqlr0100DS.ObjTyp = p_ObjTyp; sqlr0100DS.SrcFil = %subst(p_OutFileQual: 1: 10); sqlr0100DS.SrcLib = %subst(p_OutFileQual: 11: 10); sqlr0100DS.SrcMbr = p_OutMbr; callp QSQGNDDL( sqlr0100DS: %len(sqlr0100DS): 'SQLR0100': ApiErrDS); f_SndCompMsg('Data Definition Generation member ' + %trimr(p_OutMbr) + ' in ' + %trimr(f_GetQual(p_OutFileQual)) + ' - completed.'); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRDDLV - Validity checking program for lib/file/member //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_Qusrobjd /define f_RtvMsgAPI /define f_SndEscapeMsg /define f_SrcFileAddPfm /define f_CheckObj // *ENTRY /define p_JCRDDLR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- QusrObjDS = f_QUSROBJD(p_InFileQual: '*FILE'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; f_CheckObj(p_OutFileQual: '*FILE'); f_SrcFileAddPfm(p_OutFileQual: p_OutMbr: 'DDL': QusrObjDS.Text); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Data Queue Description Display') PARM KWD(DTAQ) TYPE(DATAQ) MIN(1) PROMPT('Data Queue') DATAQ: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*DTAQ') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA07 CA12 PRINT 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 EDTCDE(Y) 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) A 23 39'F7=View Dataq Entries' A COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Displays data queue 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. ]]> '); //--------------------------------------------------------- // JCRDQDR - Data queue description display //--------------------------------------------------------- /define ControlStatements /define FunctionKeys /define Dspatr /define Qmhqrdqd /define f_GetQual /define f_GetDayName /define f_BuildString /define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRDQDD workstn infds(infds); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; //-----Data queue entries display-------------- dcl-pr p_JCRDQER extpgm('JCRDQER'); *n char(20); // p_dtaqnamequal *n char(10); // p_dtaqobjtype end-pr; //--*ENTRY------------------------------------------------- dcl-pi *n; p_NameQual char(20); p_ObjType char(10); // used by validity checker program end-pi; //--------------------------------------------------------- scDow = f_GetDayName(); 1b dow *on; callp QMHQRDQD( QmhqrdqdDS: %size(QmhqrdqdDS): 'RDQD0100': p_NameQual); 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; 2b if InfdsFkey in %list(f03 :f12); f_SndCompMsg('JCRDQD for ' + f_GetQual(p_NameQual) + ' - completed'); *inlr = *on; return; 2e endif; 2b If InfdsFkey = f07; callp p_JCRDQER(p_NameQual: p_ObjType); 2e endif; 1e enddo; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Data Queue Entries Display') PARM KWD(DTAQ) TYPE(DTAQ) MIN(1) PROMPT('Data Queue') DTAQ: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*DTAQ') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A CA03 A CA05 A CA06 A CA10 A CA11 A CA12 A CA19 A CA20 A PAGEUP A PAGEDOWN A INDARA A PRINT 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 EDTCDE(Y) COLOR(BLU) A 2 2'Name:' A SCOBJHEAD 63 O 2 8 A 2 72SYSNAME 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) A *DS3 SFLSIZ(0008) A *DS4 SFLSIZ(0008) A *DS3 SFLPAG(0007) A *DS4 SFLPAG(0007) A OVERLAY A SFLMODE(&VSFLMODE) A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A 34 SFLEND(*MORE) A 06 SFLDROP(CA13) A N06 SFLFOLD(CA13) A VSFLMODE 1A H A VSRECNUM 4S 0H SFLRCDNBR A 20 2' - A - A ' A DSPATR(UL) A 21 2'Position to Entry:' A VENTNUM 9Y 0B 21 21EDTCDE(4) A DSPATR(HI) A CHANGE(23) A VQTOTCNT 9Y 0O 21 49EDTCDE(4) A 21 59'Total Queue Entries' A 22 2'Shift to column:' A 31 VDSPPOS 5Y 0B 22 21EDTCDE(4) A DSPATR(HI) A 31 VPOS 5Y 0O 22 32EDTCDE(4) A 22 38'Current Column' A 23 2'F3=Exit' A COLOR(BLU) A 23 13'F5=Refresh' A COLOR(BLU) A 23 26'F6=Last Entry' A COLOR(BLU) A 23 41'F10=Hex' A COLOR(BLU) A 23 51'F11=UnFold/Fold' A COLOR(BLU) A 23 68'F12=Cancel' A COLOR(BLU) A N31 24 2'No Entries in data queue.' A DSPATR(HI) A DSPATR(RI) A 31 04N05 24 2'F14=Display Key' A COLOR(BLU) A 31 04 05 24 2'F14=Display Entry' A COLOR(BLU) A 24 45'Shift F7=Left' A COLOR(BLU) A 24 62'Shift F8=Right' A COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Executes API to view data queue entries without disturbing entries on the queue.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRDQE/DTAQ'.Data Queue - Help :XH3.Data Queue (DTAQ) :P.Name and library of dataq to be viewed.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRDQER - Data queue entries display // call QmhrdQm API for no-touch display of dataq entries as messages. //--------------------------------------------------------- // Note storage model was changed to teraspace to accommodate large // number of entries data queues. // Additional changes to pull page-at-a-time from allocated memory, page down, // and position to list entry number to allow for over 9999 entries in queue. // use list entry number positioning instead of screen number based positioning. // Add a show last entry button. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRDQED workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Cvthc /define Infds /define FunctionKeys /define Ind /define Qmhqrdqd /define f_BuildString /define f_GetDayName /define f_DecodeApiTimeStamp /COPY JCRCMDS,JCRCMDSCPY dcl-s TempqDS char(116); dcl-s ColumnShift int(10); dcl-s ForCount int(10); dcl-s ofs int(10); dcl-s qTrimLen int(10); dcl-s v0200len int(10); dcl-s xx int(10); dcl-s BytesAvail int(10); dcl-s ff uns(5); dcl-s Shift uns(5) inz(58); dcl-s IsHexMode ind; dcl-c cSflPag const(7); dcl-c Hex40 const(x'40'); dcl-s PageSize uns(3) inz(14); dcl-s StartPtr pointer inz(*null); dcl-s EntryCount uns(3); dcl-c cRuler1 const('....+....1....+....2....+....3....+....4....+....5- ....+....6....+....7....+....8....+....9....+....0....+....1....+....2.- ...+....3....+....4....+....5....+....6....+....7....+....8....+....9..- ..+....0....+....1....+....2'); dcl-c cRuler2 const('. . . . + . . . . 1 . . . . + . . . . 2 . . . . + - . . . . 3 . . . . + . . . . 4 . . . . + . . . . 5 . . . . + . . . . 6 .- . . . + . . . . 7 . . . . + . . . . 8 . . . . + . . . . 9 . . . . + . - . . . 0 . . . . + . . . . 1 . . . . + . . . . 2 . . . . + . . . . 3 . .- . . + . . . . 4 . . . . + . . . . 5 . . . . + . . . . 6 . . . . + . . - . . 7 . . . . + . . . . 8 . . . . + . . . . 9 . . . . + . . . . 0 '); //--------------------------------------------------------- // Retrieve Data Queue Message dcl-pr QmhrdQm extpgm('QMHRDQM'); *n like(QmhrdQmDS) options(*varsize); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20); // dtaq and lib *n like(RDQS0200DS) options(*varsize) const; // key information *n int(10) const; // key info length *n char(8) const; // information *n like(ApiErrDS) options(*varsize); end-pr; dcl-ds QmhrdQmDS qualified based(QMHRDQMPtr); BytesReturned int(10) pos(1); BytesAvail int(10) pos(5); MsgRtnCount int(10) pos(9); MsgAvlCount int(10) pos(13); KeyLenRtn int(10) pos(17); KeyLenAvl int(10) pos(21); MsgTxtRtn int(10) pos(25); MsgTxtAvl int(10) pos(29); EntryLenRtn int(10) pos(33); EntryLenAvl int(10) pos(37); OffsetToEntry int(10) pos(41); DtaqLib char(10) pos(45); end-ds; // Move pointer through message entries dcl-ds ListEntryDS qualified based(ListEntryPtr); NextEntry int(10); Datetime char(8); // TOD format MessageData char(1000); // variable text end-ds; // Message selection - RDQS0100 nonkeyed queues RDQS0200 Keyed data queues dcl-ds rdqs0100DS qualified; Selection char(1) pos(1) inz('A'); // all MsgByteRtv int(10) pos(5) inz; // message bytes to rtv end-ds; dcl-ds rdqs0200DS qualified; Selection char(1) inz('K') pos(1); // Keyed KeyOrder char(2) inz('GE') pos(2); MsgByteRtv int(10) inz pos(5); // message bytes to rtv KeyByteRtv int(10) inz pos(9); // keys bytes to rtv KeyLen int(10) inz pos(13); // key length Key char(256) pos(17); // key value end-ds; // Divide entry up into subfile fields dcl-ds ViewqDS inz; Viewq1; Viewq2; end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_DtaqNameQual char(20); p_DtaqObjType char(10); end-pi; //--------------------------------------------------------- vSflMode = *on; ind.sfldrop = vSflMode; vpos = 1; QMHRDQMptr = %alloc(1); scDow = f_GetDayName(); // retrieve data queue description callp QMHQRDQD( QmhqrdqdDS: %size(QmhqrdqdDS): 'RDQD0100': p_DtaqNameQual); exsr srRefresh; // Display subfile. Calc number of screens in subfile. vSrecNum = 1; ColumnShift = 0; sEntryLen = QmhqrdqdDS.MsgLength; vQTotCnt = QmhrdQmDS.MsgAvlCount; scObjHead = f_BuildString('& & &': %subst(p_DtaqNameQual: 1: 10): QmhrdQmDS.DtaqLib: QmhqrdqdDS.Text); 1b dow *on; 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; ind.sfldsp = (rrn > 0); ind.sfldspctl = *on; ind.IsactivateF14 = (QmhqrdqdDS.Sequence = 'K'); write sheader; exfmt sbfctl1; ind.sfldrop = vSflMode; // exit / cancel 2b if InfdsFkey in %list(f03 :f12); dealloc(n) QMHRDQMptr; *inlr = *on; return; 2x elseif ind.IsChange; 3b if vEntNum = 0; vEntNum = 1; 3x elseif vEntNum > QmhrdQmDS.MsgRtnCount; vEntNum = QmhrdQmDS.MsgRtnCount; 3e endif; exsr srLoadOnePage; 1i iter; 2x elseif InfdsFkey = fPageup; 3b if vEntNum - PageSize < 0; vEntNum = 1; 3x else; vEntNum -= PageSize; 3e endif; exsr srLoadOnePage; 1i iter; 2x elseif InfdsFkey = fPageDown; 3b if vEntNum + PageSize <= QmhrdQmDS.MsgRtnCount; vEntNum += PageSize; 3e endif; exsr srLoadOnePage; 1i iter; // show last message 2x elseif InfdsFkey = f06; vEntNum = QmhrdQmDS.MsgRtnCount; exsr srLoadOnePage; // refresh 2x elseif InfdsFkey = f05; exsr srRefresh; // change display mode 2x elseif InfdsFkey = f10; 3b if IsHexMode; IsHexMode = *off; Shift = 58; 3x else; IsHexMode = *on; Shift = 25; 3e endif; exsr srUpdSfl; // 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 = (not ind.IsKeysMode); exsr srUpdSfl; // 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 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; // vEntNum = 0; 1e enddo; //--------------------------------------------------------- // Different type dataqs require different parm list to API. // An anomaly is that usual method of retrieving 8 bytes to get // bytes available does not work. //--------------------------------------------------------- begsr srRefresh; 1b if QmhqrdqdDS.Sequence = 'K'; sAccessTyp = '*KEYED (' + %char(QmhqrdqdDS.KeyLength) + ')'; rdqs0200DS.MsgByteRtv = QmhqrdqdDS.MsgLength; rdqs0200DS.KeyByteRtv = QmhqrdqdDS.KeyLength; rdqs0200DS.KeyLen = QmhqrdqdDS.KeyLength; v0200Len = QmhqrdqdDS.KeyLength + 16; 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 or *sgnlvl storage QMHRDQMptr = %realloc(QMHRDQMptr: BytesAvail); callp QMHRDQM( QmhrdQmDS: BytesAvail: 'RDQM0200': p_DtaqNameQual: rdqs0200DS: v0200Len: 'RDQS0200': ApiErrDS); 1x else; 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; vEntNum = 1; exsr srLoadOnePage; endsr; //------------------------------------------------------------------ // Spin through allocated memory to load one page from selected list entry number //------------------------------------------------------------------ begsr srLoadOnePage; rrn = 0; ind.sfldsp = *off; ind.sfldspctl = *off; write sbfctl1; //------------------------------------------------------------------ // I need to get the list entry pointer to where the first subfile record // will be loaded from. Only way I know is (since offset to next // entry could be variable) is to spin through X number of entries // so pointer is in right place to load next page of subfile. //------------------------------------------------------------------ 1b if QmhrdQmDS.MsgRtnCount > 0; ListEntryPtr = QMHRDQMptr + QmhrdQmDS.OffsetToEntry; ind.sflend = *off; 2b for ForCount = 1 to (vEntNum-1); 3b if ForCount > QmhrdQmDS.MsgRtnCount; 2v leave; 3e endif; ListEntryPtr = QMHRDQMptr + ListEntryDS.NextEntry; 2e endfor; // save starting pointer position StartPtr = ListEntryPtr; EntryCount = 0; 2b for ForCount = vEntNum to vEntNum+(PageSize-1); 3b if ForCount > QmhrdQmDS.MsgRtnCount; ind.sflend = *on; 2v leave; 3e endif; // save entry count EntryCount += 1; // 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; endsr; //--------------------------------------------------------- // Update Subfile. //--------------------------------------------------------- begsr srUpdSfl; ListEntryPtr = StartPtr; 1b for xx = 1 to EntryCount; chain xx sbfdta1; exsr srTempqDS; exsr srDataToDsp; update sbfdta1; ListEntryPtr = QMHRDQMptr + ListEntryDS.NextEntry; 1e endfor; endsr; //--------------------------------------------------------- // Fill TempqDS from allocated memory. // If Keyed data queue, then there is unexplained 5 bytes at beginning of each key. // Size of msg entry could be larger than msg variable. // qTrimLen makes sure this does not blow up! //--------------------------------------------------------- begsr srTempqDS; qTrimLen = QmhqrdqdDS.MsgLength - ofs; 1b if QmhqrdqdDS.Sequence = 'K'; 2b if (QmhqrdqdDS.KeyLength + 5) + QmhqrdqdDS.MsgLength > %size(ListEntryDS.MessageData); qTrimLen = %size(ListEntryDS.MessageData) - (QmhqrdqdDS.KeyLength + 5); 2e endif; 2b if qTrimLen > %len(ViewqDS); qTrimLen = %len(ViewqDS); 2e endif; // Entry/Key display mode. 2b if ind.IsKeysMode; TempqDS = %subst(ListEntryDS.MessageData: ofs + 5: QmhqrdqdDS.KeyLength); 2x else; TempqDS = %subst(ListEntryDS.MessageData: QmhqrdqdDS.KeyLength + ofs + 5: 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: ofs + 1); 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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Dtaara *DEC Values') PARM KWD(DTAARA) TYPE(DTAARA) MIN(1) PROMPT('Data Area') DTAARA: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*ALL) + (*ALLUSR) (*LIBL)) PROMPT('LIBRARY') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*PRINT) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.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.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 or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRDTAARA' A 27'List Data Area Values and Distance- A from Rollover' A SCSYSTEM 8A 100 A SCDOW 9A O 110 A 120DATE EDTCDE(Y) A 130TIME 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 67'Approximate Integer' A 92'Object' A 113'Days' SPACEA(1) *--- A 2'Dtaara' A 14'Attribute' A 27'Len' A 32'Dec' A 49'Current Value' A 67'Distance to RollOver' A 92'Created' A 101'LastUsed' A 113'Used' A 120'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 10A 89 A LASTUSED 10A 101 A DAYSUSED 4 0 113EDTCDE(4) A OBJTEXT 50A 120 *---------------------------------------------------------------- A R PRTMESSAGE SPACEB(2) A VMESSAGE 100A 3 ]]> '); //--------------------------------------------------------- // JCRDTAARAR - Dtaara values and rollover distance list - print //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Atof /define Constants /define Qeccvtec /define Quslobj /define f_BuildString /define f_DecodeApiTimeStamp /define f_GetApiISO /define f_GetQual /define f_Quscrtus /define f_RtvMsgAPI /define f_SndStatMsg /define f_OvrPrtf /define f_Dltovr /define f_DisplayLastSplf /define f_GetDayName /define Qecedt /define QecedtAlpha /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRDTAARAP printer oflind(IsOverFlow) usropn; dcl-s CvtVar like(editmask); dcl-s xSrcvar like(editmask); dcl-s xString like(editmask); dcl-s EditMask char(256); dcl-s p_ObjTyp char(10) inz('*DTAARA'); dcl-s MaxValuea varchar(35); dcl-s CurValf float(8); dcl-s MaxValuef float(8); dcl-s ToRollf float(8); dcl-s EditMaskLen int(10); dcl-s NumXXX int(10); dcl-s TempPos int(10); dcl-s ToRolli int(20); dcl-s vRecvrLen int(10); dcl-s IsFound ind; // Retrieve Data Area dcl-pr Qwcrdtaa extpgm('QWCRDTAA'); *n like(QwcrdtaaDS); // Receiver *n int(10) const; // Length of Receiver *n char(20) const; // Dtaara and Lib *n int(10) const; // Starting Position *n int(10) const; // Length of Receiver *n like(ApiErrDS); end-pr; dcl-ds QwcrdtaaDS qualified; BytesProvided int(10) inz; BytesReturned int(10) inz; TypeOfValue char(10); DtaaraLib char(10); LenReturned int(10) inz; NumDecimal int(10) inz; Value char(2000); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_DtaaraQual char(20); p_Output char(8); end-pi; //--------------------------------------------------------- scDow = 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': '*JOB': HeadLib); open JCRDTAARAP; write prthead; IsOverFlow = *off; // load object names into user space ApiHeadPtr = 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 srWriteAsterisk; write PrtMessage; exsr srSendCompletMsg; 1e endif; // if no matching objects found, print error message 1b if ApiHead.ListEntryCount = 0; exsr srWriteAsterisk; vmessage = 'No matching dtaara names found.'; write PrtMessage; exsr srSendCompletMsg; 1e endif; // Process objects in user space by moving pointer QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; IsFound = *on; // extract object create date, last used date, number times used ApiStampDS = f_DecodeApiTimeStamp(QuslobjDS.CreateStamp); CreateDate = f_GetApiISO(ApiStampDS.Century + ApiStampDS.YY + ApiStampDS.MMDD); 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 = f_GetApiISO(ApiStampDS.Century+ApiStampDS.YY+ApiStampDS.MMDD); 2x else; LastUsed = *blanks; 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; EditMask = *blanks; 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. xstring = %scanrpl(',':'': xstring); 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; 4b if ForCount <> ApiHead.ListEntryCount; // no last blank page write PrtHead; 4e endif; IsOverFlow = *off; 3e endif; 2e endif; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; // if no matching objects found, print message and exit 1b if not IsFound; exsr srWriteAsterisk; 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_DisplayLastSplf('JCRDTAARAR': p_Output); *inlr = *on; return; endsr; //--------------------------------------------------------- begsr srWriteAsterisk; QuslobjPtr = ApiHeadPtr; ObjNam = *all'*'; CreateDate = *all'*'; LastUsed = *all'*'; DaysUsed = 0; ObjText = *all'*'; write PrtDetail; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Dump Count by Program') PARM KWD(OUTQ) TYPE(OUTQ) PROMPT('Outq') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(QEZDEBUG) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*OUTQ') PARM KWD(DUMPDATE) TYPE(*DATE) DFT(*AVAIL) + SPCVAL((*AVAIL 222222) (*CURRENT 333333) + (*PRVDAY 444444)) PROMPT('Date (MMDDYYYY)' 1) PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') /* prompt for program name if DISPLAY selected. */ PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ *)) PARM KWD(PROGRAM) TYPE(PROGRAM) PGM(*YES) + PMTCTL(PMTCTL1) PROMPT('Program') PROGRAM: QUAL TYPE(*NAME) LEN(10) DFT(*ALL) SPCVAL((*ALL *ALL)) QUAL TYPE(*NAME) LEN(10) PROMPT('Library') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA06 CA12 CA21 A INDARA PRINT A R SBFDTA1 SFL A SSPLFNAM 10A H A SSPLFNBR 6A H A SBFOPTION 1A B 5 3 A SPGMNAM 10A O 5 6 A SPGMLIB 10A O 5 17 A SUSERNAM 10A O 5 28 A SJOBNAM 10A O 5 39 A SJOBNBR 6A O 5 51 A SSDATE L O 5 59DATFMT(*ISO) A SSTIME T O 5 70TIMFMT(*HMS) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A *DS3 SFLPAG(17) SFLSIZ(34) A *DS4 SFLPAG(17) SFLSIZ(34) 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 3'1=SndNet' COLOR(BLU) A 3 12'2=Change Outq' COLOR(BLU) A 3 26'5=Display' COLOR(BLU) A 4 2'Opt' DSPATR(HI UL) A 4 6'Program ' DSPATR(HI UL) A 4 17'Lib ' DSPATR(HI UL) A 4 28'User ' DSPATR(HI UL) A 4 39'Job ' DSPATR(HI UL) A 4 51'Number' DSPATR(HI UL) A 4 59'Date ' DSPATR(HI UL) A 4 70'Time ' DSPATR(HI UL) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A 23 2'F3=Exit' COLOR(BLU) A 23 14'F5=Refresh' COLOR(BLU) A 23 30'F6=Print' COLOR(BLU) A 23 45'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Lists RPG program dump spooled files and a count of how many times that program has dumped. :P.The command uses several spooled file APIs to efficiently "read" through outq and extract desired information from each spooled file.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRDUMP/DUMPDATE'.Date MMDDYYYY - Help :XH3.Date MMDDYYYY (DUMPDATE) :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 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. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD A 2'JCRDUMP' A SKIPB(01) A 30'Dump count by program' A SCDOW 9 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 112'Page' A PAGE1 4 0 118EDTCDE(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 SSDATE L 5DATFMT(*ISO) A SPGMNAM 10 23 A SPGMLIB 10 36 A L1CNT 10 0 52EDTCDE(2) A SMSGD 60 69 A SPACEA(1) *---------------------------------------------------------------- A R PRTLR A 1'TOTAL DUMPS' A SPACEB(2) A LRCNT 10 0 52EDTCDE(2) A SPACEA(2) ]]> '); //--------------------------------------------------------- // JCRDUMPR - Dump count by program // spin through list of spooled files retrieved from qezdebug outq. // extract information from spooled file to load into work file. // display or print selections //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRDUMPD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind) usropn; dcl-f JCRDUMPP printer oflind(IsOverFlow) usropn; /define Constants /define Infds /define FunctionKeys /define Ind /define psds /define f_RunOptionSplf /define f_RmvSflMsg /define f_GetDayName /define f_GetQual /define f_Quscrtus /define f_SndCompMsg /define f_DisplayLastSplf /define Quscmdln /define ApiErrDS /define Qspclosp /define Qspgetsp /define Qspopnsp /COPY JCRCMDS,JCRCMDSCPY dcl-ds ioDS; pgmnam char(10) ; pgmlib char(10); psdate date; pstime time; pmsgd char(60); psplfnam char(10); psplfnbr char(6); pjobnam char(10); pjobnbr char(6); pusernam char(10); end-ds; dcl-s Buffer char(5000) based(ptr4); dcl-s DumpType char(4); dcl-s InternalSplfID char(16); dcl-s IntJobID char(16); dcl-s SelectAll char(4) inz('*NO'); dcl-s SpoolDump char(4) inz('*NO'); dcl-s ip_isoDate date; dcl-s Handle int(10); dcl-s OffsetToOffset int(10) based(ptr2); dcl-s OrdinalNumber int(10) inz(-1); dcl-s dd uns(5); dcl-s IsRefresh ind inz(*off); dcl-s ppgm char(10); dcl-s plib char(10); dcl-s L1Cnt uns(10); dcl-c vDateEntered 'Date Entered System . '; dcl-c vLibrary ' Library . '; dcl-c vProgramName 'Program Name . '; dcl-c vProgramStat 'Program Status .'; dcl-c vRpg3Dump 'RPG/400 FORMATTED DU'; dcl-c vRpg4Dump 'ILE RPG/400 FORMATTE'; dcl-c vRpg4Dumpx 'Program Status Area:'; dcl-c vRpg4v7r1 'ILE RPG FORMATTED DUMP'; dcl-ds KeysToReturn qualified; // API key values *n int(10) inz(0201); // spooled file name *n int(10) inz(0202); // job name *n int(10) inz(0203); // user named *n int(10) inz(0204); // job number *n int(10) inz(0205); // spooled file number *n int(10) inz(0216); // date opned *n int(10) inz(0217); // time opened *n int(10) inz(0218); // internal job ID *n int(10) inz(0219); // internal spool ID end-ds; dcl-s NumberKeys int(10) inz(9); // number to return // buffer information dcl-ds BufferInfoDS qualified based(BufferInfoPtr); BufferLength int(10) pos(1); OrdinalNumber int(10) pos(5); OffsetGeneral int(10) pos(9); SizeGeneral int(10) pos(13); OffsetToPage int(10) pos(17); SizePageData int(10) pos(21); NumPageEntries int(10) pos(25); SizePageEntry int(10) pos(29); OffsetPrintDataSection int(10) pos(33); SizePrintDataSection int(10) pos(37); end-ds; // get end of line of print as determined by Qspgetsp API dcl-ds EndOfLineDS qualified; *n char(1) inz(x'00'); *n char(1) inz(x'15'); *n char(1) inz(x'00'); *n char(1) inz(x'34'); end-ds; dcl-ds cvt qualified; Alpha4 char(4) pos(1); Binary4 int(10) samepos(Alpha4) inz; end-ds; // List Spooled Files dcl-pr Quslspl ExtPgm('QUSLSPL'); *n char(20); // user space *n char(8) const; // format *n char(10) const; // user *n char(20); // outq and lib *n char(10) const; // form type *n char(10) const; // user data *n like(ApiErrDS); *n char(26) const; // not used job info *n like(KeysToReturn); *n int(10); // number of keys end-pr; dcl-ds QuslsplDS qualified based(QuslsplPtr); NumFieldRtn int(10) pos(1); // 0200 format only end-ds; // extract repeating key value fields dcl-ds splf0200DS qualified based(splf0200Ptr); LenghtOfInfo int(10) pos(1); Keynum int(10) pos(5); TypeOfData char(1) pos(9); LenOfData int(10) pos(13); KeyData char(17) pos(17); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_OutqQual char(20); p_ObjType char(10); p_Date char(7); p_Output char(8); p_PgmQual char(20); end-pi; //--------------------------------------------------------- exec sql set option commit=*none,datfmt=*iso,dlyprp=*yes,naming=*sys; scDow = f_GetDayName(); exec sql DROP TABLE qtemp/jcrdumpf; exec sql CREATE TABLE qtemp/jcrdumpf ( PGMNAM CHAR(10) NOT NULL DEFAULT '' , PGMLIB CHAR(10) NOT NULL DEFAULT '' , PSDATE DATE NOT NULL DEFAULT CURRENT_DATE , PSTIME TIME NOT NULL DEFAULT CURRENT_TIME , PMSGD CHAR(60) NOT NULL DEFAULT '' , PSPLFNAM CHAR(10) NOT NULL DEFAULT '' , PSPLFNBR CHAR(6) NOT NULL DEFAULT '' , PJOBNAM CHAR(10) NOT NULL DEFAULT '' , PJOBNBR CHAR(6) NOT NULL DEFAULT '' , PUSERNAM CHAR(10) NOT NULL DEFAULT '' ); //--------------------------------------------------------- // dates defined in cmds are CYYMMDD // check special values for all or current only //--------------------------------------------------------- 1b dou not IsRefresh; 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(%subst(p_Date: 2: 6): *ymd0); 2e endif; //--------------------------------------------------------- // create user spaces for APIs and load spooled file list //--------------------------------------------------------- ApiHeadPtr = f_Quscrtus(UserSpaceName); ApiHeadPtr2 = f_Quscrtus(UserSpaceName2); // load spooled file internal names to user space callp QUSLSPL( UserSpaceName: 'SPLF0200': '*ALL': p_OutqQual: '*ALL': '*ALL': ApiErrDS: ' ': KeysToReturn: NumberKeys); //--------------------------------------------------------- QuslsplPtr = ApiHeadPtr + ApiHead.OffSetToList; 2b for ForCount = 1 to ApiHead.ListEntryCount; // Spin through data to extract key values splf0200Ptr = QuslsplPtr + 4; 3b for ForCount2 = 1 to QuslsplDS.NumFieldRtn; 4b if splf0200DS.Keynum = 0201; pSplfNam = splf0200DS.KeyData; 4x elseif splf0200DS.Keynum = 0202; PJobNam = splf0200DS.KeyData; 4x elseif splf0200DS.Keynum = 0203; pUserNam = splf0200DS.KeyData; 4x elseif splf0200DS.Keynum = 0204; PJobNbr = splf0200DS.KeyData; 4x elseif splf0200DS.Keynum = 0205; cvt.Alpha4 = splf0200DS.KeyData; evalr pSplfNbr = '000000' + %char(cvt.Binary4); 4x elseif splf0200DS.Keynum = 0216; pSdate = %date(%subst(splf0200DS.KeyData: 2: 6): *ymd0); 4x elseif splf0200DS.Keynum = 0217; pStime = %time(%subst(splf0200DS.KeyData: 1: 6): *hms0); 4x elseif splf0200DS.Keynum = 0218; IntJobID = splf0200DS.KeyData; 4x elseif splf0200DS.Keynum = 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 = pSdate; 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 = ApiHeadPtr2 + 92; //Offset to Offset BufferInfoPtr = ApiHeadPtr2 + OffsetToOffset; Ptr4 = ApiHeadPtr2 + BufferInfoDS.OffsetPrintDataSection; // close spooled file callp QSPCLOSP(Handle: ApiErrDS); // extract info about dump and determine 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) = vRpg4v7r1; //RPG4 v7r1 SpoolDump = '*YES'; DumpType = 'RPG4'; 4e endif; //--------------------------------------------------------- // extract job starting date and make sure this dump is for // desired date. RPG3 = 6 long so requires different extract. //--------------------------------------------------------- 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 // 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); PgmLib = %subst(Buffer: cc: dd); aa += 1; dd = bb - aa; PgmNam = %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 PgmNam = %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 PgmLib = %subst(Buffer: cc: aa - cc); 8e endif; 7e endif; //--------------------------------------------------------- // extract program status message data. // MSGID/DTA does not always have data. // Extract status ID then extract ID message data (if any) //--------------------------------------------------------- pMsgd = *blanks; 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 pMsgd = %subst(Buffer: cc: dd); //Message data // Step over 7 places and extract message 9b if pMsgd > '00000 '; //found one cc = bb + 7; bb = %scan(EndOfLineDS: Buffer: cc); pMsgd = %trimr(pMsgd) + ' ' + %triml(%subst(Buffer: cc: bb - cc)); 9e endif; 8e endif; exec sql insert into qtemp/jcrdumpf values(:PgmNam, :PgmLib, :pSdate, :pStime, :pMsgd, :pSplfNam, :pSplfNbr, :PJobNam, :PJobNbr, :pUserNam); 7e endif; 6e endif; 5e endif; 4e endif; 3e endif; QuslsplPtr += ApiHead.ListEntrySize; 2e endfor; 2b if p_Output = '*PRINT'; exsr srPrint; 2x else; exsr srDisplay; 3b if IsRefresh; exec sql delete from qtemp/jcrdumpf; 3e endif; 2e endif; 1e enddo; f_SndCompMsg('JCRDUMP for ' + f_GetQual(p_OutqQual) + ' - completed'); *inlr = *on; return; //----------------------------------------------------------- //----------------------------------------------------------- begsr srPrint; exec sql Declare cursor02 cursor for SELECT PSDATE, PGMLIB, PGMNAM, PMSGD, count(*) FROM qtemp/jcrdumpf GROUP BY PSDATE, PGMLIB, PGMNAM, PMSGD ORDER BY PSDATE, PGMLIB, PGMNAM, PMSGD; open JCRDUMPP; write PrtHead; IsOverFlow = *off; exec sql open cursor02; exec sql fetch cursor02 into :PSDATE,:PGMLIB,:PGMNAM,:PMSGD,:L1CNT; 1b dow sqlstate = *zeros; ssdate = psdate; spgmnam = pgmnam; spgmlib = pgmlib; smsgd = pmsgd; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; write PrtL1; LRCnt += L1Cnt; exec sql fetch cursor02 into :PSDATE,:PGMLIB,:PGMNAM,:PMSGD,:L1CNT; 1e enddo; write PrtLR; exec sql close cursor02; close JCRDUMPP; f_DisplayLastSplf('JCRDUMPR2': '*PRINT'); endsr; //----------------------------------------------------------- //----------------------------------------------------------- begsr srDisplay; open JCRDUMPD; pPgm = %subst(p_PgmQual:1:10); pLib = %subst(p_PgmQual:11:10); exec sql Declare cursor01 cursor for SELECT * FROM qtemp/jcrdumpf WHERE (:pPgm = '*ALL' or (:pPgm = PGMNAM and :pLib = PGMLIB)) ORDER BY PSDATE, PGMLIB, PGMNAM, PMSGD; IsRefresh = *off; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; write sbfctl1; exec sql open cursor01; exec sql fetch cursor01 into :ioDS; 1b dow sqlstate = *zeros; SSPLFNAM = pSPLFNAM; SSPLFNBR = pSPLFNBR; SBFOPTION = *blanks; SPGMNAM = PGMNAM; SPGMLIB = PGMLIB; SUSERNAM = pUSERNAM; SJOBNAM = pJOBNAM; SJOBNBR = pJOBNBR; SSDATE = pSDATE; SSTIME = pSTIME; rrn += 1; write sbfdta1; exec sql fetch cursor01 into :ioDS; 1e enddo; exec sql close cursor01; // show subfile Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); 2b if pPgm = '*ALL'; snd-msg 'No dump spooled files found for dates'; 2x else; snd-msg 'No dump spooled files found for program ' + %trimr(pPgm) + ' in ' + %trimr(pLib); 2e endif; 1e endif; Ind.sfldspctl = *on; 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); close JCRDUMPD; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); 2b if InfdsFkey = f05; IsRefresh = *on; close JCRDUMPD; LV leavesr; 2e endif; 2b if InfdsFkey = f06; exsr srPrint; snd-msg 'Print Completed'; 1i iter; 2e endif; 2b if (not Ind.sfldsp); 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: sSplfNam: sSplfNbr: sJobNam: sUserNam: sJobNbr: ProgId); sbfOption = *blanks; update sbfdta1; 3e endif; readc sbfdta1; 2e enddo; 1e enddo; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Duplicate Keyed Logicals List') PARM KWD(MBR) TYPE(*CHAR) LEN(10) 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(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.Lists file data base relations with 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 viewed.:EHELP. :HELP NAME='JCRDUPKEY/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRDUPKEY' A 20'Duplicate Keyed Logicals List' A SCDOW 9A O 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'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 -----------------------------------' ]]> '); //--------------------------------------------------------- // JCRDUPKEYR - Duplicate Keyed Logicals List - print // List files with same leading keys, select/omit statements // and same record formats //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Constants /define BitMask /define f_OvrPrtf /define f_DltOvr /define f_Quscrtus /define Qdbrtvfd /define Qdbldbr /define f_DisplayLastSplf /define f_SndCompMsg /define f_GetDayName /define f_BuildString /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRDUPKEYP printer oflind(IsOverFlow) usropn; dcl-s WorkFileQual char(20); dcl-s DbrCnt uns(5); dcl-s yy like(filescopearry.numofkeys); dcl-s zz uns(10); dcl-s ActualPF char(20); dcl-s fscopePtrSave pointer; dcl-s IsSendMessage ind; dcl-s IsAllEQual ind; dcl-s IsAllSelect ind; dcl-s IsPrintOnce ind; dcl-ds SelectOmitDS inz qualified; Type char(7); Field char(10); Comp char(2); Value char(31); end-ds; dcl-ds DS0 qualified template; NumbKeys uns(3); FormatCnt uns(3); File char(10); Lib char(10); UniqueFlg char(1); KeysArry char(13) dim(100); PrtKeys char(104) samepos(KeysArry); RcdFmtArry char(10) dim(100); NumbSO uns(3); SelOmtArry char(50) dim(100); end-ds; dcl-ds DS1 likeds(DS0) dim(2000); dcl-ds DS2 likeds(DS0) dim(2000); //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_FileQual char(20); p_Output char(8); end-pi; //--------------------------------------------------------- scDow = f_GetDayName(); f_OvrPrtf('JCRDUPKEYP': '*JOB': %subst(p_FileQual:1:10)); open JCRDUPKEYP; //--------------------------------------------------------- // extract based-on-physical name //--------------------------------------------------------- AllocatedSize = f_GetAllocatedSize(p_FileQual: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': p_FileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 1b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; ReturnFileQual = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 1e endif; ActualPF = ReturnFileQual; scObjHead = f_BuildString('& & &': %subst(ReturnFileQual: 1: 10): %subst(ReturnFileQual: 11: 10): Fild0100ds.FileText); write PrtHead; IsOverFlow = *off; write prtdivider; // retrieve data base relation names ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QDBLDBR( UserSpaceName: 'DBRL0100': ReturnFileQual: '*ALL': '*ALL': ApiErrDS); // Process list entries in user space QdbldbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if not(QdbldbrDS.DependentFile = '*NONE'); exsr srLoadRecord; QdbldbrPtr += ApiHead.ListEntrySize; 2e endif; 1e endfor; QdbldbrDS.DependentFile = ActualPF; exsr srLoadRecord; //--------------------------------------------------------- // 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(*); sorta %subarr(ds1:1:DbrCnt) %fields(NumbKeys); sorta(d) %subarr(ds2:1:DbrCnt) %fields(NumbKeys); //--------------------------------------------------------- //--------------------------------------------------------- 1b for aa = 1 to DbrCnt; 2b if ds1(aa).File > *blanks and ds1(aa).NumbKeys > 0; 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 and ds2(cc).NumbSO = ds1(aa).NumbSO and ds2(cc).NumbKeys > 0; IsAllEQual = *on; 5b for bb = 1 to ds1(aa).FormatCnt; 6b if ds2(cc).RcdFmtArry(bb) <> ds1(aa).RcdFmtArry(bb); IsAllEQual = *off; 5v leave; 6e endif; 5e endfor; 5b if IsAllEQual; 6b for bb = 1 to ds1(aa).NumbSO; 7b if ds2(cc).SelOmtArry(bb) <> ds1(aa).SelOmtArry(bb); IsAllEQual = *off; 6v leave; 7e endif; 6e endfor; 6b if IsAllEQual; 7b for bb = 1 to ds1(aa).NumbKeys; 8b if ds2(cc).KeysArry(bb) <> ds1(aa).KeysArry(bb); IsAllEQual = *off; 7v leave; 8e endif; 7e endfor; 7b if IsAllEQual = *on; IsSendMessage = *on; 8b if IsPrintOnce; PrtFile = ds1(aa).File; PrtLib = ds1(aa).Lib; PrtKeys = ds1(aa).PrtKeys; write PrtLine; IsPrintOnce = *off; 8e endif; PrtFile = ds2(cc).File; PrtLib = ds2(cc).Lib; PrtKeys = ds2(cc).PrtKeys; write PrtLine; // remove found file from driver array 8b for bb = 1 to DbrCnt; 9b if ds2(cc).File = ds1(bb).File; ds1(bb) = *blanks; 9e endif; 8e endfor; ds2(cc) = *blanks; 7e endif; 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(n) Fild0100ptr; close JCRDUPKEYP; f_DltOvr('JCRDUPKEYP'); f_DisplayLastSplf('JCRDUPKEYR': p_Output); *inlr = *on; return; //--------------------------------------------------------- begsr srLoadRecord; WorkFileQual = QdbldbrDS.DependentFile; AllocatedSize = f_GetAllocatedSize(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: AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': WorkFileQual: '*FIRST': '0': '*FILETYPE': '*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; //------------------------------------------------- // load record formats ds1(DbrCnt).RcdfmtArry(*) = *blanks; fscopePtrSave = fscopePtr; 2b for yy = 1 to Fild0100ds.NumRcdFmts; ds1(DbrCnt).RcdfmtArry(yy) = FileScopeArry.RcdFmt; fscopePtr += 160; //next record format 2e endfor; fscopePtr = fscopePtrSave; //------------------------------------------- cc = FileScopeArry.OffsKeySpecs + 1; // if 1st bit of KeySequenBits = 1, key is descend sequence ds1(DbrCnt).KeysArry(*) = *blanks; ds1(DbrCnt).SelOmtArry(*) = *blanks; // note sql materialized tables return weird number of keys // set to zero if 16,000 keys returned 2b monitor; ds1(DbrCnt).NumbKeys = FileScopeArry.NumOfKeys; 2x on-error; ds1(DbrCnt).NumbKeys = 0; FileScopeArry.NumOfKeys = 0; 2e endmon; ds1(DbrCnt).NumbSO = FileScopeArry.NumSelectOmit; KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 2b for yy = 1 to FileScopeArry.NumOfKeys; ds1(DbrCnt).KeysArry(yy) = %trimr(KeySpecsDS.KeyFieldName); // check for descending keys 3b if %bitand(bit0: KeySpecsDS.KeySequenBits) = bit0; %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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('File Descriptions') PARM KWD(MBR) TYPE(*CHAR) LEN(10) CONSTANT('*FIRST') PARM KWD(FILE) TYPE(FILE) MIN(1) CHOICE('Long or + Short File Name') PROMPT('File') FILE: QUAL TYPE(*NAME) LEN(130) 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') /* jcrlkey passes this parm */ PARM KWD(KEYSTRING) TYPE(*CHAR) LEN(101) CONSTANT(' ') /* prompt for member type if *MBR selected */ PMTCTL1: PMTCTL CTL(VIEW) COND((*EQ '*MBR')) PARM KWD(MBRTYPE) TYPE(*CHAR) LEN(10) DFT(*ALL) + PGM(*YES) PMTCTL(PMTCTL1) PROMPT('Member + Type') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA PRINT A CA02 CA03 CA05 CA06 CA07 CA08 A CA12 CA13 CA14 CA15 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 125A O 4 4DSPATR(&SBFROWATR) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY A SFLPAG(21) SFLSIZ(357) 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 77COLOR(BLU) A 1 87DATE EDTCDE(Y) COLOR(BLU) A 2 2'File:' DSPATR(HI) A SCOBJHEAD 63A O 2 8 A 2 87SYSNAME COLOR(BLU) A SCHEADOPT 65A O 3 2COLOR(BLU) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A AKEYSELEC 1A P A 26 2'F3=Exit' COLOR(BLU) A SCKEYSELEC 100A O 26 11DSPATR(&AKEYSELEC) *---------------------------------------------------------------- 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 *DS4 SFLPAG(6) SFLSIZ(18) A *DS4 WINDOW(*DFT 11 75 *NOMSGLIN) A R WINFOOT3 WINDOW(WINCTL3) OVERLAY A 9 2'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Quick view most often needed 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.Long or Short File name 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.Display subfile of all members in the file. :PT.:PK def.*DBR:EPK.:PD.Display subfile of data base relations.:EPARML.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A PRINT INDARA A CA03 CA05 CA12 CA13 CA14 A MOUBTN(*ULP CA13) A MOUBTN(*URP CA14) 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 SCMBRTYPE 10A O 5 16 A SCCHGDATE 10A O 5 27 A SCCHGTIME 8A O 5 38 A SCRECS 9Y 0O 5 47EDTCDE(3) A SCRECDLT 9Y 0O 5 57EDTCDE(3) A SCSIZE 9Y 0O 5 67EDTCDE(3) A SCTEXT 50A O 5 78 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLPAG(20) SFLSIZ(200) A OVERLAY BLINK 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' COLOR(BLU) A 1 29'Display Member List' DSPATR(HI) A SCDOW 9A O 1108COLOR(BLU) A 1118DATE EDTCDE(Y) COLOR(BLU) A 2 2'File:' DSPATR(HI) A SCOBJHEAD 63A O 2 8 A 2108SYSNAME COLOR(BLU) A SCHEADOPT 100A O 3 2DSPATR(&AOPTIONS) A 4 2'Opt' DSPATR(HI) A 4 7'Member' DSPATR(HI) A 4 16'Type' DSPATR(HI) A 4 27'Last Change' DSPATR(HI) A 4 50'Records' DSPATR(HI) A 4 60'Deleted' DSPATR(HI) A 4 69'Size(K)' DSPATR(HI) A 4 78'Text' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 26 2'F3=Exit' COLOR(BLU) A 26 11'F5=Refresh' COLOR(BLU) A 26 24'F13=Sort Ascend' A COLOR(BLU) A SORTDESCEN 19 O 26 45COLOR(BLU) A 26 69'F12=Cancel' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> '); //--------------------------------------------------------- // JCRFDMBRR - File descriptions member list //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRFDMBRD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define DspAtr /define Infds /define FunctionKeys /define Ind /define Quslmbr /define f_Qusrmbrd /define f_GetApiISO /define f_GetApiHMS /define psds /define f_RunOptionFile /define f_GetQual /define f_Quscrtus /define f_RmvSflMsg /define f_SndStatMsg /define f_GetFileUtil /define f_GetDayName /define BitMask /define Qdbldbr /define Qdbrtvfd /define f_RunCmd /COPY JCRCMDS,JCRCMDSCPY dcl-s HeaderLib char(10); dcl-s HeaderObj char(10); dcl-s KeyFld char(10) inz('SCMBR'); dcl-s SortSequence char(10) inz('Ascend'); dcl-s MbrCnt int(10); dcl-s DeleteCount uns(5); dcl-s NumberOfRecs uns(5); dcl-s RRNsave like(rrn); dcl-s dbUtility char(8); dcl-s p_AllowOption char(4) inz('*YES'); dcl-s apiformat char(8); dcl-s IsRefresh ind inz(*off); dcl-s IsFirstTime ind; dcl-s PfFile char(10); dcl-s PfLib char(10); dcl-s ForCount1 like(ApiHead.listentrycount); dcl-s IsLF ind; dcl-ds HeaderSection qualified based(HeaderPtr); FileUsed char(10) pos(1); LibUsed char(10) pos(11); FileText char(30) pos(31); end-ds; // load screen fields for sorting dcl-ds Sortds dim(9999) qualified; Mbr char(10); Type char(10); ChgDate char(10); ChgTime char(8); Recs zoned(9); RecDlt zoned(9); Size zoned(9); Text char(50); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_MbrType char(10); end-pi; //--------------------------------------------------------- SortDescen = 'F14=Sort Descend'; IsFirstTime = *on; f_SndStatMsg('Retrieving ' + %trimr(f_GetQual(p_FileQual)) + ' - in progress'); scDow = 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 ApiHeadPtr = f_Quscrtus(UserSpaceName); HeaderObj = %subst(p_FileQual: 1: 10); HeaderLib = %subst(p_FileQual: 11: 10); exsr srRefreshScreen; //--------------------------------------------------------- 1b dow *on; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 2b if (not Ind.sfldsp); f_RmvSflMsg(ProgId); snd-msg 'No members were found'; 2e endif; write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); //------------------------------- 2b if InfdsFkey = f05; IsRefresh = *on; exsr srRefreshScreen; IsRefresh = *off; 1i iter; 2e endif; 2b if InfdsSflRcdNbr > 0; SflRcdNbr = InfdsSflRcdNbr; 2x else; SflRcdNbr = 1; 2e endif; // re-sort subfile 2b if InfdsFkey in %list(f13: f14); 3b if InfdsFkey = f13; SortSequence = 'Ascend'; 3b else; SortSequence = 'Descend'; 3e endif; KeyFld = curfld; exsr srSortAndReload; SflRcdNbr = 1; 1i iter; 2e endif; //----------------------------------------- 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 in %list(1:2:3:4:5:9); 5b if sbfOption = 4; exsr srRemoveMember; 5x else; f_RunOptionFile( sbfOption: HeaderObj: HeaderLib: '*FIRST': scmbr: ProgId); 5e endif; // Update subfile to reflect changes 5b if sbfOption = 4 and ApiErrDS.BytesReturned = 0; 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; //--------------------------------------------------------- // load object name list //--------------------------------------------------------- begsr srRefreshScreen; sbfOption = 0; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn = 0; //------------------------------------------------------- // if member type = *all, let fastest api format run, // else run slower format so can check for member type. // (still faster than calling retrieve member description for every member //------------------------------------------------------- 1b if p_MbrType = '*ALL'; apiformat = 'MBRL0100'; 1x else; apiformat = 'MBRL0200'; 1e endif; //------------------------------------------------------- callp QUSLMBR( UserSpaceName: apiformat: p_FileQual: '*ALL': '0': ApiErrDS); // file text information HeaderPtr = ApiHeadPtr + ApiHead.OffSetToHeader; scObjHead = %trimr(HeaderSection.FileUsed) + ' ' + %trimr(HeaderSection.LibUsed) + ' ' + HeaderSection.FileText; // Process data from user space by moving pointer MbrCnt = 0; QuslmbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if p_MbrType in %list('*ALL':QuslmbrDS.MbrType); QusrmbrdDS=f_Qusrmbrd(p_FileQual:QuslmbrDS.MbrName:'MBRD0200'); SCMBR = QusrmbrdDS.Mbr; SCMBRTYPE = QusrmbrdDS.MbrType; 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; MbrCnt += 1; Sortds(MbrCnt).Mbr = scMbr; Sortds(MbrCnt).Type = scMbrType; Sortds(MbrCnt).ChgDate = scChgDate; Sortds(MbrCnt).ChgTime = scChgTime; Sortds(MbrCnt).Recs = scRecs; Sortds(MbrCnt).RecDlt = scRecDlt; Sortds(MbrCnt).Size = scSize; Sortds(MbrCnt).Text = scText; 3b if rrn = 9999; 1v leave; 3e endif; 2e endif; QuslmbrPtr += ApiHead.ListEntrySize; 1e endfor; RRNsave = rrn; // Allow user to make selection from subfile exsr srLoadFromSorter; // keep cursor in place on refreshs 1b if IsRefresh = *off or SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; 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; MbrCnt = 0; 1b for rrn = 1 to NumberOfRecs; chain rrn sbfdta1; 2b if not(sbfOption = 4); //DELETE OPTION MbrCnt += 1; Sortds(MbrCnt).Mbr = scMbr; Sortds(MbrCnt).Type = scMbrType; Sortds(MbrCnt).ChgDate = scChgDate; Sortds(MbrCnt).ChgTime = scChgTime; Sortds(MbrCnt).Recs = scRecs; Sortds(MbrCnt).RecDlt = scRecDlt; Sortds(MbrCnt).Size = scSize; Sortds(MbrCnt).Text = 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 MbrCnt > 0; 2b if KeyFld = 'SCMBR'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).Mbr: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).Mbr: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) +' by Member'; //---------------------------- 2x elseif KeyFld = 'SCMBRTYPE'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).Type: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).Type: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) + ' by Member Type'; //---------------------------- 2x elseif KeyFld in %list('SCCHGTIME':'SCCHGDATE'); 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).ChgDate: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).ChgDate: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) + ' by Change Date/Time'; //---------------------------- 2x elseif KeyFld = 'SCRECS'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).Recs: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).Recs: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) + ' by Number Records'; //---------------------------- 2x elseif KeyFld = 'SCRECDLT'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).RecDlt: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).RecDlt: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) + ' by Deleted Records'; //---------------------------- 2x elseif KeyFld = 'SCSIZE'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).Size: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).Size: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) +' by Deleted Records'; //---------------------------- 2x elseif KeyFld = 'SCTEXT'; 3b if SortSequence = 'Descend'; sorta(d) %subarr(Sortds(*).Text: 1: MbrCnt); 3x else; sorta(a) %subarr(Sortds(*).Text: 1: MbrCnt); 3e endif; snd-msg 'Sort ' + %trimr(SortSequence) + ' by Text'; 2e endif; 2b if MbrCnt >= 9999; f_RmvSflMsg(ProgId); snd-msg '9999+ members returned. Narrow search.'; MbrCnt = 9999; 2e endif; 2b for aa = 1 to MbrCnt; scMbr = Sortds(aa).Mbr; scMbrType = Sortds(aa).Type; scChgDate = Sortds(aa).ChgDate; scChgTime = Sortds(aa).ChgTime; scRecs = Sortds(aa).Recs; scRecDlt = Sortds(aa).RecDlt; scSize = Sortds(aa).Size; scText = Sortds(aa).Text; sbfOption = 0; rrn += 1; write sbfdta1; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // remove members LF/PF multiple record format etc.. // get PF (or PFs file is based on) // remove member from each data base relations // remove member from PF(s) //--------------------------------------------------------- begsr srRemoveMember; UserSpaceName2 = 'JCRRMVMBR QTEMP'; ApiHeadPtr2 = f_Quscrtus(UserSpaceName2); AllocatedSize = f_GetAllocatedSize(HeaderObj+HeaderLib: '*FIRST'); 1b if ApiErrDS.BytesReturned = 0; Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': HeaderObj+HeaderLib: scmbr: '0': '*FILETYPE': '*EXT': ApiErrDS); PfFile = %subst(ReturnFileQual: 1: 10); PfLib = %subst(ReturnFileQual: 11: 10); IsLF = (%bitand(bit2: Fild0100ds.TypeBits) = bit2); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 2b if Not IsLF; exsr srDataBaseRelations; f_runcmd('RMVM FILE(' + %trimr(PfLib) + '/' + %trimr(PfFile) + ') MBR(' + %trimr(scmbr) + ')'); 2x else; 3b for forcount2 = 1 to Fild0100ds.NumOfBasedPf; pffile = FileScopeArry.BasedOnPf; pflib = FileScopeArry.BasedOnPfLib; exsr srDataBaseRelations; fscopePtr += 160; 3e endfor; // now spin back through and remove PF members fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 3b for forcount2 = 1 to Fild0100ds.NumOfBasedPf; f_runcmd('RMVM FILE(' + %trimr(FileScopeArry.BasedOnPfLib) + '/' + %trimr(FileScopeArry.BasedOnPf) + ') MBR(' + %trimr(scmbr) + ')'); fscopePtr += 160; 3e endfor; 2e endif; 1e endif; endsr; //--------------------------------------------------------- begsr srDataBaseRelations; callp QDBLDBR( UserSpaceName2: 'DBRL0100': PfFile + PfLib: scmbr : '*ALL': ApiErrDS); // the LF member may not be in the PF, if so try *FIRST member 1b if ApiErrDS.BytesReturned > 0; callp QDBLDBR( UserSpaceName2: 'DBRL0100': PfFile + PfLib: '*FIRST ': '*ALL': ApiErrDS); 1e endif; 1b if ApiErrDS.BytesReturned = 0; QdbldbrPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 2b for ForCount1 = 1 to ApiHead2.ListEntryCount; f_runcmd('RMVM FILE(' + %trimr(QdbldbrDS.DependentLib) + '/' + %trimr(QdbldbrDS.DependentLF) + ') MBR(' + %trimr(scmbr) + ')'); QdbldbrPtr += ApiHead2.ListEntrySize; 2e endfor; 1e endif; endsr; ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(2) A SCTITLE 36A O 23 A SCDOW 9A O 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 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 125A 2 ]]> '); //--------------------------------------------------------- // JCRFDR - File descriptions driver // This program also provides the presentation layer for JCRLKEY and JCRDBR. // F2 lower cases everything on the screen, easy to copy keys and // record formats from this screen. // add Fild0100ds.AccessType='AR' to list of excludes. This occurs // when a sql materialize table shows as a dependency but has no keys. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRFDD workstn sfile(sbfdta1: rrn) infds(infds) sfile(windta3: rrn3) indds(ind); dcl-f JCRFDP printer oflind(IsOverFlow) usropn; /define p_JCRLONGFIL /define ApiErrDS /define Constants /define BitMask /define DspAtr /define Infds /define FunctionKeys /define f_GetApiISO /define f_GetApiHMS /define f_Qusrmbrd /define f_Qusrobjd /define f_qmhrcvpm /define f_RmvSflMsg /define f_SndCompMsg /define f_BuildString /define Ind /define psds /define f_Quscrtus /define f_GetQual /define f_GetDayName /define f_RunOptionFile /define Qdbldbr /define Qdbrtvfd /define Qlgsort /define f_GetFileUtil /define f_RtvMsgAPI /define f_OvrPrtf /define f_DltOvr /define f_DisplayLastSplf /COPY JCRCMDS,JCRCMDSCPY dcl-s rrn3 like(rrn); dcl-s WorkFileQual char(20); dcl-s PfFile char(10); dcl-s PfLib char(10); dcl-s KeyList char(99); dcl-s ForCount1 like(ApiHead.listentrycount); dcl-s ForCount3 like(filescopearry.numselectomit); dcl-s ForCount4 like(selectomitspec.numberofparms); dcl-s ForCount5 like(fild0100ds.numofbasedpf); dcl-s ForCount6 like(joinspecds.numjflds); dcl-s ForCount7 like(pfattrds.numoftriggers); dcl-s IsLF ind; dcl-s IsDbrView ind; dcl-s IsMbrView ind; dcl-s kwork varchar(16); dcl-s IsIncludeSO ind; dcl-s IsThisKeyOK ind; dcl-s IsValidKeys ind; dcl-s IsFdScreen ind; dcl-s IsOption3 ind inz(*off); dcl-s KeySortArry char(14) dim(9) ascend; dcl-s QuickSort char(200) based(qdbldbrptr); dcl-s FileOption packed(1) inz; dcl-s savrcdnbr like(sflrcdnbr); dcl-s dbUtility char(8); dcl-s subtext like(sbfrow); dcl-s savFileName char(10); dcl-s savLibName char(10); dcl-s PrtRrn like(rrn); dcl-s IsExitPgm ind; dcl-s IsLowerCase ind; // receive keys selected in JCRLKEY utility dcl-ds LeadingKeysDS qualified; KeyFields char(10) dim(9); KeyPosition zoned(1) dim(9); SelectOmit ind; IsFoundKey ind; end-ds; dcl-ds SbfRowDS qualified; soCon char(4) pos(33) inz('s/o:'); soType char(7) pos(38); soFld char(10) pos(46); soComp char(2) pos(57); soValu char(32) pos(60); end-ds; // member display------------------------------- dcl-pr p_JCRFDMBRR extpgm('JCRFDMBRR'); *n char(20); *n char(10) const; end-pr; // object locks--------------------------------- dcl-pr p_JCROLCKR extpgm('JCROLCKR'); *n char(20); *n char(10) const; end-pr; dcl-s p_FileQual char(20); dcl-s shortfil char(10); //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_LongFileQual char(140); p_ObjTyp char(10); p_CallingCmd char(10); p_InitialView char(4); p_LeadingKeys char(101); p_MbrType char(10); end-pi; //--------------------------------------------------------- callp p_JCRLONGFIL(p_LongFileQual: shortfil); p_FileQual = shortfil + %subst(p_LongFileQual:131); f_RmvSflMsg(ProgId); LeadingKeysDS = p_LeadingKeys; DbUtility = '2=' + f_GetFileUtil(); sbfSelAtr = %bitor(ND: PR); aKeySelec = Blue; IsLowerCase = *off; scDow = f_GetDayName(); scKeySelec = 'F6=Print + F7=Data Base Relations + F8=Object Locks + F13=Fields + F14=MbrList + F15=' + %trimr(f_GetFileUtil())+' F12=Cancel'; scProgid = p_CallingCmd; //--------------------------------------------------------- // Setup looping subroutine so user can refresh screen 1b dou IsExitPgm; exsr srRefreshScreen; 1e enddo; //--------------------------------------------------------- dealloc(n) Fild0100ptr; 1b if not(p_CallingCmd = 'JCRLKEY'); f_SndCompMsg(%trimr(p_CallingCmd) + ' for ' + 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'; callp p_JCRFDMBRR(p_FileQual: p_MbrType); *inlr = *on; return; 1x else; IsFdScreen = *on; exsr srGetFileInformation; 1e endif; p_InitialView = *blanks; //--------------------------------------------------------- // Show user screen SflRcdNbr = 2; 1b dow *on; 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 msgctl; write sbfctl1; exfmt sfooter1; 2b if InfdsFkey = f03; IsExitPgm = *on; LV leavesr; 2e endif; f_RmvSflMsg(ProgId); savrcdnbr = InfdsSflRcdNbr; //--------------------------------------------------------- 2b if InfdsFkey = f02; IsLowerCase = not(IsLowerCase); LV leavesr; 2x elseif InfdsFkey = f05; LV leavesr; 2x elseif InfdsFkey = f08; callp p_JCROLCKR(p_FileQual: '*FILE'); 1i iter; 2x elseif InfdsFkey = f12; 3b if (IsDbrView or IsMbrView) and p_CallingCmd = 'JCRFD'; IsDbrView = *off; IsMbrView = *off; IsFdScreen = *on; %subst(scKeySelec: 15: 19) = 'Data Base Relations'; 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; //--------------------------------------------------------- 2b if InfdsFkey = f06; exsr srPrint; //--------------------------------------------------------- // toggle view to include or exclude select/omit 2x elseif InfdsFkey = f07; IsDbrView = *on; IsIncludeSO = not(IsIncludeSO); exsr srDataBaseRelations; //--------------------------------------------------------- 2x elseif InfdsFkey in %list(f13: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: '*ALL'); snd-msg 'Member List for ' + %trimr(f_GetQual(p_FileQual)) + ' - completed'; IsFdScreen = *on; exsr srGetFileInformation; 2e endif; //--------------------------------------------------------- // values from changed record are sent to a function to process 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 in %list(1:2: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 key field names //--------------------------------------------------------- begsr srLeadingKeysFooter; IsDbrView = *on; KeySortArry(*) = *blanks; // build string to show on screen 1b for ForCount = 1 to 9; 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; scKeySelec = *blanks; 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, // load the record formats into a window // otherwise load 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; AllocatedSize = f_GetAllocatedSize(p_FileQual: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': p_FileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); sFileName = %subst(ReturnFileQual: 1: 10); sLibName = %subst(ReturnFileQual: 11: 10); PfFile = sFileName; PfLib = sLibName; IsLF = (%bitand(bit2: Fild0100ds.TypeBits) = bit2); 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 = 'File Description'; //-ROW 1--------------------------------------------------- // List keys and select/omits 2b if %bitand(bit6: Fild0100ds.TypeBits) = bit6; // keyed access path sbfrow = *blanks; %subst(sbfrow:1:70) = *all'_'; sbfRowAtr = Blue; %subst(sbfrow:1:4)= 'Keys'; 3b if FileScopeArry.NumSelectOmit > 0; %subst(sbfrow:32:12) = ' Select/Omit'; 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'; %subst(sbfRow:61) = 'RecLen'; 2b if not(IsLF) and PfAttrDS.NumOfTriggers > 0; %subst(sbfRow:68) = '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:56) = '9999'; 2x else; %subst(sbfrow:56) = %char(QusrobjDS.NumDaysUsed); 2e endif; %subst(sbfrow:64) = %char(Fild0100ds.FileRecLen); 2b if (not IsLF) and PfAttrDS.NumOfTriggers > 0; %subst(sbfrow:72) = %char(PfAttrDS.NumOfTriggers); 2e endif; rrn += 1; write sbfDta1; //--ROW 4-------------------------------------------------- sbfRow = *blanks; rrn += 1; write sbfDta1; sbfRowAtr = White; sbfRow = *blanks; %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:83) = 'Members (F14)'; 3e endif; %subst(sbfRow:45:7) = 'Records'; %subst(sbfRow:59:7) = 'Deleted'; %subst(sbfRow:72:5) = 'Reuse'; 2e endif; rrn += 1; write sbfDta1; //--ROW 5-------------------------------------------------- sbfRowAtr = Green; sbfRow = *blanks; %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 in %range(2:9999999); %subst(sbfrow:85) = %char(Fild0100ds.NumMbrs); 4e endif; 3b if %bitand(bit0: PfAttrDS.Bits) = bit0; %subst(sbfRow:72:4) = '*YES'; 3x else; %subst(sbfRow:72:3) = '*NO'; 3e endif; 2e endif; rrn += 1; write sbfDta1; //--ROW 6-------------------------------------------------- exsr srLineRow; exsr srRow7andRow8; //--ROW 10------------------------------------------------- // Spin through JoinSpecDSs linked list to get JFLDs (join spec array) 2b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; 3b if Fild0100ds.NumOfBasedPf > 1; LfSpecificptr = Fild0100ptr + Fild0100ds.OffsLfAttr; 4b if %bitand(bit2: LfSpecific.AttrBits) = bit2; // 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; sbfrow = *blanks; 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 not(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 = 'Trigger'; %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; exsr srLineRow; 2e endif; //----------------------- // show source if available //----------------------- 2b if QusrobjDS.SrcMbr > *blanks; sbfRowAtr = Green; sbfrow = *blanks; rrn += 1; write sbfDta1; sbfRowAtr = White; sbfSelAtr = %bitor(ND: PR); sbfrow='Source Lib File Member '; rrn += 1; write sbfDta1; sbfRowAtr = Green; sbfrow = QusrobjDS.SrcLib+ ' ' + QusrobjDS.SrcFile + ' ' + QusrobjDS.SrcMbr; rrn += 1; write sbfDta1; 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; 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 IsLowerCase; SubText = %lower(SubText); 2e endif; 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: 15: 19) = 'Exclude Select/Omit'; 1x else; scTitle = 'EXCLUDE Select/Omit Logicals'; %subst(scKeySelec: 15: 19) = 'Include Select/Omit'; 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; sbfRow = *blanks; // retrieve data base relation names ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QDBLDBR( UserSpaceName: 'DBRL0100': PfFile + PfLib: '*ALL': '*ALL': ApiErrDS); QdbldbrPtr = ApiHeadPtr + ApiHead.OffSetToList; // sort by file name qlgsortDS.RecordLength = ApiHead.ListEntrySize; qlgsortDS.RecordCount = ApiHead.ListEntryCount; qlgsortDS.NumOfKeys = 1; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(21: 20); qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); callp QLGSORT( qlgsortDS: QuickSort: QuickSort: ApiHead.ListEntryCount * ApiHead.ListEntrySize: ApiHead.ListEntryCount * ApiHead.ListEntrySize: ApiErrDS); // Process list entries in user space 1b for ForCount1 = 0 to ApiHead.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 not (WorkFileQual in %list(' ':'*NONE')); PfFile = %subst(WorkFileQual: 1: 10); PfLib = %subst(WorkFileQual: 11: 10); AllocatedSize = f_GetAllocatedSize(WorkFileQual:'*FIRST'); Fild0100ptr = %realloc(Fild0100ptr: AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': WorkFileQual: '*FIRST': '0': '*FILETYPE': '*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' // arival or Fild0100ds.AccessType='EV'; // encoded vector 5b if ForCount1 > 0; QdbldbrPtr += ApiHead.ListEntrySize; 5e endif; 1i iter; 4e endif; //--------------------------------------------------------- exsr srKeys; 3e endif; 2e endif; 2b if ForCount1 > 0; QdbldbrPtr += ApiHead.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; sbfRow = *blanks; KeyList = *blanks; 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; // Some join lfs do not return an offset to // to file scope array. IBM has been notified. 1b if Fild0100ds.OffsFileScope > 0 and %bitand(bit6: Fild0100ds.TypeBits) = bit6; // keyed access path KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs; 2b for ForCount3 = 1 to FileScopeArry.NumOfKeys; // make (key1: key2) for pasting into rpg program 3b If IsLowerCase; // open parenthesis 4b if FileScopeArry.NumOfKeys > 1 and ForCount3 = 1; kwork='('+ %trimr(%lower(KeySpecsDS.KeyFieldName)) +':'; // close parenthesis 4x elseif FileScopeArry.NumOfKeys > 1 and ForCount3 = FileScopeArry.NumOfKeys; kwork = %trimr(%lower(KeySpecsDS.KeyFieldName)) +')'; // full colon between fields 4x elseif FileScopeArry.NumOfKeys > 1; kwork = %trimr(%lower(KeySpecsDS.KeyFieldName)) +':'; // single key with no (): 4x else; kwork = %trimr(%lower(KeySpecsDS.KeyFieldName)); 4e endif; 3x else; kwork = %trimr(KeySpecsDS.KeyFieldName); // check for descending keys 4b if %bitand(bit0: KeySpecsDS.KeySequenBits) = bit0; kwork = kwork + '(D)'; 4e endif; 3e endif; //--------------------------------------------------------- // If keys will not fit on one line, drop down to second line. // On the file description display the keys start at the beginning of the // subfile record. //--------------------------------------------------------- 3b if (IsDbrView and %len(%trimr(KeyList)) + (%len(kwork) + 1) > %size(KeyList)) or ((not isDbrView) and %len(%trimr(sbfRow)) + (%len(kwork) + 1) > %size(sbfRow)); 4b if IsDbrView; %subst(sbfrow:26) = KeyList; 4e endif; rrn += 1; write sbfDta1; sbfRow = *blanks; KeyList = *blanks; 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; SbfRowDS.soCon = *blanks; SelectOmitParmPtr = Fild0100ptr + SelectOmitParm.OffsToNext; 3e endfor; SelectOmitSpecPtr += 32; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- begsr srLineRow; sbfRowAtr = Blue; sbfrow = *blanks; %subst(sbfrow:1:70) = *all'_'; rrn += 1; write sbfDta1; endsr; //--------------------------------------------------------- begsr srPrint; f_OvrPrtf('JCRFDP': '*JOB' : 'JCRFDP'); open JCRFDP; write PrtHead; IsOverFlow = *off; 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'); // generate completion message then send to message subfile f_DisplayLastSplf(ProgId: '*PRINT'); snd-msg f_qmhrcvpm(3); endsr; ]]> '); //--------------------------------------------------------- // JCRFDV - Validity checking program for lib/long file/member //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_SndEscapeMsg /define p_JCRLONGFIL /COPY JCRCMDS,JCRCMDSCPY dcl-s shortfil char(10); //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_LongFileQual char(140); end-pi; // return short file name from long file name callp p_JCRLONGFIL(p_LongFileQual: shortfil); 1b if shortfil = *blanks; f_SndEscapeMsg('CPF9812: File '+%trimr(%subst(p_LongFileQual:1:130))+ ' in library ' + %trimr(%subst(p_LongFileQual:1:130))+' not found. '); 1x else; f_CheckMbr(shortfil + %subst(p_LongFileQual:131): p_Mbr); 1e endif; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('File Field Descriptions') 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(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) 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(*ADD) + VALUES(*REPLACE *ADD) PROMPT('Replace or + add records') PMTCTL1: PMTCTL CTL(OUTPUT) COND((*EQ '*OUTFILE') (*EQ + '*SRC')) NBRTRUE(*EQ 1) ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA A PRINT A CA03 A CA12 A R SBFDTA1 SFL A FLDTEXT50 50A H A FLDALIAS 10A H A SBLENGTH 5S 0H A SBTXT 35A O 7 2 A SBKEY 3A O 7 38 A SBFIELD 10A O 7 42 A SBDATATYPE 16A O 7 55 A SBFROMPOS 5Y 0O 7 72EDTCDE(4) A SBTOPOS 5Y 0O 7 78EDTCDE(4) A SBCCSID 5A O 7 86DSPATR(HI) *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0306) A SFLPAG(0018) A OVERLAY A CA04 A CA06 A CA07 A CA08 A CA09 A CA10 A CA11 A CA15 A CA16 A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) 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 EDTCDE(Y) 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 120A 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 4 86'Job CCSID:' A SCJOBCCSID 5A O 4 97 A 5 2'Search:' A COLOR(BLU) A SEARCHTXT 26A B 5 10 A SEARCHFLD 10A B 5 42DSPATR(PC) A SEARCHLEN 5Y 0B 5 55EDTCDE(4) A 5 61'Search Length' A COLOR(BLU) 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 55'Data Type ' A DSPATR(HI) A DSPATR(UL) A 6 74'Position' A DSPATR(HI) A DSPATR(UL) A CCSIDHEAD 20A O 6 86DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A AF4KEY 1A P A AF7KEY 1A P A AF8KEY 1A P A 26 2'F3=Exit' A COLOR(BLU) A 26 10'F6=Print' A COLOR(BLU) A 26 19'F9=By Field' A COLOR(BLU) A 26 31'F10=By Pos' A COLOR(BLU) A 26 42'F11=Show' A COLOR(BLU) A F11SHOW 6A O 26 51COLOR(BLU) A DBUTILITY 10A O 26 58COLOR(BLU) A 26 69'F16=Not Populated' A COLOR(BLU) A 26 87'F4=Rcdfmts' A DSPATR(&AF4KEY) A 26 98'F7=Select/Omit' A DSPATR(&AF7KEY) A 26113'F8=Toggle ALIAS' A DSPATR(&AF8KEY) *---------------------------------------------------------------- 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(5) 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=Cancel' 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(9) 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=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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRFFDF; CREATE TABLE JCRFFDF ( FLDTEXT50 CHAR(50) NOT NULL DEFAULT '' , SBKEY CHAR(3) NOT NULL DEFAULT '' , SBFIELD CHAR(10) NOT NULL DEFAULT '' , SBDATATYPE CHAR(16) NOT NULL DEFAULT '' , SBFROMPOS NUMERIC(5, 0) NOT NULL DEFAULT 0 , SBTOPOS NUMERIC(5, 0) NOT NULL DEFAULT 0 , FLDALIAS CHAR(10) NOT NULL DEFAULT '' , FROMFILE CHAR(10) NOT NULL DEFAULT '' , FILELIB CHAR(10) NOT NULL DEFAULT '' , SBLENGTH NUMERIC(5, 0) NOT NULL DEFAULT 0, SBCCSID CHAR(5) NOT NULL DEFAULT '') RCDFMT JCRFFDFR ; LABEL ON TABLE JCRFFDF IS 'File field descriptions - outfile jcr' ; LABEL ON COLUMN JCRFFDF ( FLDTEXT50 TEXT IS 'Text' , SBKEY TEXT IS 'Sequence Key' , SBFIELD TEXT IS 'Name' , SBDATATYPE TEXT IS 'Attribute' , SBFROMPOS TEXT IS 'From' , SBTOPOS TEXT IS 'To' , SBCCSID TEXT IS 'CCSID' , FLDALIAS TEXT IS 'Alias' , FROMFILE TEXT IS 'File' , FILELIB TEXT IS 'Library' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRFFDF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Lists field information from data file. Sort on any column and toggle between field names and alias names. Included are options to select record format to view. :P.If information is put into *SRC, RPGLE source code to initialize each file field is generated in member. :NT.Max record length, Max number of keys and Max number of fields are displayed if selecting record format from multi-record format file.:ENT. :P.The command has special extension that show 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.:EHELP. :HELP NAME='JCRFFD/RCDFMT'.Record Format - Help :XH3.Record Format (RCDFMT) :P.Select specific record format for multi-record format files.:EHELP. :HELP NAME='JCRFFD/UNPACK'.Show unpacked format - Help :XH3.Show unpacked format (UNPACK) :P.Output shows actual field start and end positions or adjusted position if packed fields were defined as zoned. :P.This option was added to show field positions as 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 as defined in data file. :PT.*YES :PD.Starting and ending position of data fields are adjusted to show as if data fields were unpacked.:EPARML.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRFFD/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print, display, outfile, source file output the 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. :HELP NAME='JCRFFD/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRFFD/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- 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 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'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 120A 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 68'Data Type' A 91'Location' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A FLDTEXT45 45A O 3 A SBKEY 3A 50 A SBFIELD 10A O 55 A SBDATATYPE 16A 68 A SBFROMPOS 5S 0O 88EDTCDE(4) A SBTOPOS 5S 0O 94EDTCDE(4) *---------------------------------------------------------------- A R PRTPAGEBRK SKIPB(2) A 1' ' ]]> '); //--------------------------------------------------------- // JCRFFDR - File Field Descriptions - print/display // call API to retrieve file field descriptions. // load entries to array and QLGSORT them into sequence. // Output information to selected media type. // V7 added show if field CCSID is different than default ccsid of job. // you will across some IBM files with CCSID of 65535 and have to use // cast(Field as varchar(Length) CCSID 37) to sql //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRFFDP printer oflind(IsOverFlow) usropn indds(indp); dcl-f JCRFFDD workstn sfile(sbfdta1: rrn1) infds(infds) sfile(windta3: rrn3) indds(ind) sfile(windta4: rrn4) usropn; dcl-f JCRFFDF usage(*output) extfile(extofile) extmbr(extombr) usropn; dcl-f RPGSRC disk(112) usage(*output) extfile(extofile) extmbr(extombr) usropn; /define ApiErrDS /define Constants /define Dspatr /define Infds /define psds /define FunctionKeys /define Ind /define f_BuildString /define Qdbrtvfd /define Qlgsort /define Quslfld /define BitMask /define f_DisplayLastSplf /define f_GetQual /define f_OvrPrtf /define f_Dltovr /define f_GetDayName /define f_Quscrtus /define f_SndCompMsg /define f_GetFileUtil /define f_RunOptionFile /define f_GetDataTypeKeyWords /define f_CamelCase /define SourceOutDS /define f_RmvSflMsg // *ENTRY /define p_JCRFFDR /COPY JCRCMDS,JCRCMDSCPY dcl-s QualActual char(21); dcl-s FileActual char(10); dcl-s LibActual char(10); dcl-s KeyFldsArry char(10) dim(50); dcl-s KeySeqArry char(1) dim(50); dcl-s SwapName char(10); dcl-s SortByFld char(10); dcl-s SearchKey char(3); dcl-s extOMbr char(10); dcl-s SortOverlay char(200) based(sortptr); dcl-s KeyCount like(filescopearry.numofkeys); dcl-s SoCount like(filescopearry.numselectomit); dcl-s ParmCount like(selectomitspec.numberofparms); dcl-s RcdFmtCount like(fild0100ds.numrcdfmts); dcl-s LengthOfBuffer int(10); dcl-s NextFrom uns(5) inz(1); dcl-s rrn1 like(rrn); dcl-s rrn3 like(rrn); dcl-s rrn4 like(rrn); dcl-s IsToggleAlias ind; dcl-s IsToggleKeys ind; dcl-s IsSearch ind; dcl-s IsFiltered ind; dcl-s IsFirstTime ind; dcl-s fscopePtrSave pointer; dcl-s PrtRrn like(rrn) inz(0); dcl-s unsignedlength uns(10); dcl-s DecimalPos char(2); dcl-ds indp qualified; // print file indicator IsUnPacked ind pos(09) inz; end-ds; dcl-ds QusrjobiDS qualified; JobDefaultCCSID int(10) pos(373); end-ds; dcl-pr qusrjobi extpgm('QUSRJOBI'); // retrieve job info *n like(QusrjobiDS); *n int(10) const; *n char(8) const; *n char(26) const; *n char(16) const; *n like(apierrds); end-pr; dcl-ds ScreenFieldDS extname('JCRFFDF') inz end-ds; //-----List fields not populated dcl-pr p_JCRNOTPOPR extpgm('JCRNOTPOPR'); *n char(20) const; *n char(10) const; *n char(8) const; end-pr; //--------------------------------------------------------- // get default job ccsid callp QUSRJOBI( QusrjobiDS: %size(QusrjobiDS): 'JOBI0400': '* ': ' ': ApiErrDs); scjobccsid = %char(QusrjobiDS.JobDefaultCCSID); //--------------------------------------------------------- f_RmvSflMsg(ProgId); ApiHeadPtr = f_Quscrtus(UserSpaceName); f11Show = 'Keys'; ccsidhead = *blanks; // Open appropriate output file depend on type 1b if p_Output = '*'; //DISPLAY open JCRFFDD; scDow = f_GetDayName(); DbUtility = 'F15=' + f_GetFileUtil(); 1x elseif p_Output = '*PRINT'; f_OvrPrtf('JCRFFDP': '*JOB': %subst(p_FileQual: 1: 10)); open JCRFFDP; scDow = f_GetDayName(); indp.IsUnPacked = (p_UnPack = '*YES'); 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 //--------------------------------------------------------- AllocatedSize = f_GetAllocatedSize(p_FileQual: p_RcdFmt); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: 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 1b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; FileType4 = '*LF'; 1x else; FileType4 = '*PF'; 1e endif; QualActual = f_GetQual(FileActual + LibActual); exsr srLoadRcdFmtInfo; //--------------------------------------------------------- 1b if p_Output = '*'; exsr srProcessSubfile; f_SndCompMsg('JCRFFD for ' + %trimr(QualActual) + ' - completed'); 1x elseif p_Output = '*PRINT'; f_Dltovr('JCRFFDP'); close JCRFFDP; f_DisplayLastSplf('JCRFFDR': p_Output); 1x elseif p_Output = '*OUTFILE'; close JCRFFDF; f_SndCompMsg('Outfile ' + %trimr(extOfile) + ' generated by JCRFFD.'); 1e endif; dealloc(n) 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 *on; Ind.sfldsp = rrn1 > 0; Ind.sfldspctl = *on; write msgctl; write sfooter1; exfmt sbfctl1; IsSearch = *off; f_RmvSflMsg(ProgId); 2b if InfdsFkey in %list(f03 :f12); LV leavesr; 2x elseif InfdsFkey = f04 and Fild0100ds.NumRcdFmts > 1; exsr srPromptRcdFmt; 2x elseif InfdsFkey = F06; exsr srPrintScreen; snd-msg '** Print Completed **'; 2x elseif InfdsFkey = F07 and FileScopeArry.NumSelectOmit > 0; exsr srSelectOmit; 2x elseif InfdsFkey = f08; IsToggleAlias = *on; 3b if FldOrAlias = 'Field'; FldOrAlias = 'ALIAS'; 3x else; FldOrAlias = 'Field'; 3e endif; 3b for rrn1 = 1 to ApiHead.ListEntryCount; chain rrn1 sbfdta1; 4b if FldAlias > *blanks; SwapName = sbField; sbField = FldAlias; FldAlias = SwapName; 4e endif; update sbfdta1; 3e endfor; 2x elseif InfdsFkey = f09; snd-msg 'Sort by Field Name'; f11Show = 'Keys'; SortByFld = 'SBFIELD'; exsr srResequence; 2x elseif InfdsFkey = f10; snd-msg 'Sort by Position'; f11Show = 'Keys'; SortByFld = 'SBFROMPOS'; exsr srResequence; 2x elseif InfdsFkey = f11; 3b if f11Show = 'Keys'; f11Show = 'Fields'; SortByFld = 'SBKEY'; SearchKey = 'Key'; IsSearch = *on; exsr srResequence; SearchKey = *blanks; 3x else; f11Show = 'Keys'; SortByFld = 'SBFROMPOS'; exsr srResequence; 3e endif; 2x elseif InfdsFkey = f15; f_RunOptionFile(2: FileActual: LibActual: '*FIRST': '*FIRST': ProgId); 2x elseif InfdsFkey = f16; callp p_JCRNOTPOPR(FileActual+ LibActual:'*FIRST':'*'); 2x elseif SearchTxt > *blanks or SearchFld > *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 = ApiHeadPtr + ApiHead.OffSetToList; SortPtr = QuslfldPtr; 1b for ForCount = 1 to ApiHead.ListEntryCount; sbField = QuslfldDS.FieldName; FldText50 = QuslfldDS.FieldText; FldAlias = QuslfldDS.AlternativeFieldName; 2b if QuslfldDS.AlternativeFieldName > *blanks; aF8Key = Blue; 2e endif; 2b if FldText50 = *blanks and FldAlias > *blanks; // show alias if no text FldText50 = QuslfldDS.AlternativeFieldName; 2e endif; // Determine if field Key field and A or Descending aa = %lookup(sbField: KeyFldsArry: 1: KeyCount); 2b if aa > 0; 3b if aa<=9; sbKey = KeySeqArry(aa) + '0'+ %char(aa); 3x else; sbKey = KeySeqArry(aa) + %char(aa); 3e endif; 2x else; sbKey = *blanks; 2e endif; //--------------------------------------------------------- // Calculate ending position of each field. //--------------------------------------------------------- 2b if QuslfldDS.Digits > 0; // numeric unsignedlength = QuslfldDS.Digits; DecimalPos = %triml(%editc(QuslfldDS.DecimalPos:'3')); 2x else; unsignedlength = QuslfldDS.FieldLengthA; DecimalPos = *blanks; 2e endif; sbDataType = %scanrpl(';':' ': f_GetDataTypeKeyWords( QuslfldDS.FieldType: unsignedlength: DecimalPos)); sbLength = unsignedlength; // for length searches 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; SBCCSID = *blanks; 2b if QuslfldDS.FieldCCSID > 0; 3b if QuslfldDS.FieldCCSID <> QusrjobiDS.JobDefaultCCSID; ccsidhead = 'CCSID Field <> Job'; SBCCSID = %char(QuslfldDS.FieldCCSID); 3e endif; 2e endif; // write to output type //----------------------------------------------------------------- // use a particularly sleazy,obscure overlay of an unused // portion of the user space entry to store my screen fields, // after the sort I can just pull the fields back out without re-processing. //----------------------------------------------------------------- 2b if p_Output = '*'; %subst(QuslfldDS:101: %len(ScreenFieldDS)) = ScreenFieldDS; sbTxt = f_CamelCase(FldText50); rrn1 += 1; PrtRrn += 1; write sbfdta1; 2x elseif p_Output = '*PRINT'; FldText45 = FldText50; write PrtDetail; 3b if IsOverFlow; 4b if ForCount <> ApiHead.ListEntryCount; // avoid last blank page write PrtPageBrk; 4e endif; IsOverFlow = *off; 3e endif; 2x elseif p_Output = '*OUTFILE'; write JCRFFDFR; 2x elseif p_Output = '*SRC'; OutDS.SrcCod = ' clear ' + %trimr(sbField) + ';'; OutDS.SrcSeq += 1; write RPGSRC OutDS; 2e endif; QuslfldPtr += ApiHead.ListEntrySize; 1e endfor; endsr; //--------------------------------------------------------- // get pointer to file scope array for 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 %bitand(bit6: Fild0100ds.TypeBits) = bit6; // keyed access path 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 %bitand(bit0: KeySpecsDS.KeySequenBits) = bit0; 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; IsOverFlow = *off; 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; select3 = *blanks; // 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; 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': '*JOB': %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 bb = 1 to PrtRrn; chain bb sbfdta1; FldText45 = FldText50; write PrtDetail; 2b if IsOverFlow; 3b if bb <> PrtRrn; // avoid last blank page write PrtPageBrk; 3e endif; 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 = ApiHead.ListEntrySize; qlgsortDS.RecordCount = ApiHead.ListEntryCount; // note sort key positions are where I overlaid user space entry // with my screen fields. 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(180: 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 = ApiHead.ListEntryCount * ApiHead.ListEntrySize; callp QLGSORT( qlgsortDS: SortOverlay: SortOverlay: LengthOfBuffer: LengthOfBuffer: ApiErrDS); QuslfldPtr = SortPtr; 1b for ForCount = 1 to ApiHead.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 SearchLen > 0; IsFiltered = (sbLength = SearchLen); 3x elseif SearchTxt > *blanks; IsFiltered = %scan(%trimr(SearchTxt): %upper(FldText50)) > 0; 3e endif; 2e endif; 2b if IsFiltered; sbTxt = f_CamelCase(FldText50); rrn1 += 1; PrtRrn += 1; write sbfdta1; 2e endif; QuslfldPtr += ApiHead.ListEntrySize; 1e endfor; endsr; ]]> '); //--------------------------------------------------------- // JCRFFDV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_GetFileLevelID /define f_OutFileCrtDupObj // *ENTRY /define p_JCRFFDR /COPY JCRCMDS,JCRCMDSCPY dcl-s levelid char(13); //--------------------------------------------------------- 1b if not(%subst(p_FileQual: 11: 10) = '*LIBL'); f_CheckObj(%subst(p_FileQual: 11: 10) + 'QSYS': '*LIB'); 1e endif; // if invalid record format, function throws an exception message LevelID = f_GetFileLevelID(p_FileQual: p_RcdFmt); 1b if p_Output = '*SRC'; f_CheckMbr(p_OutFileQual: %subst(p_OutMbrOpt: 3: 10)); 1x elseif p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRFFDF'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Free/Fixed Side-by-Side View') PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('RPG member') 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') ]]> .*-------------------------------------------------------------------- :P.Shows original RPGLE fixed column calc specs on left side of screen and what code would look like in free format on right. :P.Opcodes with ????????? mean this is not valid in free and must be re-written. It is surprising to view the number of deprecated opcdes IBM has dropped. :P.Code clean up is recommended so no ?????????? are showing before making converting to free. :P.Summary page is produced at bottom of each report showing each opcode that could not be converted and number of times used in the code.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRFREESS/SRCMBR'.RPG member name - Help :XH3.RPG member name (SRCMBR) :P.Member whose side-by-side list 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 or * Display the listing.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 198) CPI(15) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRFREESS' A 23'Free/Fixed Side-by-Side View' A SCDOW 9A O 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100SPACEA(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 Format Validation' 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 EDTCDE(Y) SPACEA(1) *--- A 2'Mbr:' A SCOBJHEAD 105A O 7SPACEA(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) ]]> '); //--------------------------------------------------------- // JCRFREESSR - Free/fixed side-by-side source view //--------------------------------------------------------- // Originally designed to be conversion program between fixed format // and free. In the process, it became clear just how hard that would be without // intentional rewrites of the legacy code. // Any lines with ???????????????????? are invalid in /free and must be re-written. // Final page of report is summary/count of invalid opcodes. //--------------------------------------------------------- /define ControlStatements /define psds /define SrcDS /define Constants /define f_DisplayLastSplf /define f_GetQual /define f_IsCompileTimeArray /define f_GetDayName /define f_BuildString /define f_RunCmd /define f_Qusrmbrd /define f_Dltovr /COPY JCRCMDS,JCRCMDSCPY dcl-f V4SRC disk(112) extfile(extifile) extmbr(p_srcmbr) usropn; dcl-f JCRFREESSP printer oflind(*in01) usropn; dcl-s ee like(levelsdeep); dcl-s ff like(levelsdeep); dcl-s F2upper like(f2); dcl-s OpUpsave like(opup); dcl-s RFupper like(srcds.resultfield); dcl-s Work like(srcds.src112); dcl-s WorkUpper like(srcds.src112); dcl-s xx like(levelsdeep); dcl-s yy like(levelsdeep); dcl-s OpCodeArry char(10) dim(200); dcl-s LF2 char(14); dcl-s LineOfCode char(112); dcl-s zz char(14); dcl-s CountArry uns(5) dim(200); dcl-s LevelsDeep uns(5); dcl-s DownOneLevel ind; dcl-s IsCalcSpec ind; dcl-s IsCallp ind; dcl-s IsCasxx ind; dcl-s IsWhenIndent ind; dcl-s UpOneLevel ind; dcl-s IsFree ind; dcl-s IsSQL ind; dcl-s IsComment ind; dcl-ds *n; OpUp char(10); DoIfWh char(2) samepos(OpUp); EndOpcode char(3) samepos(OpUp); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_Output char(8); end-pi; //--------------------------------------------------------- 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); extIfile = f_GetQual(p_SrcFilQual); f_RunCmd('OVRPRTF FILE(JCRFREESSP) ' + 'SPLFNAME(' + %trimr(p_SrcMbr) + ') ' + 'PRTTXT(*BLANK) OVRSCOPE(*JOB)'); open v4Src; open JCRFREESSp; scDow = f_GetDayName(); write PrtHead; //--------------------------------------------------------- read v4Src SrcDs; 1b dow not %eof; Seqno = SrcDS.SeqNum6; F1 = SrcDS.Factor1; OP = SrcDS.OpCode; F2 = SrcDS.Factor2; RF = SrcDS.ResultField; RSI = SrcDS.ResultingInd; 2b if f_IsCompileTimeArray(SrcDS.CompileArray) or %upper(SrcDS.SpecType) = 'P'; 1v leave; 2e endif; // see if inside /free 2b if SrcDS.Asterisk = '/'; SrcDS.FreeForm = %upper(SrcDS.FreeForm); 3b if SrcDS.FreeForm = '/FREE'; IsFree = *on; IsCalcSpec = *on; 3x elseif SrcDS.FreeForm = '/END-FREE'; IsFree = *off; 3e endif; 3b if SrcDS.FreeForm = '/EXEC SQL'; IsSQL = *on; IsCalcSpec = *on; 3x elseif SrcDS.FreeForm = '/END-EXEC'; IsSQL = *off; 3e endif; 2e endif; 2b if %upper(SrcDS.SpecType) = 'C'; IsCalcSpec = *on; 2b elseif %upper(SrcDS.SpecType) in %list('O': 'D': 'F'); IsCalcSpec = *off; 2e endif; 2b if IsCalcSpec; DownOneLevel = *off; UpOneLevel = *off; 3b if not (SrcDS.Asterisk in %list('+':'/')); 4b if SrcDS.OpCode > *blanks; IsCallp = *off; 4e endif; OpUp = %upper(SrcDS.OpCode); 4b if SrcDS.Asterisk = '*'; 4x elseif EndOpcode = 'CAS'; IsCasxx = *on; 4x elseif DoIfWh in %list('DO':'IF') // note %list cannot be DS name 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 4x elseif EndOpcode = 'END'; 5b if not IsCasxx; UpOneLevel = *on; 5e endif; IsCasxx = *off; 4e endif; 3e endif; // Convert EVERYTHING to free format Work = *blanks; LineOfCode = *blanks; IsComment = *off; 3b if IsFree or IsSql; Work = SrcDS.Src112; 3x elseif SrcDS.Asterisk = '*'; 4b if %subst(SrcDS.Src112: 8) = *blanks; Work = *blanks; 4x else; Work = '// ' + %triml(%subst(SrcDS.Src112: 8)); IsComment = *on; 4e endif; 3x elseif %upper(SrcDS.SlashComment) = '/E'; Work = *blanks; //--------------------------------------------------------- // All DO statements must be converted to FOR opcodes // There are 5 variations of 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 //--------------------------------------------------------- 3x elseif OpUp = 'DO'; 4b 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; 4x elseif SrcDS.Factor1 > *blanks //aa DO xx and SrcDS.Factor2 > *blanks and SrcDS.ResultField = *blanks; Work = 'for JCRCNT = ' + %trimr(SrcDS.Factor1) + ' to ' + SrcDS.Factor2; 4x elseif SrcDS.Factor1 = *blanks //DO xx yy and SrcDS.Factor2 > *blanks and SrcDS.ResultField > *blanks; Work = 'for ' + %trimr(SrcDS.ResultField) + ' = 1 to ' + SrcDS.Factor2; 4x elseif SrcDS.Factor1 = *blanks //DO xx and SrcDS.Factor2 > *blanks and SrcDS.ResultField = *blanks; Work = 'for JCRCNT = 1 to ' + SrcDS.Factor2; 4x elseif SrcDS.Factor1 = *blanks //DO and SrcDS.Factor2 = *blanks and SrcDS.ResultField = *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 = 'eval ' + %trimr(SrcDS.ResultField) + ' = %subdt(' + %trimr(SrcDS.Factor2) + ')'; 3x elseif %subst(OpUp: 1: 5) = 'CHECK'; Work = 'eval ' + %trimr(SrcDS.ResultField) + ' = %' + %trimr(SrcDS.OpCode) + '(' + %trimr(SrcDS.Factor1) + ':' + %trimr(SrcDS.Factor2) + ')'; 3x elseif %subst(OpUp: 1: 5) = 'XLATE'; Work = 'eval ' + %trimr(SrcDS.ResultField) + ' = %' + %trimr(SrcDS.OpCode) + '(' + %trimr(SrcDS.Factor1) + ':' + %trimr(SrcDS.Factor2) + ')'; 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 OpUp in %list('BEGSR ':'MONITOR':'ON-ERROR': 'CLEAR ') or %subst(OpUp: 1: 3) in %list('ACQ':'END':'IN ': 'IN(':'OUT' :'REL') or %subst(OpUp: 1: 4) in %list('POST':'NEXT':'DUMP') or %subst(OpUp: 1: 5) in %list('CHAIN':'DSPLY':'READE': 'RESET':'SETGT':'SETLL':'TEST ':'TEST(') or %subst(OpUp: 1: 6) in %list('COMMIT':'DELETE': 'READPE':'ROLBK':'UNLOCK'); 4b if SrcDS.Factor1 = *blanks; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 4x else; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor1) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 4e endif; // resulting ind errors 4b if SrcDS.ResultingInd > *blanks; Work = %trimr(Work) + ' ??' + %trim(SrcDS.ResultingInd) + '????????????????'; OpUpsave = OpUp; OpUp = 'ResultInd'; exsr srLoadError; OpUp = OpUpsave; 4e endif; //--------------------------------------------------------- // opcode FACTOR2 RESULT conversions. // opcode FACTOR2 // end result is Opcode Factor2 Result //--------------------------------------------------------- 3x elseif OpUp in %list('EXCEPT ':'EXFMT':'EXSR':'ELSE': 'ELSEIF':'FORCE':'ITER':'LEAVE':'LEAVESR':'OTHER ': 'SELECT ' :'SORTA ') or %subst(OpUp: 1: 4) in %list('OPEN':'FEOD') or %subst(OpUp: 1: 5) in %list('CLOSE':'READ ': 'READC':'READP':'WRITE') or %subst(OpUp: 1: 6) = 'UPDATE'; Work = %trimr(SrcDS.OpCode) + ' ' + %trimr(SrcDS.Factor2) + ' ' + SrcDS.ResultField; 4b if SrcDS.ResultingInd > *blanks; Work = %trimr(Work) + ' ??' + %trim(SrcDS.ResultingInd) + '????????????????'; OpUpsave = OpUp; OpUp = 'ResultInd'; exsr srLoadError; OpUp = OpUpsave; 4e endif; //--------------------------------------------------------- // Opcode RESULT field simple compressions //--------------------------------------------------------- 3x 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. //--------------------------------------------------------- 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(SrcDS.OpCode) + ' ' + SrcDS.ExtendFactor2; // get position for callp parms to line up with factor2 bb = %scan(SrcDS.ExtendFactor2: Work); 4b if %subst(OpUp: 1: 5) = 'CALLP'; IsCallp = *on; 4e endif; 3x else; //--------------------------------------------------------- 4b if OpUp = *blanks; 5b if not IsCallp; Work = SrcDS.ExtendFactor2; 5x else; Work = *blanks; %subst(Work: bb) = %trimr(SrcDS.ExtendFactor2); 5e endif; 4x else; exsr srLoadError; Work = %trimr(SrcDS.OpCode) + ' ?????????????????????????'; 4e endif; 3e endif; exsr srOutput; 2e endif; read v4Src SrcDs; 1e enddo; write PrtSumHead; 1b for ff = 1 to ee; sumopcod = OpCodeArry(ff); sumCount = CountArry(ff); write PrtSumDet; 1e endfor; close v4Src; close JCRFREESSp; f_DltOvr('JCRFREESSP'); f_DisplayLastSplf('JCRFREESSR': p_Output); *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 = %upper(SrcDS.Factor2); rfupper = %upper(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; zz = *blanks; lf2 = SrcDS.Factor2; f2upper = %upper(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 not(%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; LineOfCode = *blanks; xx = 1; 1b for yy = 1 to LevelsDeep; 2b if xx <= 109; // less than 37 levels deep %subst(LineOfCode: xx: 3) = *blanks; 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 = %upper(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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Scan File Set Where Used') 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(SRCFILE) TYPE(SRCFILE) MIN(1) MAX(9) + PROMPT('Source File(s)') SRCFILE: ELEM TYPE(*CHAR) LEN(10) CHOICE(*PGM) + CHOICEPGM(*LIBL/JCRSMLTRC) PROMPT('File') 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,CLP,DSPF,etc.') + PROMPT(' Mbr Type') 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) 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) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRFSETF; CREATE TABLE JCRFSETF ( SRCLIB CHAR(10) NOT NULL DEFAULT '' , SRCFIL CHAR(10) NOT NULL DEFAULT '' , LISTMBR CHAR(10) NOT NULL DEFAULT '' , MBRTYPE CHAR(10) NOT NULL DEFAULT '' , SRCTXT CHAR(40) NOT NULL DEFAULT '' , SRCDTA CHAR(100) NOT NULL DEFAULT '' , SCANFILE CHAR(10) NOT NULL DEFAULT '' , SRELATEF CHAR(10) NOT NULL DEFAULT '' ) RCDFMT JCRFSETFR ; LABEL ON TABLE JCRFSETF IS 'Scan file set where used - outfile jcr' ; LABEL ON COLUMN JCRFSETF ( SRCLIB TEXT IS 'Source library' , SRCFIL TEXT IS 'Source file' , LISTMBR TEXT IS 'Source mbr' , MBRTYPE TEXT IS 'Mbr Type' , SRCTXT TEXT IS 'Text' , SRCDTA TEXT IS 'Source' , SCANFILE TEXT IS 'Original File' , SRELATEF TEXT IS 'Relation File' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRFSETF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Scans selected *RPGLE source files for selected data file. Retrieves the PF and related LF names then scans for those names in selected source members. :P.End result is print or outfile of all source members that use selected file or related logical. :NT.To define many scanned source files with a single keyword, add records to JCRSMLTCHF. These records drive the choice text if you F4 prompt the File Name. Great way to pre-select groups of source files scanned often.:ENT. :NT.The library of the file is added to library list.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRFSET/FILE'.File Name - Help :XH3.File Name (FILENAME) :P.File name whose data base relations is 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 the command will search. :NT.Associate unlimited numbers of files with single keyword in file JCRSMLTCHF. Choice Keyword must begin with character * :ENT.: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 might 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 interactive session for extended time if scanning large number of members.:EPARML.:EHELP. :HELP NAME='JCRFSET/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output. :P.JCRFSETF cannot be specified as outfile to receive output.:EHELP. :HELP NAME='JCRFSET/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- 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 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'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 HSRCLIB 10A O 20 A HSRCFIL 10A O 32 A HSRCMBR 10A O 44 A HSRCMBRTYP 10A 56 *----------------------------------------------------- A R PRTHEAD4 SPACEA(1) A 1'Library' A 12'File' A 26'Member' A 40'Text' A 80'Source Data' SPACEA(1) *--- A 1'----------' A 12'----------' A 26'----------' A 38'----------------------------------- A ------' A 80'----------------------------------- A ------------------------------------ A -----------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SRCLIB 10A O 1 A SRCFIL 10A O 12 A LISTMBR 10A O 26 A SRCTXT 40A 38 A SRCDTA80 80A O 80 ]]> '); //--------------------------------------------------------- // 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. // // Search any number of preselected source library and files if // choice key is entered in file JCRSMLTCHF. // // new for v7 is to move all the rpgle fspec retrieval to jcrgetfilr so // traditional D specs and new DCL-F file specs are scanned. Slower than original. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f MBRSRC disk(112) extfile(extifile) usropn extmbr(openmbr) infds(infds); dcl-ds SrcDS qualified inz; Src112 char(100) pos(13); end-ds; dcl-f JCRFSETF usage(*output) extfile(extofile) extmbr(extombr) usropn; dcl-f JCRFSETP printer oflind(IsOverFlow) indds(ind) usropn; dcl-f JCRSMLTCHF keyed usropn; /define ApiErrDS /define psds /define Constants /define f_BlankCommentsCL /define Ind /define Infds /define Qdbldbr /define Qdbrtvfd /define f_GetDayName /define f_BuildString /define Quslmbr /define BitMask /define f_GetQual /define f_Quscrtus /define f_OvrPrtf /define f_DltOvr /define f_RunCmd /define f_IsCompileTimeArray /define p_JCRGETFILR /COPY JCRCMDS,JCRCMDSCPY dcl-s BasedOnPfQual char(20); dcl-s extOMbr char(10); dcl-s OpenMbr char(10); dcl-s PhysicalFile char(10); dcl-s Displacement int(5) based(displaceptr); dcl-s NumOfLists int(5) based(srclistptr); dcl-s ForCount3 uns(5); dcl-s IsClMbr ind inz(*off); dcl-s IsFirstTime ind; dcl-s PredefinedKey like(ChoiceKey); dcl-s SrcFileQual char(20); dcl-ds LdaDS DTAARA(*usrctl: *LDA) qualified; SrcFiles char(398); DataFileQual char(20); ActualLib char(10) overlay(DataFileQual:11); LfSameLib char(4); Output char(8); OutFileQual char(20); OutMbrOpt char(22); end-ds; // Get source file/lib/mbr names selected dcl-ds InnerListDS based(InnerListPtr); SrcFil char(10) pos(3); SrcLib char(10) pos(13); SrcMbr char(10) pos(23); SrcMbrTyp char(10) pos(33); end-ds; //--*ENTRY------------------------------------------------- // LDA is used for long parms //--------------------------------------------------------- in LdaDS; //* Use pointers to overlay input parms with DS values SrcListPtr = %addr(LdaDS.SrcFiles); scDow = 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': '*JOB': %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; 1e endif; // Create user spaces/retrieve pointer ApiHeadPtr = f_Quscrtus(UserSpaceName); ApiHeadPtr2 = f_Quscrtus(UserSpaceName2); // if selected file is LF, the based-on-PF name is found // and processing continues as if PF had been selected. AllocatedSize = f_GetAllocatedSize(LdaDS.DataFileQual: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': LdaDS.DataFileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); LdaDS.DataFileQual = ReturnFileQual; //actual file lib BasedOnPfQual = ReturnFileQual; //physical file 1b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; BasedOnPfQual = FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib; 1e endif; PhysicalFile = %subst(BasedOnPfQual: 1: 10); scanFile = LdaDS.DataFileQual; IsFirstTime = *on; // make sure file library is in library list else scan will not work f_RunCmd(f_BuildString('ADDLIBLE LIB(&)': %subst(BasedOnPfQual: 11: 10))); //--------------------------------------------------------- 1b if LdaDS.Output = '*PRINT'; scObjHead = f_BuildString('& & &': %subst(ReturnFileQual: 1: 10): %subst(ReturnFileQual: 11: 10): Fild0100ds.FileText); write PrtHead; IsOverFlow = *off; // 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; 3b if not(%subst(SrcFil:1 :1) = '*'); hSrcLib = SrcLib; hSrcFil = SrcFil; hSrcMbr = SrcMbr; hSrcMbrTyp = SrcMbrTyp; write PrtHead2; 3x else; 4b if not %open(JCRSMLTCHF); open JCRSMLTCHF; 4e endif; PredefinedKey = %subst(SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; reade PredefinedKey JCRSMLTCHR; 4b dow not %eof; hSrcLib = ChoiceLib; hSrcFil = ChoiceFil; hSrcMbr = ChoiceMbr; hSrcMbrTyp = ChoiceTyp; write PrtHead2; 5b if IsOverFlow; write PrtHead; IsOverFlow = *off; 5e endif; Ind.HeadingSwitch = *on; reade PredefinedKey JCRSMLTCHR; 4e enddo; 3e endif; Ind.HeadingSwitch = *on; 2e endfor; write PrtHead4; 1e endif; DisplacePtr = SrcListPtr; 1b for ForCount3 = 1 to NumOfLists; DisplacePtr += 2; InnerListPtr = SrcListPtr + Displacement; extIfile = f_GetQual(SrcFil + SrcLib); 2b if not(%subst(SrcFil:1 :1) = '*'); exsr srGetMbrList; 2x else; 3b if not %open(JCRSMLTCHF); open JCRSMLTCHF; 3e endif; PredefinedKey = %subst(SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; reade PredefinedKey JCRSMLTCHR; 3b dow not %eof; SrcLib = ChoiceLib; SrcFil = ChoiceFil; SrcMbr = ChoiceMbr; SrcMbrTyp = ChoiceTyp; extIfile = f_GetQual(SrcFil + SrcLib); exsr srGetMbrList; reade PredefinedKey JCRSMLTCHR; 3e enddo; 2e endif; 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; dealloc(n) Fild0100ptr; *inlr = *on; return; //----------------------------------------------------- // load user space with mbr name list for selected files //----------------------------------------------------- begsr srGetMbrList; callp QUSLMBR( UserSpaceName: 'MBRL0200': SrcFil + SrcLib: SrcMbr: '0': ApiErrDS); 1b if ApiErrDS.BytesReturned = 0; //no errors on return // Process members in user space QuslmbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 2b for ForCount = 1 to ApiHead.ListEntryCount; // member type selection 3b if SrcMbrTyp = '*ALL' or SrcMbrTyp = QuslmbrDS.MbrType; OpenMbr = QuslmbrDS.MbrName; 4b if %subst(QuslmbrDS.MbrType: 1: 2) = 'CL'; //--------------------------------------------------------- // retrieve data base relation names 5b if IsFirstTime; callp QDBLDBR( UserSpaceName2: 'DBRL0100': BasedOnPfQual: '*ALL': '*ALL': ApiErrDS); IsFirstTime = *off; 5e endif; open MBRSRC; exsr srReadClpMbr; close MBRSRC; 4x elseif %subst(QuslmbrDS.MbrType: 1: 2) = 'RP' or %subst(QuslmbrDS.MbrType: 1: 2) = 'SQ'; exsr srRpgMbr; 4e endif; 3e endif; QuslmbrPtr += ApiHead.ListEntrySize; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // program to load F and dcl-f into element per file record format //--------------------------------------------------------- begsr srRpgMbr; IsClMbr = *off; sRelateF = PhysicalFile; SrcFileQual = SrcFil + SrcLib; callp p_JCRGETFILR( QuslmbrDS.MbrName: SrcFileQual: FileCount: OnePerRcdFmt: FspecArry: CommentArry: PrNameArry: DeleteArry); // get count of number of record formats returned bb = 0; aa = 1; 1b dou OnePerRcdFmt(aa).File = *blanks; aa += 1; bb += 1; 1e enddo; 1b for aa = 1 to bb; 2b if OnePerRcdFmt(aa).File = PhysicalFile or OnePerRcdFmt(aa).BasedOnPF = PhysicalFile; sRelateF = OnePerRcdFmt(aa).File; SrcDS.Src112 = FspecArry(OnePerRcdFmt(aa).FileCount); exsr srPrintLine; 1v leave; 2e endif; 1e endfor; 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 SrcDs; 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 = %upper(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 short file name like MON for example, check for // check for MON) or MON space. // This will not help if file name is MSG // but it will clean up a lot of scans. //--------------------------------------------------------- 4b if %scan(%trimr(PhysicalFile) + ' ': SrcDS.Src112) > 0 or %scan(%trimr(PhysicalFile) + ')': SrcDS.Src112) > 0; sRelateF = PhysicalFile; exsr srPrintLine; LV leavesr; 4x else; // spin through DBRL user space looking for file name matches QdbldbrPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 5b if not(QdbldbrDS.DependentLF = '*NONE'); 6b for ForCount2= 1 to ApiHead2.ListEntryCount; 7b if %scan(%trimr(QdbldbrDS.DependentLF) + ' ': SrcDS.Src112) > 0 or %scan(%trimr(QdbldbrDS.DependentLF) + ')': SrcDS.Src112) > 0; sRelateF = QdbldbrDS.DependentLF; exsr srPrintLine; LV leavesr; 7e endif; QdbldbrPtr += ApiHead2.ListEntrySize; 6e endfor; 5e endif; 4e endif; 3e endif; 2e endif; read MBRSRC SrcDs; 1e enddo; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srPrintLine; ListMbr = QuslmbrDS.MbrName; MbrType = QuslmbrDS.MbrType; SrcTxt = QuslmbrDS.Text; 1b if LdaDS.Output = '*PRINT'; SrcDta80 = SrcDS.Src112; write PrtDetail; 1x else; SrcDta = SrcDS.Src112; write JCRFSETFR; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRFSETS - Scan File Set Where Used - submitter // Save existing *LDA // Load long list variables to *LDA // sbmjob for print, run interactive for display // Reset *LDA to previous value. //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_RunCmd /define f_SndCompMsg /define f_DisplayLastSplf // *ENTRY /define p_JCRFSETS /COPY JCRCMDS,JCRCMDSCPY dcl-s SavLda like(LdaDS); dcl-ds LdaDS DTAARA(*LDA) qualified; SrcFiles char(398); DataFileQual char(20); LfSameLib char(4); Output char(8); OutFileQual char(20); OutMbrOpt char(22); end-ds; dcl-pr p_JCRFSETR extpgm('JCRFSETR') end-pr; //--------------------------------------------------------- SavLda = LdaDs; LdaDs.srcFiles = p_SrcFiles; LdaDS.DataFileQual = p_DtaFileQual; LdaDS.Output = p_Output; LdaDS.OutFileQual = p_OutFileQual; LdaDS.OutMbrOpt = p_OutMbrOpt; LdaDS.LfSameLib = p_LfSameLib; out LdaDS; 1b if p_Output = '*'; callp p_JCRFSETR(); // interactive show spooled file f_DisplayLastSplf('JCRFSETR': p_Output); 1x else; f_RunCmd('SBMJOB CMD(CALL JCRFSETR) JOB(JCRFSET) JOBQ(QTXTSRCH)'); f_SndCompMsg('Job JCRFSET submitted to job queue QTXTSRCH.'); 1e endif; // replace original LDA LdaDs = SavLda; out LdaDS; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRFSETV - Validity checking program // If file already exists, open to verify no level checks. // If the source file name starts with *, then read the // pre-defined file groups in JCRSMLTCHF. //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_SndEscapeMsg /define f_OutFileCrtDupObj // *ENTRY /define p_JCRFSETS /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRSMLTCHF keyed usropn; dcl-s OffsetToNext int(5) based(DisplacePtr); dcl-s NumOfLists int(5) based(p_SrcFilesPtr); dcl-s ForCount uns(3); dcl-s PredefinedKey like(ChoiceKey); // Get number of source files and source File/Lib/Mbr names dcl-ds InnerList based(InnerListPtr) qualified; SrcFil char(10) pos(3); SrcLib char(10) pos(13); end-ds; //--------------------------------------------------------- f_CheckObj(p_DtaFileQual: '*FILE'); 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 + OffsetToNext; 2b if not(%subst(InnerList.SrcFil: 1: 1) = '*'); f_CheckMbr(InnerList.SrcFil + InnerList.SrcLib:'*FIRST'); 2x else; exsr srCheckPreDefinedFiles; 2e endif; 1e endfor; 1b if p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRFSETF'); 1e endif; *inlr = *on; return; //------------------------------------------ begsr srCheckPreDefinedFiles; open JCRSMLTCHF; PredefinedKey = %subst(InnerList.SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; 1b if not %equal; f_SndEscapeMsg('Predefined key ' + %trimr(PreDefinedKey) + ' not in file JCRSMLTCHF.'); 1x else; reade PredefinedKey JCRSMLTCHR; 2b dow not %eof; f_CheckObj(CHOICEFIL + CHOICELIB:'*FILE'); reade PredefinedKey JCRSMLTCHR; 2e enddo; 1e endif; close JCRSMLTCHF; endsr; ]]> '); //--------------------------------------------------------- // JCRF7 - seu exit program - split/combine lines. // To activate for your seu sessions. // 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. . . mylib___ Name // (mylib=your jcrcmds 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. // Combining lines will not delete second line. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) stgmdl(*teraspace) alloc(*stgmdl); dcl-ds HeadDS based(pHeadPtr) qualified; RecLen int(10) pos(1); CursorPos int(10) pos(9); F7Key char(1) pos(61); end-ds; dcl-s SrcLines char(282) based(pSrcLinesPtr); dcl-s line1 char(120); dcl-s line2 char(120); dcl-s xx uns(3); dcl-ds ReturnDS based(pReturnPtr) qualified; Code char(1) pos(1); Rec int(10) pos(5); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; pHeadPtr pointer; pReturnPtr pointer; pSrcLinesPtr pointer; end-pi; //--------------------------------------------------------- 1b if HeadDS.F7Key = '7' and HeadDS.CursorPos > 0; line1 = %subst(SrcLines:21: HeadDS.RecLen); line2 = %subst(SrcLines: HeadDS.RecLen+41: HeadDS.RecLen); 2b if %subst(line1: HeadDS.CursorPos) > *blanks; exsr srSplitLine; 2x else; exsr srMergeLine; 2e endif; %subst(SrcLines: 21) = line1; %subst(SrcLines: HeadDS.RecLen+41: HeadDS.RecLen) = line2; ReturnDS.Code = *off; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // SPLIT LINE // if position 6 is equal blanks, assume 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(line1: 6: 1) = *blanks; //assume free //find 1st character on top statement to //line up split code xx = %check(' ': line1: 7); 2b if xx = 0; xx = 8; 2e endif; 1x else; //not free xx = HeadDS.CursorPos; 1e endif; line2 = *blanks; %subst(line2: xx) = %subst(line1: HeadDS.CursorPos); 1b if HeadDS.CursorPos = 1; line1 = *blanks; 1x else; line1 = %subst(line1: 1: HeadDS.CursorPos - 1); 1e endif; ReturnDS.Rec = 2; endsr; //--------------------------------------------------------- // Merge line at cursor //--------------------------------------------------------- begsr srMergeLine; %subst(line1: HeadDS.CursorPos) = %triml(line2); 1b if HeadDS.CursorPos = 1; line2 = *blanks; 1x else; line2 = %subst(line2: %len(line2) - (HeadDS.CursorPos - 2)); 1e endif; ReturnDS.Rec = 1; 1b if line2 > *blanks; ReturnDS.Rec = 2; 1e endif; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('JCR Games Selection Menu') ]]> */ /*--------------------------------------------------------------------------*/ PGM DCLF FILE(JCRGAMESD) MONMSG MSGID(CPF0000) CHGVAR VAR(&SCLIN) VALUE(02) CHGVAR VAR(&SCPOS) VALUE(04) DOUNTIL COND('0') SNDRCVF RCDFMT(SCREEN) 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(JCRGMTIC)) WHEN COND(&SCOPTION = '7') THEN(CALL PGM(JCRGMYAT)) WHEN COND(&SCOPTION = '8') THEN(CALL PGM(JCRGMMINE)) OTHERWISE ENDSELECT ENDDO ENDPGM ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT CA03(03) CA12(12) A R SCREEN OVERLAY A BLINK 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' COLOR(BLU) A 1 24DATE EDTCDE(Y) COLOR(BLU) A 2 24SYSNAME 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. Tic/Tac/Toe' A 9 2'7. Yahtzee' A 10 2'8. 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) ]]> .*-------------------------------------------------------------------- :P.Pop-up window to select educational games program.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // 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 ControlStatements /define FieldsArry /define FieldsAttrDS /define f_IsValidMbr /define Constants /define f_GetQual /define f_RunCmd /define f_Qusrmbrd /define f_BlankCommentsCL /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGETCLPF disk(132) usropn; dcl-ds inputDS len(132); iAmp char(1) pos(2); iFieldName char(11) samepos(iAmp); iDeclaredVar char(18) samepos(iAmp); iSourceCode char(100) pos(10); iEndOfXref char(43) pos(34); iDataType char(1) pos(43); iEndOfSource char(25) pos(44); iFieldLength char(5) pos(58); iFieldDecimals char(1) pos(64); end-ds; dcl-s xx uns(10); dcl-s CountClParms uns(10); dcl-s ArryOfClParms char(11) dim(500); dcl-s IsLookForSeverity ind; dcl-s IsFoundVar ind; dcl-s IsPGM ind; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcFilQual char(20); p_SrcMbr char(10); p_DiagSeverity char(2); end-pi; //--------------------------------------------------------- // generate diagnostic listing and copy to data file p_DiagSeverity = '00'; FieldsArryCnt = 0; 1b if f_IsValidMbr('JCRGETCLPF' + 'QTEMP'); f_RunCmd('CLRPFM QTEMP/JCRGETCLPF'); 1x else; f_RunCmd('CRTPF FILE(QTEMP/JCRGETCLPF) RCDLEN(132)'); 1e endif; f_RunCmd('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)'); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); 1b if QusrmbrdDS.MbrType = 'CLP'; f_RunCmd('CRTCLPGM PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*SOURCE *XREF *NOGEN)'); 1x else; f_RunCmd('CRTBNDCL PGM(QTEMP/' + p_SrcMbr + ') SRCFILE(' + f_GetQual(p_SrcFilQual) + ') OPTION(*XREF) OUTPUT(*PRINT)'); f_RunCmd('DLTPGM PGM(QTEMP/' + p_SrcMbr + ')'); 1e endif; f_RunCmd('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETCLPF) SPLNBR(*LAST)'); f_RunCmd('DLTOVR FILE(' + p_SrcMbr + ')'); //--------------------------------------------------------- // read listing aa = 0; cc = 0; CountClParms = 0; open JCRGETCLPF; read JCRGETCLPF inputDS; 1b dow not %eof; %subst(iSourceCode:95) = *blanks; iSourceCode = f_BlankCommentsCL(iSourceCode); iSourceCode = %upper(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 inputDS; 1e enddo; 1b if CountClParms = 0; *inlr = *on; return; 1e endif; 1b dou iDeclaredVar = 'Declared Variables'; read JCRGETCLPF inputDS; 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 inputDS; 2b if iAmp = '&'; // only extract parm fields xx = %lookup(iFieldName: ArryOfClParms: 1: CountClParms); 3b if xx > 0; FieldsArryCnt += 1; FieldsArry(xx).Name = iFieldName; clear FieldsAttrDS; FieldsAttrDS.DataType = iDataType; FieldsAttrDS.Length = %uns(iFieldLength); evalr FieldsAttrDS.DecimalPos = ' ' + iFieldDecimals; FieldsArry(xx).Attr = FieldsAttrDS; 3e endif; 2e endif; 1e enddo; close JCRGETCLPF; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRGETFILR - Record format/file xref for RPG source (Fspec or dcl-f) // this program does the dirty work of extracting information from // F or dcl-f specs. // Called from jcrrfilr (show files in source) // jcrhfdr (convert f specs to free). // jcranzov (verify printer declaration in source) // jcrfsetr (file set where used) // Return string array with one element per file, with // associated F spec keywords in that single string // Note: I cannot comprehend why ibm decided to require a // usage(*delete) keyword if the file or any record format in that // file has a delete opcode in the main or any F definitions // inside any dcl-proc. This massively complicates the F specs // as now the entire source must be read looking for delete // opcodes by file or included record formats and keep track // is the delete in the main or in a procedure (and track the procedure name) //--------------------------------------------------------- /define ControlStatements /define f_GetQual /define Constants /define f_EllipsisLoc /define f_IsIgnoreLine /define f_IsCompileTimeArray /define f_ReturnZeroIfBetweenQuotes /define f_ReturnZeroIfAfterComments /define ApiErrDS /define Qdbrtvfd /define BitMask /define f_Quscrtus /define f_Qusrobjd /define FspecDS /define p_JCRGETFILR /COPY JCRCMDS,JCRCMDSCPY dcl-f RPGSRC disk(112) extfile(extIfile) extmbr(p_SrcMbr) usropn; dcl-s LowRec like(InputDS.Src74); dcl-s Semi uns(3); dcl-s SlashSlash uns(3); dcl-s IsDclf ind inz(*off); dcl-s ContinuationString varchar(1024); dcl-s SemiColonIsFound ind; dcl-s UpSpec char(1); dcl-s string varchar(94); dcl-s Dots uns(3); dcl-s dxname char(74); dcl-s xx uns(3); dcl-s DeleteCnt uns(5); dcl-s char74 char(74); dcl-s canidate char(10); dcl-s FormatIncludeOrIgnore char(10) dim(32); dcl-s CountIncExc uns(3); dcl-s CountRename uns(3); dcl-s FileNameSave char(10); dcl-s FileHowUsed char(1); dcl-s FileAddition char(1); dcl-s RenamedFmt char(10) dim(32); dcl-s BeingRenamed char(10) dim(32); dcl-s WorkFileQual char(20); dcl-s NextRename uns(5); dcl-s ff uns(5); dcl-s EndParenthesis uns(5); dcl-s CurrentColon uns(5); dcl-s OnePerCnt uns(5); dcl-s IsFile ind; dcl-s IsProcess ind; dcl-s IsIgnore ind; dcl-s IsInclude ind; dcl-s IsCloseParenth ind; dcl-s IsLF ind; dcl-s FileExt char(10); dcl-s LibExt char(10); dcl-s RenameSave char(10); dcl-s QuoteStart uns(3); dcl-s QuoteEnd uns(3); dcl-s fstring varchar(512); dcl-s ThisFileName char(10); dcl-s ThisFileProc char(74); dcl-s IsFoundInThisProc ind; dcl-s ccu like(cc); dcl-ds DeleteStatements dim(1000) qualified; PrName char(74); FileOrRcdFmt char(14); end-ds; // capture fspec comments for dcl-f conversion program dcl-ds InputDS len(112) qualified; CompileArry char(3) pos(13); SpecType char(1) pos(18); FileName char(10) pos(19); Asterisk char(1) samepos(FileName); Src74 char(74) samepos(FileName); OpCode char(6) pos(38); Factor2 char(14) pos(48); fKeyWord char(37) pos(56); Comment char(20) pos(93); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_FileCount uns(5); p_OnePerRcdFmt like(OnePerRcdFmt) dim(256); // JCRRFILR p_FspecArry like(FspecArry) dim(256); // JCRHFDR & JCRANZOV p_CommentArry like(CommentArry) dim(256); // JCRHFDR 1 to 1 with FspecArry p_PrNameArry like(PrNameArry) dim(256); // JCRHFDR 1 to 1 with FspecArry p_DeleteArry like(DeleteArry) dim(256); // JCRHFDR 1 to 1 with FspecArry end-pi; //--------------------------------------------------------- p_FileCount = 0; clear p_OnePerRcdFmt; p_FspecArry(*) = *blanks; p_CommentArry(*) = *blanks; p_PrNameArry(*) = *blanks; p_DeleteArry(*) = *blanks; DeleteStatements(*) = *blanks; clear OnePerRcdFmt; Fild0100ptr = %alloc(1); // so realloc will work extIfile = f_GetQual(p_SrcFilQual); open RPGSRC; read RPGSRC InputDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(InputDS.CompileArry); 1v leave; 2e endif; string = %trimr(InputDS.Src74); 2b if not f_IsIgnoreLine(string); exsr srProcessSource; 2e endif; read RPGSRC InputDS; 1e enddo; close RPGSRC; exsr srLoadOnePerRcdfmt; dealloc(n) Fild0100ptr; exsr srMarryUpDeletes; p_OnePerRcdFmt(*) = OnePerRcdFmt(*); *inlr = *on; return; //--------------------------------------------------------- // OnePerRcdFmt - has file/rcdfmt/renamed rcdfmts and procedure name // p_FspecArry - has file name and element # is control // p_PrNameArry - 1 to 1 with FspecArry - this element# is in this proc. // p_DeleteArry - 1 to 1 with FspecArry - record 'Y' if delete is found // DeleteStatements dim(1000) qualified; - // PrName char(74); // FileOrRcdFmt char(14); // // Spin through and figure what gets deleted where. // // watch out for a procedure deleting a file or record format that could be // defined in main or defined in a procedure. //--------------------------------------------------------- begsr srMarryUpDeletes; 1b for ff = 1 to p_FileCount; FspecDS = %upper(p_FspecArry(ff)); // no free format for primary, secondary, table. 2b if FspecDS.FileType = 'U' and FspecDS.Designation in %list(' ':'F') and FspecDS.RecordAddressType in %list(' ':'A':'K'); ThisFileName = FspecDS.name; ThisFileProc = p_PrNameArry(ff); exsr srSpinCycle; 2e endif; 1e endfor; //--------------------------------------------------------- // now to check if any procedures have a delete statement // and that file or record format is not defined in that procedure. // need to update the p_DeleteArry for the main defined files. // The usage delete keyword is a pain. //--------------------------------------------------------- // spin through all procedure delete statements 1b for bb = 1 to DeleteCnt; 2b if DeleteStatements(bb).PrName > *blanks; ThisFileProc = DeleteStatements(bb).PrName; IsFoundInThisProc = *off; 3b for aa = 1 to OnePerCnt; 4b if OnePerRcdFmt(aa).ProcName = ThisFileProc; 5b if f_IsFoundInThisProc(); IsFoundInThisProc = *on; 3v leave; 5e endif; 4e endif; 3e endfor; //---------------------------------------------------- // now go find the main procedure file definition //---------------------------------------------------- 3b if not IsFoundInThisProc; 4b for aa = 1 to OnePerCnt; 5b if OnePerRcdFmt(aa).ProcName = *blanks; 6b if f_IsFoundInThisProc(); 7b for ff = 1 to p_FileCount; 8b if p_PrNameArry(ff) = *blanks; FspecDS = %upper(p_FspecArry(ff)); 9b if FspecDS.name = OnePerRcdFmt(aa).file; p_DeleteArry(ff) = 'Y'; 7v leave; 9e endif; 8e endif; 7e endfor; 6e endif; 5e endif; 4e endfor; 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // spin through the record formats for this procedure file //--------------------------------------------------------- begsr srSpinCycle; 1b for aa = 1 to OnePerCnt; 2b if OnePerRcdFmt(aa).File = ThisFileName and OnePerRcdFmt(aa).ProcName = ThisFileProc; // spin through the delete statements in this proc 3b for bb = 1 to DeleteCnt; 4b if DeleteStatements(bb).PrName = ThisFileProc; 5b if f_IsFoundInThisProc(); p_DeleteArry(ff) = 'Y'; LV leavesr; 5e endif; 4e endif; 3e endfor; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srLoadOnePerRcdfmt; 1b for ff = 1 to p_FileCount; fstring = %trimr(p_FspecArry(ff)); fstring = %upper(fstring); //--------------------------------------------------------- // load fields from f spec externally described fields. //--------------------------------------------------------- FileExt = *blanks; LibExt = '*LIBL'; CountRename = 0; FormatIncludeOrIgnore(*) = *blanks; CountIncExc = 0; IsIgnore = *off; IsInclude = *off; RenamedFmt(*) = *blanks; BeingRenamed(*) = *blanks; //--------------------------------------------------------- IsFile = *off; 2b if %subst(fstring:1:1) > *blanks; // fixed column 3b if %subst(fstring:16:1) = 'E' and %subst(fstring:30:4) = 'DISK'; FileNameSave = %subst(fstring:1:10); FileHowUsed = %subst(fstring:11:1); FileAddition = %subst(fstring:14:1); IsFile = *on; 3e endif; 2x else; //--------------------------------------------------------------------- // extract file name from dcl-f string // make sure DCL-F is first thing in the string; //--------------------------------------------------------------------- cc = %scan('DCL-F': fstring); 3b if cc> 0 and cc = %check(' ': fstring); FileNameSave = *blanks; FileHowUsed = 'I'; // default FileAddition = *blanks; // first non-blank is start of file name cc = %check(' ': fstring: cc + 5); 4b for bb = cc to %len(fstring); 5b if %subst(fstring:bb:1) in %list(' ': ';'); FileNameSave = %subst(fstring: cc: bb-cc); 4v leave; 5e endif; 4e endfor; 4b if %subst(fstring:bb:1) = ';'; IsFile = *on; 4x else; // check for printer or workstn and skip these 5b if %scan('WORKSTN': fstring: bb) = 0 and %scan('PRINTER': fstring: bb) = 0; IsFile = *on; 5e endif; 4e endif; // get first usage 4b if IsFile; cc = %scan('USAGE(': fstring); 5b if cc > 0; cc = %scan('*':fstring: cc + 6); 6b if cc>0; FileHowUsed = %subst(fstring:cc+1:1); ccu = cc; // save for update scan FileAddition = *blanks; cc = %scan('*OUTPUT':fstring: cc + 6); 7b if cc>0; FileAddition = 'A'; 7e endif; cc = %scan('*UPDATE':fstring: ccu + 6); 7b if cc>0; FileHowUsed = 'U'; 7e endif; 6e endif; 5e endif; 4e endif; 3e endif; 2e endif; 2b if IsFile; exsr srLoadExtFile; exsr srLoadRenamed; exsr srLoadIncludeOrIgnore; exsr srLoadFileData; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srProcessSource; UpSpec = %upper(InputDS.SpecType); // get delete statements as they roll by 1b if UpSpec = 'C' and %upper(InputDS.OpCode) = 'DELETE'; DeleteCnt += 1; DeleteStatements(DeleteCnt).PrName = dxname; DeleteStatements(DeleteCnt).FileOrRcdfmt = %upper(InputDS.Factor2); // get procedure names as they roll by 1x elseif UpSpec = 'P' and InputDS.FileName > *blanks; //---------------------------------------- // Deal with ... to extract field name //---------------------------------------- Dots = f_EllipsisLoc(InputDS.Src74); 2b if Dots = 0; dxname = %trim(%subst(InputDS.Src74:1:15)); 2x else; dxname = %trim(%subst(InputDS.Src74:1:Dots-1)); 2e endif; dxname = %upper(dxname); 1x elseif InputDS.SpecType = *blanks and InputDS.Asterisk = *blanks; string = %upper(string); xx = %scan('DCL-PROC':string); 2b if xx > 0 and f_ReturnZeroIfBetweenQuotes(xx:String) > 0 and f_ReturnZeroIfAfterComments(xx:String) > 0; char74 = string; Dots = f_EllipsisLoc(char74); 3b if Dots = 0; aa = %scan(';':string); dxname = %trimr(%subst(char74:xx + 9:aa-(xx+9))); 3x else; dxname = %trim(%subst(char74:xx+9:Dots-1)); 3e endif; 2x else; canidate = f_GetFreeDeleteName(Inputds.Src74); 3b if canidate > *blanks; DeleteCnt += 1; DeleteStatements(DeleteCnt).PrName = dxname; DeleteStatements(DeleteCnt).FileOrRcdfmt = Canidate; 3e endif; 2e endif; 1e endif; //----------------------------------------------- // since v6r1 allows files in the procedures, must read entire source //----------------------------------------------- 1b if f_StartNewFspec; p_FileCount += 1; //-------------------------------------------------------- // if dcl then move the comments out to the comment field // so calling programs will know where comment ends //-------------------------------------------------------- 2b if IsDclf and SlashSlash > 0; InputDS.Comment = %subst(InputDS.Src74:SlashSlash) + InputDS.Comment; %subst(InputDS.Src74:SlashSlash) = *blanks; 2e endif; p_FspecArry(p_FileCount) = InputDS.Src74; p_CommentArry(p_FileCount) = InputDS.Comment; p_PrNameArry(p_FileCount) = dxname; //----------------------------------------------------- // now spin through until all keywords are loaded //----------------------------------------------------- // -- free format read until find ending ; 2b if IsDclf; Semi = %scan(';':InputDS.Src74); 3b if Semi = 0 or (SlashSlash > 0 and Semi > SlashSlash); // ; exsr srLoadFreeKeywords; 3e endif; 2x else; //----------------------------------------------------- // -- fixed column read until find next File start spec //----------------------------------------------------- exsr srLoadFixedKeywords; 2e endif; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srLoadFreeKeywords; // read and load until semi colon is found // drop comments from all lines by dcl-f line. SemiColonIsFound = *off; %len(ContinuationString) = 0; 1b dou SemiColonIsFound; read RPGSRC InputDS; 2b if %eof; LV leavesr; 2e endif; 2b if not f_IsComment; 3b if SlashSlash > 0; %subst(InputDS.Src74:SlashSlash) = *blanks; 3e endif; ContinuationString += ' ' + %trim(InputDS.Src74); 2e endif; Semi = %scan(';':InputDS.Src74); 2b if (Semi > 0 and (SlashSlash = 0 or Semi < SlashSlash)); p_FspecArry(p_FileCount) = %trimr(p_FspecArry(p_FileCount)) + ' ' + ContinuationString; p_PrNameArry(p_FileCount) = dxname; SemiColonIsFound = *on; 2e endif; 1e enddo; endsr; //--------------------------------------------------------- //FFile is e k disk rename( //F xxx010r:r) //F include(xxx010r //F :xxx010t) // could be a legitimate // include/Ignore of multiple record formats that goes across multiple source // lines. Load data from however many records into a single string. //--------------------------------------------------------- begsr srLoadFixedKeywords; %len(ContinuationString) = 0; 1b dow *on; read RPGSRC InputDS; 2b if %eof; 1v leave; 2e endif; 2b if not f_IsComment; 3b if f_StartNewFspec or not(%upper(InputDS.SpecType) = 'F'); readp RPGSRC InputDS; 1v leave; 3e endif; 3b if %upper(InputDS.SpecType)='F' and InputDS.fKeyWord > *blanks; ContinuationString += ' ' + %trim(InputDS.fKeyWord); 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- // Cram everything together but do not // crowd out the spaces at end of device 'DISK ' //--------------------------------------------------------- 1b if %len(%trimr(p_FspecArry(p_FileCount))) <= 36; %subst(p_FspecArry(p_FileCount): 37) = ContinuationString; 1x else; // now start cramming p_FspecArry(p_FileCount) = %trimr(p_FspecArry(p_FileCount)) + ' ' + ContinuationString; 1e endif; endsr; //--------------------------------------------------------- // extract extfile( or extdesc( values // 1) Ignore extfile(*extdesc), will get those looking for extdesc( // 2) only process extfile(' with a tic mark after the (. // 3) extract library name (if given) and file name. //--------------------------------------------------------- begsr srLoadExtFile; bb = %scan('EXTFILE(': fstring); 1b if bb > 0; 2b if %subst(fstring: bb+8: 1) = qs; exsr srExtractExtFileandLib; 2e endif; 1e endif; bb = %scan('EXTDESC(': fstring); 1b if bb > 0; 2b if %subst(fstring: bb+8: 1) = qs; exsr srExtractExtFileandLib; 2e endif; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srExtractExtFileandLib; FileExt = *blanks; LibExt = '*LIBL'; QuoteStart = bb+8; QuoteEnd = %scan(qs: fstring: QuoteStart + 1); 1b monitor; /IF DEFINED(*V7R3M0) bb = %scan('/': fstring: QuoteStart + 1: QuoteEnd-QuoteStart); /ELSE bb = %scan('/': fstring: QuoteStart + 1); /ENDIF 1x on-error; bb=0; 1e endmon; 1b if bb = 0; // no library FileExt = %subst(fstring: QuoteStart + 1: (QuoteEnd-QuoteStart)-1); 1x else; LibExt = %subst(fstring: QuoteStart+1: (bb-QuoteStart)-1); FileExt = %subst(fstring: bb + 1: (QuoteEnd-bb)-1); 2b if LibExt = 'QTEMP'; LibExt = '*LIBL'; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // extract RENAME values // find rename( or rename Xspaces ( // rename (a : b) is valid as rename(a:b) //--------------------------------------------------------- begsr srLoadRenamed; NextRename = 0; // compress out spaces 1b dou aa = 0; fstring = %scanrpl('RENAME ':'RENAME':fstring); aa = %scan('RENAME ': fstring); 1e enddo; 1b dow *on; NextRename = %scan('RENAME(': fstring: NextRename + 1); 2b if NextRename = 0; 1v leave; 2e endif; CountRename += 1; aa = %scan(':': fstring: NextRename); BeingRenamed(CountRename) = %triml(%subst(fstring: NextRename + 7: aa - (NextRename + 7))); bb = %scan(')': fstring: aa); RenamedFmt(CountRename) = %triml(%subst(fstring: aa + 1: (bb - aa) - 1)); 1e enddo; endsr; //--------------------------------------------------------- // Check IGNORED record formats in this file. // Multiple formats could be in one statement separated by : . // Extract all formats that are included/ignored and return // them in array of record formats. //--------------------------------------------------------- begsr srLoadIncludeOrIgnore; 1b if %scan('IGNORE(': fstring) > 0; IsIgnore = *on; 1x elseif %scan('INCLUDE(': fstring) > 0; IsInclude = *on; 1e endif; //--------------------------------------------------------- // Could rename(a:b) ignore(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(': fstring) > 0 or %scan('INCLUDE(': fstring) > 0; 2b if IsIgnore; cc = %scan('IGNORE(': fstring); 3b dow cc > 0; cc += 7; exsr srExtractNames; cc = %scan('IGNORE(': fstring: cc); 3e enddo; 2e endif; 2b if IsInclude; cc = %scan('INCLUDE(': fstring); 3b dow cc > 0; cc += 8; exsr srExtractNames; cc = %scan('INCLUDE(': fstring: cc+1); 3e enddo; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // So look for end parenthesis, process between parenthesis, then check for more //--------------------------------------------------------- begsr srExtractNames; EndParenthesis = %scan(')': fstring: cc); //---------------------------------------------- // cc = after ( of ignore( or include(. // Only process this keyword to ) //---------------------------------------------- CurrentColon = cc; CurrentColon = %scan(':': fstring: CurrentColon + 1); 1b if CurrentColon = 0 or CurrentColon > EndParenthesis; //(singlename) CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(fstring: cc: EndParenthesis - cc)); 1x else; // tiptoe through the colon(s) (a :b:c) etc... 2b dou CurrentColon = 0 or CurrentColon > EndParenthesis; CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(fstring: cc: CurrentColon - cc)); cc = CurrentColon + 1; CurrentColon = %scan(':': fstring: cc); 3b if CurrentColon = 0 or CurrentColon > EndParenthesis; CountIncExc += 1; FormatIncludeOrIgnore(CountIncExc) = %triml(%subst(fstring: cc: EndParenthesis - cc)); 2v leave; 3e endif; 2e enddo; 1e endif; endsr; //--------------------------------------------------------- // load fields from files begsr srLoadFileData; 1b if FileExt > *blanks; WorkFileQual = FileExt + LibExt; 1x else; WorkFileQual = FileNameSave + LibExt; 1e endif; AllocatedSize = f_GetAllocatedSize(WorkFileQual: '*FIRST'); 1b if ApiErrDS.BytesReturned > 0; OnePerCnt += 1; OnePerRcdFmt(OnePerCnt).File = FileNameSave; OnePerRcdFmt(OnePerCnt).FileExt = FileExt; OnePerRcdFmt(OnePerCnt).Lib = *all'*'; OnePerRcdFmt(OnePerCnt).Format = *all'*'; OnePerRcdFmt(OnePerCnt).FormatReName = *all'*'; OnePerRcdFmt(OnePerCnt).BasedOnPF = '*NOT FOUND'; OnePerRcdFmt(OnePerCnt).Usage = *blanks; OnePerRcdFmt(OnePerCnt).FileAddition = *blanks; OnePerRcdFmt(OnePerCnt).Text = '*FILE NOT FOUND'; OnePerRcdFmt(OnePerCnt).ProcName = p_PrNameArry(ff); OnePerRcdFmt(OnePerCnt).FileCount = ff; 1x else; Fild0100ptr = %realloc(Fild0100ptr: AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': WorkFileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; IsLF = (%bitand(bit2: Fild0100ds.TypeBits) = bit2); //--------------------------------------------------------- // 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; OnePerCnt += 1; OnePerRcdFmt(OnePerCnt).File = FileNameSave; OnePerRcdFmt(OnePerCnt).FileExt = FileExt; OnePerRcdFmt(OnePerCnt).Lib = %subst(ReturnFileQual: 11: 10); OnePerRcdFmt(OnePerCnt).Format = FileScopeArry.RcdFmt; OnePerRcdFmt(OnePerCnt).FormatReName = RenameSave; OnePerRcdFmt(OnePerCnt).Usage = FileHowUsed; OnePerRcdFmt(OnePerCnt).FileAddition = FileAddition; OnePerRcdFmt(OnePerCnt).ProcName = p_PrNameArry(ff); OnePerRcdFmt(OnePerCnt).FileCount = ff; 4b if IsLF; OnePerRcdFmt(OnePerCnt).BasedOnPF = FileScopeArry.BasedOnPf; QusrObjDS = f_QUSROBJD(FileScopeArry.BasedOnPf + FileScopeArry.BasedOnPfLib: '*FILE'); OnePerRcdFmt(OnePerCnt).Text = QusrObjDS.Text; 4x else; OnePerRcdFmt(OnePerCnt).BasedOnPF = *blanks; OnePerRcdFmt(OnePerCnt).Text = Fild0100ds.FileText; 4e endif; 3e endif; fscopePtr += 160; 2e endfor; 1e endif; endsr; //---------------------------------------------------------- //---------------------------------------------------------- dcl-proc f_IsFoundInThisProc; dcl-pi *n ind end-pi; 1b if OnePerRcdFmt(aa).FormatReName > *blanks and OnePerRcdFmt(aa).FormatReName = DeleteStatements(bb).FileOrRcdFmt; return *on; 1x elseif OnePerRcdFmt(aa).Format > *blanks and OnePerRcdFmt(aa).Format = DeleteStatements(bb).FileOrRcdFmt; return *on; 1x elseif OnePerRcdFmt(aa).File = DeleteStatements(bb).FileOrRcdFmt; return *on; 1e endif; return *off; end-proc; //---------------------------------------------------------- //---------------------------------------------------------- // return on if start of new File spec dcl-proc f_StartNewFspec; dcl-pi *n ind; end-pi; IsDclf = *off; 1b if f_IsComment; return *off; 1x elseif ((InputDS.SpecType = 'F' or InputDS.SpecType = 'f') and InputDS.FileName > *blanks); return *on; 1x else; LowRec = %lower(InputDS.Src74); IsDclf = (%scan('dcl-f': LowRec) > 0); 2b if IsDclf; return *on; 2e endif; 1e endif; return *off; end-proc; //----------------------------------------------------------- // return on if is a comment line dcl-proc f_IsComment; dcl-pi *n ind; end-pi; dcl-s FirstCharacter uns(3); 1b if (InputDS.Asterisk = '*' or InputDS.Asterisk = '/'); return *on; 1e endif; SlashSlash = %scan('//': InputDS.Src74); FirstCharacter = %check (' ': InputDS.Src74); 1b if SlashSlash = FirstCharacter; return *on; 1e endif; return *off; end-proc; //------------------------------ // return file or record format name for delete opcode // delete name; // delete(e) name ; // delete (key:key2) name ; // delete key name ; // // Find the ; and then back up to the beginning of the name. //- // if someone wants to write a multi-line extraction // delete // a // name; // please send me the code. //------------------------------ dcl-proc f_GetFreeDeleteName; dcl-pi *n char(14); pstring char(74); end-pi; dcl-s canidate char(14); dcl-s EndPos uns(3); dcl-s bb uns(3); dcl-s StartPos uns(3); dcl-s NameStart uns(3); dcl-s NameEnd uns(3); dcl-s AfterCommentCheck varchar(94); dcl-s string char(74); string = %upper( pstring); canidate = *blanks; StartPos = %scan(' DELETE':string:1); 1b if StartPos > 0; AfterCommentCheck = %trimr(string); StartPos = f_ReturnZeroIfAfterComments(StartPos: AfterCommentCheck); 2b if StartPos > 0; StartPos = f_ReturnZeroIfBetweenQuotes(StartPos: AfterCommentCheck); 2e endif; 2b if StartPos > 0; // now get end of the line pos EndPos = %scan(';':string:StartPos+1); 3b if EndPos > 0; //------------------------------------------------- NameStart = 0; NameEnd = 0; 4b for bb = (EndPos - 1) downto (StartPos + 6); 5b if NameEnd = 0 and %subst(string:bb:1) > ' '; NameEnd = bb; 5e endif; 5b if NameEnd > 0 and %subst(string:bb:1) = ' '; NameStart = bb + 1; 4v leave; 5e endif; 4e endfor; 4b if NameStart > 0 and NameEnd > 0 and NameEnd >= NameStart; canidate = %subst(string: NameStart: NameEnd - NameStart + 1); 4e endif; return canidate; 3e endif; 2e endif; 1e endif; return *blanks; end-proc; ]]> '); //--------------------------------------------------------- // 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 ControlStatements /define FieldsArry /define FieldsAttrDS /define f_IsValidMbr /define f_GetQual /define f_RunCmd /define f_Qusrmbrd /define f_BuildString /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGETFLDF disk(132) usropn; dcl-ds inputDS len(132); iNotReferenced char(1) pos(1); iCheckComplete char(20) pos(1); iCheckCompleteSql char(20) pos(4); iMsgSummary char(7) pos(2); iEqual char(1) pos(7); iGlobalRef char(24) pos(7); iFileType char(1) pos(8); iExternalForma char(30) pos(9); iDFieldName char(10) pos(10); iFldShort char(17) pos(10); iFldLong char(123) pos(10); iOFieldName char(10) pos(32); iGlobAttr1 char(1) pos(28); iGlobAttr3 char(3) pos(27); iGlobLen char(17) pos(29); iFSname char(92) pos(41); iReference char(31) pos(50); iIFieldName char(15) pos(51); iDiagSeverity char(2) pos(31); iDiagSeveritySql char(2) pos(1); iFieldText char(39) pos(83); iFileSeq char(3) pos(122); end-ds; dcl-s aa uns(10); dcl-s readcount uns(10); dcl-s xx uns(10); dcl-s ii uns(10); dcl-s xOpen uns(3); dcl-s xComma uns(3); dcl-s xAster uns(3); dcl-s xClose uns(3); dcl-s FileNameArry char(10) dim(12767); dcl-s FileFldsArry char(15) dim(12767); dcl-s FileFldTxtArry dim(12767) like(ifieldtext); dcl-s FileName char(10); dcl-s FileSeq char(3); dcl-s IsGlobalRef ind inz(*off); dcl-s SavName char(100); dcl-s SavProcName char(100); dcl-s SavQualified char(100); dcl-s SavDim char(15); dcl-s IsUnReferenced ind; dcl-s IsQualified ind; dcl-s IsLookForSeverity ind; dcl-s IsServicePgm ind; dcl-s char8 char(8); //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcFilQual char(20); p_SrcMbr char(10); p_DiagSeverity char(2); p_PepCnt packed(3); end-pi; p_PepCnt = 0; //--------------------------------------------------------- // generate diagnostic listing and copy to data file //--------------------------------------------------------- p_DiagSeverity = '00'; 1b if f_IsValidMbr('JCRGETFLDF' + 'QTEMP'); f_RunCmd('CLRPFM QTEMP/JCRGETFLDF'); 1x else; f_RunCmd('CRTPF FILE(QTEMP/JCRGETFLDF) RCDLEN(132) SIZE(*NOMAX)'); 1e endif; f_RunCmd('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)'); QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); 1b if QusrmbrdDS.MbrType = 'SQLRPGLE'; f_RunCmd(f_BuildString('+ CRTSQLRPGI OBJ(QTEMP/&) SRCFILE(&) OPTION(*NOXREF *GEN) + OUTPUT(*PRINT) COMPILEOPT(&QDFTACTGRP(*NO)&Q)': p_SrcMbr: f_GetQual(p_SrcFilQual))); f_RunCmd('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); 1x else; //--------------------------------------------------------- // weird. the compiler list will not show the pep unless *GEN the program //--------------------------------------------------------- f_RunCmd(f_BuildString('+ CRTBNDRPG PGM(QTEMP/&) SRCFILE(&) + OPTION(*XREF *NOSECLVL *SHOWCPY *EXPDDS + *NOEXT *NOSHOWSKP *NOSRCSTMT *NOEVENTF) DFTACTGRP(*NO)': p_SrcMbr: f_GetQual(p_SrcFilQual))); 1e endif; f_RunCmd('CPYSPLF FILE(' + p_SrcMbr + ') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)'); f_RunCmd('DLTOVR FILE(' + p_SrcMbr + ')'); f_RunCmd('DLTPGM PGM(QTEMP/' + p_SrcMbr+')'); //--------------------------------------------------------- // read listing open JCRGETFLDF; read JCRGETFLDF inputDS; readCount += 1; 1b dow not %eof; 2b if iGlobLen = 'ASED(_QRNL_PRM+)'; p_PepCnt += 1; 2e endif; 2b if iGlobalRef = 'Indicator References:'; IsLookForSeverity = *on; 2e endif; 2b if not IsLookForSeverity; 3b if IsGlobalRef; exsr srGlobalDefinitions; 3x else; exsr srFileFieldDefinitions; 3e endif; 3b if iGlobalRef = 'Global Field References:'; IsGlobalRef = *on; 3e endif; 2e endif; 2b if IMsgSummary = 'RNF1304'; IsServicePgm = *on; 2e endif; 2b if not IsServicePgm; 3b if iCheckComplete = 'Compilation stopped.'; p_DiagSeverity = iDiagSeverity; 1v leave; 3e endif; 3b if iCheckCompleteSql = 'level severity error'; p_DiagSeverity = iDiagSeveritySql; 1v leave; 3e endif; 2e endif; read JCRGETFLDF inputDS; readCount += 1; 1e enddo; //--------------------------------------------------------- 1b if p_DiagSeverity <= '20'; f_RunCmd('DLTSPLF FILE(' + p_SrcMbr + ') SPLNBR(*LAST)'); 1e endif; 1b if ii > 1; sorta %subarr(FieldsArry(*).Name: 1: ii); 1e endif; FieldsArryCnt = ii; close JCRGETFLDF; *inlr = *on; return; //--------------------------------------------------------- // Load up all the file field sequence numbers to reference later //--------------------------------------------------------- begsr srFileFieldDefinitions; 1b if iExternalForma = '* External format . . . . . :'; aa = %scan('/':iFSname); FileName = %subst(iFSname: aa+1); FileSeq = iFileSeq; 2b dou iEqual = '='; read JCRGETFLDF inputDS; 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 in %list(' A(': ' B(': ' F(': ' G(': ' I(': ' N(': ' P(': ' S(': ' D(': ' T(': ' U(': ' Z(': ' *(': ' DS': ' 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 // FieldsArryCnt... // 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 ... is found 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 inputDS; 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 inputDS; // reposition 3v leave; 4e endif; readp JCRGETFLDF inputDS; 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 // Start in pos 50, look for first non-blank, then first blank // and check everything after that for blanks. // In above example, 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: FieldsArry(*).Name: 1: ii) = 0; ii += 1; FieldsArry(ii).Name = SavName; FieldsArry(ii).Attr = FieldsAttrDS; 3e endif; 2e endif; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRGMBLJ - Black Jack 21 //--------------------------------------------------------- /define ControlStatements /define Dspatr /define FunctionKeys /define f_GetCardFace /define f_ShuffleDeck /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMBLJD workstn infds(infds) indds(ind); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s PlayerHas uns(3); dcl-s DealerShow uns(3); dcl-s yy uns(3); dcl-s yyAlpha char(3); dcl-s Color char(1); dcl-s CardFace char(2); dcl-s DealerDownCrd char(2); dcl-s DeckArry char(2) dim(52); dcl-s hh uns(3); dcl-s Dealer uns(3) inz(1); dcl-s Player uns(3) inz(2); dcl-s Card uns(3); dcl-s row uns(3); dcl-s col uns(3); dcl-s Deal uns(3); dcl-s HandValue uns(3); dcl-s NxtCardDealt uns(3); dcl-s NxtDealerCard uns(3); dcl-s NxtPlayerCard uns(3); dcl-s IsCompleted ind; // card faces and screen field attributes 4d array dcl-ds ColumnDS qualified template; col char(1) dim(3); end-ds; dcl-ds CardDS qualified template; row dim(3) likeds(ColumnDS); end-ds; dcl-ds Hand dim(2) qualified based(ptr); Card dim(6) likeds(CardDS); end-ds; dcl-s ptr pointer inz(%addr(s0111)); //------------------------------------------------------ dcl-ds HandA dim(2) likeds(Hand) based(ptr2); dcl-s ptr2 pointer inz(%addr(s0111a)); // Card ID attributes at top and bottom of card 2d array dcl-ds CardIdA dim(2) qualified; Card char(1) dim(6); end-ds; // Card ID values 2d array dcl-ds CardId dim(2) qualified; Card char(2) dim(6); end-ds; // card outline border attributes 2d array dcl-ds BorderA dim(2) qualified based(ptr5); Card char(1) dim(6); end-ds; dcl-s ptr5 pointer inz(%addr(Border1A)); // large hand values 2d array dcl-ds Big dim(7) qualified; col char(1) dim(4); end-ds; dcl-ds BigA dim(7) likeds(Big); dcl-ds Deal10s dim(7) likeds(Big) based(ptr8); // 10s position dcl-s ptr8 pointer inz(%addr(D111)); dcl-ds Deal10sA dim(7) likeds(Big) based(ptr9); dcl-s ptr9 pointer inz(%addr(D111a)); dcl-ds Deal1s dim(7) likeds(Big) based(ptr10); // 1s position dcl-s ptr10 pointer inz(%addr(D211)); dcl-ds Deal1sA dim(7) likeds(Big) based(ptr11); dcl-s ptr11 pointer inz(%addr(D211a)); dcl-ds User10s dim(7) likeds(Big) based(ptr13); // 10s dcl-s ptr13 pointer inz(%addr(U111)); dcl-ds User10sA dim(7) likeds(Big) based(ptr14); dcl-s ptr14 pointer inz(%addr(U111a)); dcl-ds User1s dim(7) likeds(Big) based(ptr15); // 1s dcl-s ptr15 pointer inz(%addr(U211)); dcl-ds User1sA dim(7) likeds(Big) based(ptr16); dcl-s ptr16 pointer inz(%addr(U211a)); // map screen fields into DS so arrays can manipulate values dcl-ds *n inz; // card value sum d111; d112; d113; d114; d121; d122; d123; d124; d131; d132; d133; d134; d141; d142; d143; d144; d151; d152; d153; d154; d161; d162; d163; d164; d171; d172; d173; d174; d211; d212; d213; d214; d221; d222; d223; d224; d231; d232; d233; d234; d241; d242; d243; d244; d251; d252; d253; d254; d261; d262; d263; d264; d271; d272; d273; d274; d111a; d112a; d113a; d114a; d121a; d122a; d123a; d124a; d131a; d132a; d133a; d134a; d141a; d142a; d143a; d144a; d151a; d152a; d153a; d154a; d161a; d162a; d163a; d164a; d171a; d172a; d173a; d174a; d211a; d212a; d213a; d214a; d221a; d222a; d223a; d224a; d231a; d232a; d233a; d234a; d241a; d242a; d243a; d244a; d251a; d252a; d253a; d254a; d261a; d262a; d263a; d264a; d271a; d272a; d273a; d274a; u111; u112; u113; u114; u121; u122; u123; u124; u131; u132; u133; u134; u141; u142; u143; u144; u151; u152; u153; u154; u161; u162; u163; u164; u171; u172; u173; u174; u211; u212; u213; u214; u221; u222; u223; u224; u231; u232; u233; u234; u241; u242; u243; u244; u251; u252; u253; u254; u261; u262; u263; u264; u271; u272; u273; u274; u111a; u112a; u113a; u114a; u121a; u122a; u123a; u124a; u131a; u132a; u133a; u134a; u141a; u142a; u143a; u144a; u151a; u152a; u153a; u154a; u161a; u162a; u163a; u164a; u171a; u172a; u173a; u174a; u211a; u212a; u213a; u214a; u221a; u222a; u223a; u224a; u231a; u232a; u233a; u234a; u241a; u242a; u243a; u244a; u251a; u252a; u253a; u254a; u261a; u262a; u263a; u264a; u271a; u272a; u273a; u274a; Border1a; Border2a; Border3a; Border4a; Border5a; Border6a; Border7a; Border8a; Border9a; Border10a; Border11a; Border12a; // Card Faces s0111; s0112; s0113; s0121; s0122; s0123; s0131; s0132; s0133; s0211; s0212; s0213; s0221; s0222; s0223; s0231; s0232; s0233; s0311; s0312; s0313; s0321; s0322; s0323; s0331; s0332; s0333; s0411; s0412; s0413; s0421; s0422; s0423; s0431; s0432; s0433; s0511; s0512; s0513; s0521; s0522; s0523; s0531; s0532; s0533; s0611; s0612; s0613; s0621; s0622; s0623; s0631; s0632; s0633; s0711; s0712; s0713; s0721; s0722; s0723; s0731; s0732; s0733; s0811; s0812; s0813; s0821; s0822; s0823; s0831; s0832; s0833; s0911; s0912; s0913; s0921; s0922; s0923; s0931; s0932; s0933; s1011; s1012; s1013; s1021; s1022; s1023; s1031; s1032; s1033; s1111; s1112; s1113; s1121; s1122; s1123; s1131; s1132; s1133; s1211; s1212; s1213; s1221; s1222; s1223; s1231; s1232; s1233; // card face attributes s0111a; s0112a; s0113a; s0121a; s0122a; s0123a; s0131a; s0132a; s0133a; s0211a; s0212a; s0213a; s0221a; s0222a; s0223a; s0231a; s0232a; s0233a; s0311a; s0312a; s0313a; s0321a; s0322a; s0323a; s0331a; s0332a; s0333a; s0411a; s0412a; s0413a; s0421a; s0422a; s0423a; s0431a; s0432a; s0433a; s0511a; s0512a; s0513a; s0521a; s0522a; s0523a; s0531a; s0532a; s0533a; s0611a; s0612a; s0613a; s0621a; s0622a; s0623a; s0631a; s0632a; s0633a; s0711a; s0712a; s0713a; s0721a; s0722a; s0723a; s0731a; s0732a; s0733a; s0811a; s0812a; s0813a; s0821a; s0822a; s0823a; s0831a; s0832a; s0833a; s0911a; s0912a; s0913a; s0921a; s0922a; s0923a; s0931a; s0932a; s0933a; s1011a; s1012a; s1013a; s1021a; s1022a; s1023a; s1031a; s1032a; s1033a; s1111a; s1112a; s1113a; s1121a; s1122a; s1123a; s1131a; s1132a; s1133a; s1211a; s1212a; s1213a; s1221a; s1222a; s1223a; s1231a; s1232a; s1233a; end-ds; // name screen indicators dcl-ds ind qualified; IsStand ind pos(06); end-ds; dcl-ds CurrCard qualified; NumVal uns(3) inz; Suite char(1); end-ds; //--------------------------------------------------------- // Load Splash alt red-blue strips. Load BLACK JACK to 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'; scDow = f_GetDayName(); //-load card colors---------- 1b for hh = Dealer to Player; 2b for Card = 1 to 6; 3b if Card in %list(1:5); Color = %bitor(RED: RI); 3x elseif Card in %list(2: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; DealerShow = 21; PlayerHas = 21; //--------------------------------------------------------- // Play the game. 1b dow *on; 2b if DealerShow > 0; exsr srShowBigTot; 2e endif; exfmt screen; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 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; //--------------------------------------------------------- // 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 < PlayerHas; 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! PlayerMsg = '** W I N N E R **'; PlayerMsgA = %bitor(WHITE: RI); DealerMsg = '**DEALER BUSTED**'; DealerMsgA = %bitor(RED: HI: RI); hh = Player; exsr srWinnerBorderColor; credits += YouBet; Youbet = 0; 1x elseif DealerShow < PlayerHas; //Player Won PlayerMsg = '** W I N N E R **'; PlayerMsgA = %bitor(WHITE: RI); DealerMsg = *blanks; DealerMsgA = x'00'; credits += YouBet; Youbet = 0; hh = Player; exsr srWinnerBorderColor; 1x elseif DealerShow > PlayerHas; //Dealer Won DealerMsg = '** DEALER WINS **'; DealerMsgA = %bitor(WHITE: RI); PlayerMsg = *blanks; PlayerMsgA = x'00'; hh = Dealer; exsr srWinnerBorderColor; credits -= YouBet; Youbet = 0; 1x elseif DealerShow = PlayerHas; //Tie DealerMsg = '** T I E **'; DealerMsgA = %bitor(WHITE: RI); PlayerMsg = '** BET DOUBLED **'; PlayerMsgA = %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; DealerMsg = *blanks; DealerMsgA = x'00'; PlayerMsg = *blanks; PlayerMsgA = x'00'; PlayerHas = 0; DealerShow = 0; 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; PlayerHas = 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; PlayerHas = Handvalue; //--------------------------------------------------------- // 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 PlayerHas > 21; //BUSTED! PlayerMsg = '** B U S T E D **'; PlayerMsgA = %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. // Cannot accumulate values of cards as they // are 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) = 'J' or CardId(hh).Card(Card) = 'Q' or CardId(hh).Card(Card) = 'K'; HandValue += 10; 2x elseif CardId(hh).Card(Card) <> '**'; HandValue += %int(CardId(hh).Card(Card)); 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 dealer as that is the '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(*) = 'A A'; Color = %bitor(Red: RI); 1x elseif CardFace = 'K'; Hand(hh).Card(Card).Row(*) = 'K K'; Color = %bitor(Yellow: RI); 1x elseif CardFace = 'Q'; Hand(hh).Card(Card).Row(*) = 'Q Q'; Color = %bitor(White: RI); 1x elseif CardFace = 'J'; Hand(hh).Card(Card).Row(*) = 'J J'; Color = %bitor(Green: RI); 1x elseif CardFace = '10'; Hand(hh).Card(Card).Row(*) = '1 0'; Color = %bitor(Red: RI); 1x elseif CardFace = '9'; Hand(hh).Card(Card).Row(*) = '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; //--------------------------------------------------------- // 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(PlayerHas); 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; //--------------------------------------------------------- //--------------------------------------------------------- // Return 4 row X 7 column array dcl-proc f_LoadBig; dcl-pi *n char(4) dim(7); pBaseNum uns(3); end-pi; dcl-s Line char(4) dim(7); 1b if pBaseNum = 0; Line(*) = '0 0'; Line(1) = ' 00 '; Line(7) = ' 00 '; 1x elseif pBaseNum = 1; Line(*) = ' 1 '; Line(1) = ' 11 '; Line(7) = ' 111'; 1x elseif pBaseNum = 2; line = %list( '222 ': ' 2': ' 2': ' 22 ': '2 ': '2 ': '2222'); 1x elseif pBaseNum = 3; line = %list( '333 ': ' 3': ' 3': ' 333': ' 3': ' 3': '333 '); 1x elseif pBaseNum = 4; line = %list( ' 44': ' 4 4': '4 4': '4444': ' 4': ' 4': ' 4'); 1x elseif pBaseNum = 5; line = %list( '5555': '5 ': '5 ': '5555': ' 5': ' 5': '5555'); 1x elseif pBaseNum = 6; line = %list( '6666': '6 ': '6 ': '6666': '6 6': '6 6': '6666'); 1x elseif pBaseNum = 7; line = %list( '7777': ' 7': ' 7': ' 7 ': ' 7 ': '7 ': '7 '); 1x elseif pBaseNum = 8; line = %list( '8888': '8 8': '8 8': '8888': '8 8': '8 8': '8888'); 1x elseif pBaseNum = 9; line = %list( '9999': '9 9': '9 9': '9999': ' 9': ' 9': '9999'); 1e endif; return Line; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA12 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 PLAYERMSGA 1A P A 1 3'JCRGMBLJ' COLOR(BLU) A 1 14'BLACK JACK 21' A COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME 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 5 11'|' A DSPATR(&BORDER1A) A 5 13'|' A DSPATR(&BORDER2A) 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 5 49'|' A DSPATR(&BORDER3A) A 5 51'|' A DSPATR(&BORDER4A) A 5 59'|' A DSPATR(&BORDER4A) A 5 61'|' A DSPATR(&BORDER5A) A 5 69'|' A DSPATR(&BORDER5A) A 5 71'|' A DSPATR(&BORDER6A) A 5 79'|' A DSPATR(&BORDER6A) A 6 3'|' A DSPATR(&BORDER1A) A S0111 1A O 6 5DSPATR(&S0111A) A S0112 1A O 6 7DSPATR(&S0112A) A S0113 1A O 6 9DSPATR(&S0113A) A 6 11'|' A DSPATR(&BORDER1A) A 6 13'|' A DSPATR(&BORDER2A) A S0211 1A O 6 15DSPATR(&S0211A) A S0212 1A O 6 17DSPATR(&S0212A) A S0213 1A O 6 19DSPATR(&S0213A) 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 S0311 1A O 6 43DSPATR(&S0311A) A S0312 1A O 6 45DSPATR(&S0312A) A S0313 1A O 6 47DSPATR(&S0313A) A 6 49'|' A DSPATR(&BORDER3A) A 6 51'|' A DSPATR(&BORDER4A) A S0411 1A O 6 53DSPATR(&S0411A) A S0412 1A O 6 55DSPATR(&S0412A) A S0413 1A O 6 57DSPATR(&S0413A) A 6 59'|' A DSPATR(&BORDER4A) A 6 61'|' A DSPATR(&BORDER5A) A S0511 1A O 6 63DSPATR(&S0511A) A S0512 1A O 6 65DSPATR(&S0512A) A S0513 1A O 6 67DSPATR(&S0513A) A 6 69'|' A DSPATR(&BORDER5A) A 6 71'|' A DSPATR(&BORDER6A) A S0611 1A O 6 73DSPATR(&S0611A) A S0612 1A O 6 75DSPATR(&S0612A) A S0613 1A O 6 77DSPATR(&S0613A) A 6 79'|' A DSPATR(&BORDER6A) A 7 3'|' A DSPATR(&BORDER1A) A S0121 1A O 7 5DSPATR(&S0121A) A S0122 1A O 7 7DSPATR(&S0122A) A S0123 1A O 7 9DSPATR(&S0123A) A 7 11'|' A DSPATR(&BORDER1A) A 7 13'|' A DSPATR(&BORDER2A) A S0221 1A O 7 15DSPATR(&S0221A) A S0222 1A O 7 17DSPATR(&S0222A) A S0223 1A O 7 19DSPATR(&S0223A) 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 S0321 1A O 7 43DSPATR(&S0321A) A S0322 1A O 7 45DSPATR(&S0322A) A S0323 1A O 7 47DSPATR(&S0323A) A 7 49'|' A DSPATR(&BORDER3A) A 7 51'|' A DSPATR(&BORDER4A) A S0421 1A O 7 53DSPATR(&S0421A) A S0422 1A O 7 55DSPATR(&S0422A) A S0423 1A O 7 57DSPATR(&S0423A) A 7 59'|' A DSPATR(&BORDER4A) A 7 61'|' A DSPATR(&BORDER5A) A S0521 1A O 7 63DSPATR(&S0521A) A S0522 1A O 7 65DSPATR(&S0522A) A S0523 1A O 7 67DSPATR(&S0523A) A 7 69'|' A DSPATR(&BORDER5A) A 7 71'|' A DSPATR(&BORDER6A) A S0621 1A O 7 73DSPATR(&S0621A) A S0622 1A O 7 75DSPATR(&S0622A) A S0623 1A O 7 77DSPATR(&S0623A) A 7 79'|' A DSPATR(&BORDER6A) A 8 3'|' A DSPATR(&BORDER1A) A S0131 1A O 8 5DSPATR(&S0131A) A S0132 1A O 8 7DSPATR(&S0132A) A S0133 1A O 8 9DSPATR(&S0133A) A 8 11'|' A DSPATR(&BORDER1A) A 8 13'|' A DSPATR(&BORDER2A) A S0231 1A O 8 15DSPATR(&S0231A) A S0232 1A O 8 17DSPATR(&S0232A) A S0233 1A O 8 19DSPATR(&S0233A) A 8 21'|' 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 S0331 1A O 8 43DSPATR(&S0331A) A S0332 1A O 8 45DSPATR(&S0332A) A S0333 1A O 8 47DSPATR(&S0333A) A 8 49'|' A DSPATR(&BORDER3A) A 8 51'|' A DSPATR(&BORDER4A) A S0431 1A O 8 53DSPATR(&S0431A) A S0432 1A O 8 55DSPATR(&S0432A) A S0433 1A O 8 57DSPATR(&S0433A) A 8 59'|' A DSPATR(&BORDER4A) A 8 61'|' A DSPATR(&BORDER5A) A S0531 1A O 8 63DSPATR(&S0531A) A S0532 1A O 8 65DSPATR(&S0532A) A S0533 1A O 8 67DSPATR(&S0533A) A 8 69'|' A DSPATR(&BORDER5A) A 8 71'|' A DSPATR(&BORDER6A) A S0631 1A O 8 73DSPATR(&S0631A) A S0632 1A O 8 75DSPATR(&S0632A) A S0633 1A O 8 77DSPATR(&S0633A) A 8 79'|' A DSPATR(&BORDER6A) A 9 3'|_______|' A DSPATR(&BORDER1A) A 9 13'|_______|' A DSPATR(&BORDER2A) 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 9 41'|_______|' A DSPATR(&BORDER3A) A 9 51'|_______|' A DSPATR(&BORDER4A) A 9 61'|_______|' A DSPATR(&BORDER5A) A 9 71'|_______|' A DSPATR(&BORDER6A) 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 13 41' _______ ' A DSPATR(&BORDER9A) A 13 51' _______ ' A DSPATR(&BORDER10A) A 13 61' _______ ' A DSPATR(&BORDER11A) A 13 71' _______ ' A DSPATR(&BORDER12A) A 14 3'|' A DSPATR(&BORDER7A) A 14 11'|' A DSPATR(&BORDER7A) A 14 13'|' A DSPATR(&BORDER8A) 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 49'|' A DSPATR(&BORDER9A) A 14 51'|' A DSPATR(&BORDER10A) A 14 59'|' A DSPATR(&BORDER10A) A 14 61'|' A DSPATR(&BORDER11A) A 14 69'|' A DSPATR(&BORDER11A) A 14 71'|' A DSPATR(&BORDER12A) A 14 79'|' A DSPATR(&BORDER12A) A 15 3'|' A DSPATR(&BORDER7A) A S0711 1A O 15 5DSPATR(&S0711A) A S0712 1A O 15 7DSPATR(&S0712A) A S0713 1A O 15 9DSPATR(&S0713A) A 15 11'|' A DSPATR(&BORDER7A) A 15 13'|' A DSPATR(&BORDER8A) A S0811 1A O 15 15DSPATR(&S0811A) A S0812 1A O 15 17DSPATR(&S0812A) A S0813 1A O 15 19DSPATR(&S0813A) 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 S0721 1A O 16 5DSPATR(&S0721A) A S0722 1A O 16 7DSPATR(&S0722A) A S0723 1A O 16 9DSPATR(&S0723A) A 16 11'|' A DSPATR(&BORDER7A) A 16 13'|' A DSPATR(&BORDER8A) A S0821 1A O 16 15DSPATR(&S0821A) A S0822 1A O 16 17DSPATR(&S0822A) A S0823 1A O 16 19DSPATR(&S0823A) 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 S0731 1A O 17 5DSPATR(&S0731A) A S0732 1A O 17 7DSPATR(&S0732A) A S0733 1A O 17 9DSPATR(&S0733A) A 17 11'|' A DSPATR(&BORDER7A) A 17 13'|' A DSPATR(&BORDER8A) A S0831 1A O 17 15DSPATR(&S0831A) A S0832 1A O 17 17DSPATR(&S0832A) A S0833 1A O 17 19DSPATR(&S0833A) A 17 21'|' 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 18 3'|_______|' A DSPATR(&BORDER7A) A 18 13'|_______|' A DSPATR(&BORDER8A) 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 PLAYERMSG 25A O 21 20DSPATR(&PLAYERMSGA) 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) ]]> '); //--------------------------------------------------------- // JCRGMBTL - BattleShip //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Dspatr /define FunctionKeys /define QsnGetCsrAdr /define f_GetRandom /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMBTLD workstn infds(Infds); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s col uns(3); dcl-s ForCount uns(3); dcl-s HashCol uns(3) dim(51); dcl-s HashRow uns(3) dim(51); dcl-s row uns(3); dcl-s TimesHit2 uns(3); dcl-s TimesHit3 uns(3); dcl-s TimesHit4 uns(3); dcl-s TimesHit5 uns(3); dcl-s UserxHit2 uns(3); dcl-s UserxHit3 uns(3); dcl-s UserxHit4 uns(3); dcl-s UserxHit5 uns(3); dcl-s HitCol1 uns(3); dcl-s HitCol2 uns(3); dcl-s HitRow1 uns(3); dcl-s HitRow2 uns(3); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s IsCollision ind; dcl-s IsDeployed ind; dcl-s IsGoodRowCol ind; dcl-s IsHit ind; dcl-s IsHitFirst ind; dcl-s IsHitSecond ind; dcl-c Left 1; dcl-c Right 2; dcl-c Up 3; dcl-c Down 4; dcl-ds GridDS qualified template; col char(1) dim(10); end-ds; dcl-ds Deployed dim(10) likeds(GridDS); dcl-ds Attack dim(10) likeds(GridDS) based(ptr); // enemy screen fields dcl-ds AttackA dim(10) likeds(GridDS) based(ptr2); // enemy attrib array dcl-ds Defend dim(10) likeds(GridDS) based(ptr3); // defend screen fields dcl-ds DefendA dim(10) likeds(GridDS) based(ptr4); // defend attrib array dcl-ds DefendSave dim(10) likeds(GridDS); dcl-s ptr pointer inz(%addr(r01c01)); dcl-s ptr2 pointer inz(%addr(atr0101)); dcl-s ptr3 pointer inz(%addr(b01c01)); dcl-s ptr4 pointer inz(%addr(btr0101)); // map screen fields into DS so arrays can manipulate values dcl-ds *n; r01c01; r01c02; r01c03; r01c04; r01c05; r01c06; r01c07; r01c08; r01c09; r01c10; r02c01; r02c02; r02c03; r02c04; r02c05; r02c06; r02c07; r02c08; r02c09; r02c10; r03c01; r03c02; r03c03; r03c04; r03c05; r03c06; r03c07; r03c08; r03c09; r03c10; r04c01; r04c02; r04c03; r04c04; r04c05; r04c06; r04c07; r04c08; r04c09; r04c10; r05c01; r05c02; r05c03; r05c04; r05c05; r05c06; r05c07; r05c08; r05c09; r05c10; r06c01; r06c02; r06c03; r06c04; r06c05; r06c06; r06c07; r06c08; r06c09; r06c10; r07c01; r07c02; r07c03; r07c04; r07c05; r07c06; r07c07; r07c08; r07c09; r07c10; r08c01; r08c02; r08c03; r08c04; r08c05; r08c06; r08c07; r08c08; r08c09; r08c10; r09c01; r09c02; r09c03; r09c04; r09c05; r09c06; r09c07; r09c08; r09c09; r09c10; r10c01; r10c02; r10c03; r10c04; r10c05; r10c06; r10c07; r10c08; r10c09; r10c10; atr0101; atr0102; atr0103; atr0104; atr0105; atr0106; atr0107; atr0108; atr0109; atr0110; atr0201; atr0202; atr0203; atr0204; atr0205; atr0206; atr0207; atr0208; atr0209; atr0210; atr0301; atr0302; atr0303; atr0304; atr0305; atr0306; atr0307; atr0308; atr0309; atr0310; atr0401; atr0402; atr0403; atr0404; atr0405; atr0406; atr0407; atr0408; atr0409; atr0410; atr0501; atr0502; atr0503; atr0504; atr0505; atr0506; atr0507; atr0508; atr0509; atr0510; atr0601; atr0602; atr0603; atr0604; atr0605; atr0606; atr0607; atr0608; atr0609; atr0610; atr0701; atr0702; atr0703; atr0704; atr0705; atr0706; atr0707; atr0708; atr0709; atr0710; atr0801; atr0802; atr0803; atr0804; atr0805; atr0806; atr0807; atr0808; atr0809; atr0810; atr0901; atr0902; atr0903; atr0904; atr0905; atr0906; atr0907; atr0908; atr0909; atr0910; atr1001; atr1002; atr1003; atr1004; atr1005; atr1006; atr1007; atr1008; atr1009; atr1010; b01c01; b01c02; b01c03; b01c04; b01c05; b01c06; b01c07; b01c08; b01c09; b01c10; b02c01; b02c02; b02c03; b02c04; b02c05; b02c06; b02c07; b02c08; b02c09; b02c10; b03c01; b03c02; b03c03; b03c04; b03c05; b03c06; b03c07; b03c08; b03c09; b03c10; b04c01; b04c02; b04c03; b04c04; b04c05; b04c06; b04c07; b04c08; b04c09; b04c10; b05c01; b05c02; b05c03; b05c04; b05c05; b05c06; b05c07; b05c08; b05c09; b05c10; b06c01; b06c02; b06c03; b06c04; b06c05; b06c06; b06c07; b06c08; b06c09; b06c10; b07c01; b07c02; b07c03; b07c04; b07c05; b07c06; b07c07; b07c08; b07c09; b07c10; b08c01; b08c02; b08c03; b08c04; b08c05; b08c06; b08c07; b08c08; b08c09; b08c10; b09c01; b09c02; b09c03; b09c04; b09c05; b09c06; b09c07; b09c08; b09c09; b09c10; b10c01; b10c02; b10c03; b10c04; b10c05; b10c06; b10c07; b10c08; b10c09; b10c10; btr0101; btr0102; btr0103; btr0104; btr0105; btr0106; btr0107; btr0108; btr0109; btr0110; btr0201; btr0202; btr0203; btr0204; btr0205; btr0206; btr0207; btr0208; btr0209; btr0210; btr0301; btr0302; btr0303; btr0304; btr0305; btr0306; btr0307; btr0308; btr0309; btr0310; btr0401; btr0402; btr0403; btr0404; btr0405; btr0406; btr0407; btr0408; btr0409; btr0410; btr0501; btr0502; btr0503; btr0504; btr0505; btr0506; btr0507; btr0508; btr0509; btr0510; btr0601; btr0602; btr0603; btr0604; btr0605; btr0606; btr0607; btr0608; btr0609; btr0610; btr0701; btr0702; btr0703; btr0704; btr0705; btr0706; btr0707; btr0708; btr0709; btr0710; btr0801; btr0802; btr0803; btr0804; btr0805; btr0806; btr0807; btr0808; btr0809; btr0810; btr0901; btr0902; btr0903; btr0904; btr0905; btr0906; btr0907; btr0908; btr0909; btr0910; btr1001; btr1002; btr1003; btr1004; btr1005; btr1006; btr1007; btr1008; btr1009; btr1010; end-ds; //--------------------------------------------------------- scDow = f_GetDayName(); exsr srSetupUserShips; 1b dow *on; exfmt screen2; // get cursor Row and Column QsnGetCsrAdr(QsnCursorRow: QsnCursorCol: 0: ApiErrDS); csrRow = QsnCursorRow; cSrCol = QsnCursorCol; // F5 = Restart 2b if InfdsFkey = f05; exsr srSetupUserShips; 1i iter; 2e endif; 2b if InfdsFkey in %list(f03 :f12); 1v leave; 2e endif; // Process users attack, then let computer have shot at it! exsr srUserAttack; // Check and see if ALL enemy ships are sunk 2b if UserxHit2 = 9 and UserxHit3 = 9 and UserxHit4 = 9 and UserxHit5 = 9; GameOver = 'CONGRATULATIONS! YOU WIN!'; aGameover = %bitor(Green: RI); 2x else; exsr srComputerAttack; 2e endif; 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; endsr; //--------------------------------------------------------- // Blow users stuff outta the water!! // 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 // // Until computer gets a hit, use a hash table to // select random shots from not-hit locations. // // 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; HitRow1 = 0; HitCol1 = 0; HitRow2 = 0; HitCol2 = 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 HitRow1 = 0; HitRow1 = row; HitCol1 = col; IsHitFirst = *on; 4x else; HitRow2 = row; HitCol2 = 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 HitRow1 = HitRow2; IsHit = f_MultNextHit(LEFT); 3b if not IsHit; IsHit = f_MultNextHit(RIGHT); 3e endif; 2e endif; 2b if HitCol1 = HitCol2 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) in %list('m':'H':'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; 1b dow *on; exfmt screen1; 2b if InfdsFkey in %list(f03 :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 not(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; //--------------------------------------------------------- // Find next random location to hit after single hit dcl-proc f_SingleNextHit; 1b dou IsGoodRowCol; row = HitRow1; col = HitCol1; IsGoodRowCol = f_MoveReticle(row: col: f_GetRandom(4): 'SGL'); 2b if IsGoodRowCol; f_DropBombOnX(row: col); return; 2e endif; 1e enddo; end-proc; //--------------------------------------------------------- // Find next location to nuke after multiple hits dcl-proc f_MultNextHit; dcl-pi *n ind; p_Vector uns(3) const; end-pi; row = HitRow1; col = HitCol1; 1b dou not IsGoodRowCol; IsGoodRowCol = f_MoveReticle(row: col: p_Vector: 'MLT'); 2b if IsGoodRowCol and not(Defend(row).Col(col) = 'H'); f_DropBombOnX(row: col); return *on; 2e endif; 1e enddo; return *off; end-proc; //--------------------------------------------------------- // Update Hits on grid and set display attributes dcl-proc f_UpdateHits; dcl-pi *n; row uns(3); col uns(3); GridRow likeds(Defend) dim(10); GridRowA likeds(DefendA) dim(10); GridSave likeds(DefendSave) dim(10); HitAttr2 char(1); HitAttr3 char(1); HitAttr4 char(1); HitAttr5 char(1); HitCount2 uns(3); HitCount3 uns(3); HitCount4 uns(3); HitCount5 uns(3); end-pi; dcl-s rowx uns(3); dcl-s colx uns(3); 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-proc; //--------------------------------------------------------- // Unload the BOMB!!! dcl-proc f_DropBombOnX; dcl-pi *n; row uns(3); col uns(3); end-pi; dcl-s rowx uns(3); dcl-s colx uns(3); 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 remaining computer ships locations. 1b if TimesHit2 + TimesHit3 + TimesHit4 + TimesHit5 = 36; GameOver = 'LOSER! PRESS F5 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-proc; //--------------------------------------------------------- // Return *off if next Row/Col not valid target dcl-proc f_MoveReticle; dcl-pi *n ind; row uns(3); col uns(3); Direction uns(3) const; TypeScan char(3) const; end-pi; // 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-proc; //--------------------------------------------------------- // randomly deploy ship positions dcl-proc f_GenerateDeployment; dcl-pi *n end-pi; dcl-s ShipSize uns(3); dcl-s randVector uns(3); dcl-s sizeCount uns(3); dcl-s row uns(3); dcl-s col uns(3); dcl-s rowx uns(3); dcl-s colx uns(3); dcl-ds rowDS dim(10) qualified; col char(1) dim(10); end-ds; //--------------------------------------------------------- // 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 // Be concerned about ships trying to run off grid // and about ships trying to overlay each other. // Known is the length of ship, direction ship is going, // size of grid. If ship would run off the 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, 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-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA12 A R SCREEN1 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 3'Deploy the 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 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 EDTCDE(Y) COLOR(BLU) A 2 8'ATTACK ' A DSPATR(HI UL) A 2 42'DEFEND ' A DSPATR(HI UL) A 2 72SYSNAME COLOR(BLU) 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'F5=Restart' COLOR(BLU) ]]> '); //--------------------------------------------------------- // JCRGMCRB - Cribbage // 03/13/19 31 for 2 instead of 1 //--------------------------------------------------------- /define ControlStatements /define Dspatr /define FunctionKeys /define f_GetCardFace /define f_GetCardColor /define f_ShuffleDeck /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMCRBD workstn infds(infds) indds(ind) sfile(sbfdta1: rrn); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s NextStepFlg char(31); dcl-s ShowScoreSbf char(3); dcl-s srCraigStat char(30); dcl-s srUserStat char(30); dcl-s WhoPlayed char(5) inz('Craig'); dcl-s WhoPlayedLast char(3); dcl-s CurrentCard uns(3); dcl-s ab uns(3); dcl-s ac uns(3); dcl-s ad uns(3); dcl-s ah uns(3); dcl-s AllGroupings uns(3) dim(8); dcl-s an uns(3); dcl-s ax uns(3); dcl-s ay uns(3); dcl-s az uns(3); dcl-s BestA uns(3); dcl-s BestB uns(3); dcl-s BestC uns(3); dcl-s BestD uns(3); dcl-s BestDiscard1 uns(3); dcl-s BestDiscard2 uns(3); dcl-s BestScore uns(3); dcl-s ByHowMuch uns(3); dcl-s CardCount uns(3); dcl-s CardsToScore uns(3); dcl-s Check uns(3); dcl-s Deal uns(3); dcl-s HandScore uns(3); dcl-s NxtPlayC uns(3); dcl-s NxtPlayCard uns(3); dcl-s NxtPlayU uns(3); dcl-s PickHighCard uns(3); dcl-s PlayAbleCnt uns(3); dcl-s PlayThisCard uns(3); dcl-s RemainingCnt uns(3); dcl-s rrn uns(3); dcl-s RunningTot uns(3); dcl-s sbfx uns(3); dcl-s Sbfxb uns(3); dcl-s sFifteens uns(3); dcl-s sFourOfKind uns(3); dcl-s sPairs uns(3); dcl-s sRunOf3s uns(3); dcl-s sRunOf4s uns(3); dcl-s sRunOf5s uns(3); dcl-s sRunOf6s uns(3); dcl-s sRunOf7s uns(3); dcl-s sThreeOfKind uns(3); dcl-s WhoseCrib uns(3); // 1=Player 2=Craig dcl-s CraigLeadAny ind; dcl-s CraigLeadFive ind; dcl-s CraigLeadFour ind; dcl-s CraigLeadNine ind; dcl-s CraigLeadSix ind; dcl-s CraigLeadTen ind; dcl-s CraigLeadThree ind; dcl-s CraigLeadTwo ind; dcl-s IsCardSelected ind dim(6); dcl-s IsCraigCardPlayed ind dim(4); // what has been played dcl-s IsCraigGo ind; dcl-s IsCraigOut ind; // Craig out of card dcl-s IsFlush ind; dcl-s IsFound ind; dcl-s IsGameOver ind; // we have a winner dcl-s IsGO ind; dcl-s IsLoadGraph ind; dcl-s IsOver31 ind; dcl-s IsPickBest ind; // Craig play logic dcl-s IsUserCardPlayed ind dim(4); dcl-s IsUserGo ind; dcl-s IsUserOut ind; // user out of cards dcl-s DiscardX char(1) dim(6) based(ptr7); dcl-s ptr7 pointer inz(%addr(discard1)); dcl-c QuoteMark const(''''); // card face 3d array dcl-ds RowDsx qualified template; col char(2) dim(4); end-ds; dcl-ds Face dim(4) qualified based(ptr1); row likeds(RowDsx) dim(3); end-ds; dcl-s ptr1 pointer inz(%addr(chand11)); // screen field attributes 3d array dcl-ds RowDsy qualified template; col char(1) dim(4); end-ds; dcl-ds Attr dim(4) qualified based(ptr2); row likeds(RowDsy) dim(3); end-ds; dcl-s ptr2 pointer inz(%addr(chand11a)); // cards Craig will play 2d array dcl-ds PlayCraig dim(3) qualified based(ptr3); col char(2) dim(4); end-ds; dcl-s ptr3 pointer inz(%addr(Play11)); dcl-ds PlayCraigA dim(3) qualified based(ptr4); col char(1) dim(4); end-ds; dcl-s ptr4 pointer inz(%addr(Play11a)); // cards user will play 2d array dcl-ds PlayUser dim(3) qualified based(ptr5); col char(2) dim(4); end-ds; dcl-s ptr5 pointer inz(%addr(Play15)); dcl-ds PlayUserA dim(3) qualified based(ptr6); col char(1) dim(4); end-ds; dcl-s ptr6 pointer inz(%addr(Play15a)); // name screen indicators dcl-ds ind qualified; sfldsp ind pos(01); sfldspctl ind pos(02); Play1stCard ind pos(10); Play2ndCard ind pos(20); Play3rdCard ind pos(30); Play4thCard ind pos(40); PlayMsg ind pos(45); Play5thCard ind pos(50); Play6thCard ind pos(60); CribMsgCraig ind pos(70); CribMsgUser ind pos(71); ColrBarCraig ind pos(72); ColrBarUser ind pos(73); CraigSaysGo ind pos(74); UserSaysGo ind pos(75); BorderRed ind pos(76); BorderBlue ind pos(77); end-ds; dcl-ds indsav qualified; Play1stCard ind; Play2ndCard ind; Play3rdCard ind; Play4thCard ind; end-ds; dcl-ds *n; NewDeck char(2) dim(52); // newly sorted deck NewCard uns(3) overlay(newdeck:1); NewSuite char(1) overlay(newdeck:*next); end-ds; dcl-ds *n; uDealt char(2) dim(6) ascend; // users hand uFace uns(3) overlay(uDealt:1); uSuite char(1) overlay(uDealt:*next); end-ds; dcl-ds *n; uPlay4 char(2) dim(4) ascend; // 4 cards to play uFace4 uns(3) overlay(uPlay4:1); uSuite4 char(1) overlay(uPlay4:*next); end-ds; dcl-ds *n; cDealt char(2) dim(6) ascend; // Craigs hand cFace uns(3) overlay(cDealt:1); cSuite char(1) overlay(cDealt:*next); end-ds; dcl-ds *n; cPlay4 char(2) dim(4) ascend; // 4 cards to play cFace4 uns(3) overlay(cPlay4:1); cSuite4 char(1) overlay(cPlay4:*next); end-ds; dcl-ds *n; CribCards char(2) dim(4) ascend inz; // either crib CribFace uns(3) overlay(CribCards:1); CribSuite char(1) overlay(CribCards:*next); end-ds; dcl-ds *n; PlayIt char(2) dim(8); // cards played pFace uns(3) overlay(PlayIt:1); pSuite char(1) overlay(PlayIt:*next); end-ds; dcl-ds BestIndexDS inz; BestIndexA uns(3); BestIndexB uns(3); BestIndexC uns(3); BestIndexD uns(3); BestArry uns(3) dim(4) pos(1); end-ds; // Craig hand AI and scoring variables dcl-ds *n; TstDeck char(2) dim(8) descend inz; // work deck to compare TstCard uns(3) overlay(TstDeck:1); TstSuite char(1) overlay(TstDeck:*next); end-ds; dcl-ds *n; RunDeck char(2) dim(8) descend inz; // drop when runs of RunCard uns(3) overlay(RunDeck:1); end-ds; dcl-ds *n; SavDeck char(2) dim(8); // Original Deck SavCard uns(3) overlay(Savdeck:1) inz; SavSuite char(1) overlay(Savdeck:*next); end-ds; dcl-ds aIndex inz; a1 uns(3); a2 uns(3); a3 uns(3); a4 uns(3); a5 uns(3); a6 uns(3); a7 uns(3); IndexArry uns(3) dim(7) pos(1); end-ds; // load cards that scored to window dcl-ds sbfSC inz; // scoring cards sbfSC1 char(2); sbfSC2 char(2); sbfSC3 char(2); sbfSC4 char(2); sbfSC5 char(2); sbfSCval char(2) dim(5) pos(1); end-ds; dcl-ds sbfSCa inz; // scoring card attributes sbfSC1a char(1); sbfSC2a char(1); sbfSC3a char(1); sbfSC4a char(1); sbfSC5a char(1); sbfSCatr char(1) dim(5) pos(1); end-ds; // move bar graph to represent total scores dcl-ds BarCds inz; // Craigs graph trackc1; trackc2; trackc3; BarCarry char(1) dim(120) pos(1); end-ds; dcl-ds BarUds inz; // users graph tracku1; tracku2; tracku3; BarUarry char(1) dim(120) pos(1); end-ds; // map screen fields into DS so pointers to data can overlay dcl-ds *n; chand11a; chand12a; chand13a; chand14a; chand21a; chand22a; chand23a; chand24a; chand31a; chand32a; chand33a; chand34a; ccrib11a; ccrib12a; ccrib13a; ccrib14a; ccrib21a; ccrib22a; ccrib23a; ccrib24a; ccrib31a; ccrib32a; ccrib33a; ccrib34a; uhand11a; uhand12a; uhand13a; uhand14a; uhand21a; uhand22a; uhand23a; uhand24a; uhand31a; uhand32a; uhand33a; uhand34a; ucrib11a; ucrib12a; ucrib13a; ucrib14a; ucrib21a; ucrib22a; ucrib23a; ucrib24a; ucrib31a; ucrib32a; ucrib33a; ucrib34a; play11a; play12a; play13a; play14a; play21a; play22a; play23a; play24a; play31a; play32a; play33a; play34a; play15a; play16a; play17a; play18a; play25a; play26a; play27a; play28a; play35a; play36a; play37a; play38a; uhand15a; uhand16a; uhand25a; uhand26a; uhand35a; uhand36a; play11; play12; play13; play14; play21; play22; play23; play24; play31; play32; play33; play34; play15; play16; play17; play18; play25; play26; play27; play28; play35; play36; play37; play38; chand11; chand12; chand13; chand14; chand21; chand22; chand23; chand24; chand31; chand32; chand33; chand34; ccrib11; ccrib12; ccrib13; ccrib14; ccrib21; ccrib22; ccrib23; ccrib24; ccrib31; ccrib32; ccrib33; ccrib34; uhand11; uhand12; uhand13; uhand14; uhand21; uhand22; uhand23; uhand24; uhand31; uhand32; uhand33; uhand34; ucrib11; ucrib12; ucrib13; ucrib14; ucrib21; ucrib22; ucrib23; ucrib24; ucrib31; ucrib32; ucrib33; ucrib34; uhand15; uhand16; uhand25; uhand26; uhand35; uhand36; discard1; discard2; discard3; discard4; discard5; discard6; end-ds; scDow = f_GetDayName(); //--------------------------------------------------------- // load initial screen to show lots of pretty colors 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); Deck1 = *blanks; Deck2 = *blanks; Deck3 = *blanks; 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; u121 = *blanks; c121 = *blanks; runningtot = 31; ind.CribMsgCraig = *on; ind.CribMsgUser = *on; ind.ColrBarCraig = *off; ind.ColrBarUser = *off; ind.PlayMsg = *off; PlayMsg = *blanks; UserMsg = 'Press Enter to begin!'; exfmt screen; exsr srCheckExit; // Initialize stuff for new game to begin WhoseCrib = 2; //player 1st crib barucnt = 0; barccnt = 0; u121 = *blanks; c121 = *blanks; 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 in play, what card values, who went first last time. // Use a flag concept to keep track of what is happening. //--------------------------------------------------------- 1b dow *on; 2b if NextStepFlg = 'Craig Plays a Card' or NextStepFlg = 'Play Craig 1st card'; 2x else; exfmt screen; 2e endif; 2b if InfdsFkey in %list(f03 :f12); 1v leave; 2e endif; usermsga = *blanks; UserMsg = *blanks; //--------------------------------------------------------- // Show users hand and prompt 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; //--------------------------------------------------------- // Use savant subroutines to do simple steps (or not so simple). // They will report status back of what they did and all grim complicated // control logic is 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 // If Craig is out of cards and user cannot play, still give Craig // a GO for 1 to reset deck count. // or vice versa if user is out of cards and Craig cannot 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 cannot 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 cannot play (not IsCraigOut) and //Craig has cards IsCraigGo; //Craig cannot 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 cannot 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 cannot 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 cannot play (not IsCraigOut) and //Craig has cards (not IsUserOut) and //User has cards IsUserGo; //User cannot 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 cannot 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 // 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 is selected. // If nothing scores, play highest card. //--------------------------------------------------------- NxtPlayCard += 1; PlayThisCard = 0; BestScore = 0; PickHighCard = 0; 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. // 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 is a winner, stop game and show results. //--------------------------------------------------------- 1b if IsGameOver; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' WON by ' + %triml(%editc(ByHowMuch:'4')) + ' .' + ' Thank you for good game.'; ind.Play1stCard = *off; ind.Play2ndCard = *off; ind.Play3rdCard = *off; ind.Play4thCard = *off; ind.Play5thCard = *off; ind.Play6thCard = *off; usermsga = *blanks; usermsg = *blanks; exfmt screen; *inlr = *on; return; 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; // 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; DiscardX(*) = *blanks; 2e endif; 1e endif; exsr srChkForGO; //Check Craig GO endsr; //--------------------------------------------------------- // Show users hand and prompt 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; DiscardX(*) = *blanks; UserMsga = *blanks; 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 start card. ind.Play5thCard = *off; ind.Play6thCard = *off; Deck1 = f_GetCardFace(NewCard(13)); Deck1a = %bitor(WHITE: PR: UL); Deck2a = f_GetCardColor(NewSuite(13)); Deck3a = Deck2a; //--------------------------------------------------------- // Load two user discards into crib . // Load four 'keepers' into users Play array. //--------------------------------------------------------- ac = 0; ax = 0; ay = 0; UPlay4(*) = *blanks; 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; uHand15 = *blanks; uhand16 = *blanks; uhand15a = *blanks; uhand16a = *blanks; uhand25a = *blanks; uhand26a = *blanks; uhand35a = *blanks; uhand36a = *blanks; DiscardX(*) = *blanks; 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; exsr srCheckExit; PlayMsg = *blanks; ind.PlayMsg = *off; 1e endif; endsr; //--------------------------------------------------------- // Craig picks 1st card to play. There are lots of strategies that // could be applied here. // This subroutine can be executed after GO, so is 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 will equal index of // card from Craigs hand 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 += 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 += 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 is 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. // Flush processing is different for crib, // all 4 cards must match suite of starting card. //--------------------------------------------------------- begsr srScoreWindow; PlayMsg = *blanks; ind.PlayMsg = *off; ind.BorderRed = *off; ind.BorderBlue = *off; savdeck(*) = *blanks; 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 did not win exsr srScoreUser; 2e endif; 1x else; //Craig has crib lin = 6; //position window exsr srScoreUser; 2b if not IsGameOver; //user did not win exsr srScoreCraig; 2e endif; 1e endif; // Give crib points to crib holder 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 ---- sbfscval(*) = *blanks; sbfscatr(*) = *blanks; 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; exsr srCheckExit; 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 ---- sbfscval(*) = *blanks; sbfscatr(*) = *blanks; 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; exsr srCheckExit; 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 ---- sbfscval(*) = *blanks; sbfscatr(*) = *blanks; 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; exsr srCheckExit; 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 sbfscval(*) = *blanks; sbfscatr(*) = *blanks; 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; sbfscatr(*) = *blanks; 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; SavDeck(*) = *blanks; savCard = 0; TstDeck(*) = *blanks; TstCard = 0; BestB = 0; BestC = 0; BestD = 0; BestScore = 0; 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 is 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 and nothing scored. // There is room for strategy here but to keep it simple, // 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; ax = 0; 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 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 //--------------------------------------------------------- BestDiscard1 = 0; BestDiscard2 = 0; 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); CribCards(*) = *blanks; 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) = Attr(ah).Row(2).Col(ax); 1e endfor; endsr; //--------------------------------------------------------- // Deal next hand //--------------------------------------------------------- begsr srNextHand; Face(*) = *all' '; Attr(*) = *allx'00'; PlayCraig(*) = *all' '; PlayCraigA(*) = *allx'00'; PlayUser(*) = *all' '; PlayUserA(*) = *allx'00'; NxtPlayC = 0; NxtPlayU = 0; Deck1A = *blanks; Deck2A = *blanks; Deck3A = *blanks; Deck1 = *blanks; Deck2 = *blanks; Deck3 = *blanks; PlayIt(*) = *blanks; WhoPlayedLast = *blanks; IsUserGo = *off; IsCraigGo = *off; IsUserOut = *off; IsCraigOut = *off; IsPickBest = *off; NxtPlayCard = 0; pFace(*) = 0; PlayThisCard = 0; uFace(*) = 0; uFace4(*) = 0; cFace(*) = 0; cFace4(*) = 0; CribFace(*) = 0; TstCard(*) = 0; RunCard(*) = 0; SavCard(*) = 0; RunningTot = 0; srCraigStat = *blanks; srUserStat = *blanks; 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; ax = 0; 1b for Deal = 1 by 2 to 11; ax += 1; uDealt(ax) = NewDeck(Deal); 1e endfor; // load even cards to Craig ax = 0; 1b for Deal = 2 by 2 to 12; ax += 1; cDealt(ax) = NewDeck(Deal); 1e endfor; ax = 0; //--------------------------------------------------------- // Load 6 user card faces to screen. // Only first four cards are in array. 5th and 6th card are // only used for crib selection and play minor part in overall scheme. // Load cards function returns card face (A 1 2 3 4 J Q K) and color // attribute for card in hand. //--------------------------------------------------------- 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; sbfscval(*) = *blanks; sbfscatr(*) = *blanks; 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. 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; AllGroupings(*) = 0; sFifteens = 0; sPairs = 0; sThreeOfKind = 0; sFourOfKind = 0; sRunOf3s = 0; sRunOf4s = 0; sRunOf5s = 0; sRunOf6s = 0; sRunOf7s = 0; // Check all cards played for 15 total Check = 0; 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. // Cannot count same cards twice. // ie if 4 of a kind, do not count same cards as 2 pairs. // Look for 4s first. //--------------------------------------------------------- 2b dou '1'; // one time do so leave will work 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. //--------------------------------------------------------- HandScore = 0; PlayMsg = *blanks; 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; exsr srCheckExit; 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; exsr srCheckExit; 3x elseif sRunOf6s > 0; HandScore = 6; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 6 for 6. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 3x elseif sRunOf5s > 0; HandScore = 5; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 5 for 5. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 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; exsr srCheckExit; 3x elseif sRunOf4s > 0; HandScore = 4; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 4 for 4. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 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; exsr srCheckExit; 3x elseif sRunOf3s > 0; HandScore = 3; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Run of 3 for 3. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 3x elseif sPairs > 0; HandScore = 2; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored Pair for 2. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 3e endif; 3b if RunningTot = 31; ind.CraigSaysGo = *off; ind.UserSaysGo = *off; HandScore = 2; ind.PlayMsg = *on; PlayMsg = %trimr(WhoPlayed) + ' scored 31 for 2. Press Enter'; exsr srMoveBarGraph; exfmt screen; exsr srCheckExit; 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; exsr srCheckExit; 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; exsr srCheckExit; // If all cards played, pop up score window for each hand exsr srShowCrib; exsr srScoreWindow; exsr srNextHand; exsr srUserDealt; 2e endif; PlayMsg = *blanks; 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; TstDeck(*) = *blanks; TstCard = 0; 2b for a1 = ax to 8; TstDeck(a1) = SavDeck(a1); 2e endfor; sorta TstCard; //--------------------------------------------------------- // run of 7 //--------------------------------------------------------- 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; TstDeck(*) = *blanks; 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; TstDeck(*) = *blanks; 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; TstDeck(*) = *blanks; 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; TstDeck(*) = *blanks; 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; RunningTot = 0; PlayIt(*) = *blanks; NxtPlayCard = 0; pFace(*) = 0; PlayCraig(*) = *blanks; PlayCraigA(*) = *blanks; PlayUser(*) = *blanks; PlayUserA(*) = *blanks; NxtPlayC = 0; NxtPlayU = 0; 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 AllGroupings(*) = 0; 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. // Look for 4s first. If found, add 1 to 4 counter. // Drop cards from test deck //--------------------------------------------------------- sFourOfKind = 0; 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 12'; CardCount = 4; exsr srLoadSbfRec; 7e endif; 7b for az = 1 to CardsToScore; 8b if CurrentCard = TstCard(az); TstCard(az) = 0; 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 //--------------------------------------------------------- sThreeOfKind = 0; 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); TstCard(az) = 0; 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 sPairs = 0; 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); TstCard(az) = 0; 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. // This is 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. // 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, it could happen) sRunOf7s = 0; 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; RunCard(a1) = 0; RunCard(a2) = 0; RunCard(a3) = 0; RunCard(a4) = 0; RunCard(a5) = 0; RunCard(a6) = 0; RunCard(a7) = 0; 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, 'remove' those // runs from the 'deck' so they do not count 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 sRunOf6s = 0; 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; RunCard(a1) = 0; RunCard(a2) = 0; RunCard(a3) = 0; RunCard(a4) = 0; RunCard(a5) = 0; RunCard(a6) = 0; 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 sRunOf5s = 0; 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; RunCard(a1) = 0; RunCard(a2) = 0; RunCard(a3) = 0; RunCard(a4) = 0; RunCard(a5) = 0; 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 sRunOf4s = 0; 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; RunCard(a1) = 0; RunCard(a2) = 0; RunCard(a3) = 0; RunCard(a4) = 0; 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 sRunOf3s = 0; 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; sorta cPlay4; // show craigs hand in numerical sequence 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) = Attr(1).Row(2).Col(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) = Attr(3).Row(2).Col(ax); 1e endfor; endsr; //--------------------------------------------------------- begsr srCheckExit; 1b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 1e endif; endsr; //--------------------------------------------------------- // King, Queen and Jack card values count as 10 //--------------------------------------------------------- dcl-proc f_KQJcount10; dcl-pi *n uns(3); p_Num1to13 uns(3) const; end-pi; 1b if p_Num1to13 > 10; return 10; 1e endif; return p_Num1to13; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA12 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 EDTCDE(Y) COLOR(BLU) A 70 2 32' CRIB ' COLOR(RED) DSPATR(RI) A 2 72SYSNAME COLOR(BLU) 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(9) 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 ControlStatements /define ApiErrDS /define Dspatr /define FunctionKeys /define QsnGetCsrAdr /define f_GetRandom /define f_GetDayName /define f_CenterText /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMMINED workstn infds(infds); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s col uns(3); dcl-s row uns(3); dcl-c Akna const('*'); // Mine dcl-c MFlag const('!'); // Win mine dcl-c NoBomb const(':'); // No mine dcl-c Sorok const(8); // Rows dcl-c Oszlop const(40); // Column dcl-s akt uns(3); dcl-s aknak uns(3) inz(0); dcl-s Ures uns(5); dcl-s jeloles uns(3); dcl-s rowK int(3); dcl-s colK int(3); dcl-s rows int(3); dcl-s cols int(3); dcl-s i int(3); dcl-s j int(3); dcl-s aa int(3); dcl-s bb int(3); dcl-s xx uns(3); dcl-s Number uns(3); dcl-s vanNulla char(1); dcl-s language char(1); // E-English,H-Hungaria dcl-s XKeypress uns(3); dcl-ds wstempds inz; wstemp1 char(40); wstemp2 char(40); wstemp3 char(40); wstemp4 char(40); wstemp5 char(40); wstemp6 char(40); wstemp7 char(40); wstemp8 char(40); wstempArry dim(8) like(wstemp1) pos(1); end-ds; dcl-ds Wsmezods inz; Wsmezo1; Wsmezo2; Wsmezo3; Wsmezo4; Wsmezo5; Wsmezo6; Wsmezo7; Wsmezo8; WsmezoArry dim(8) like(Wsmezo1) pos(1); end-ds; dcl-ds Mines dim(Sorok) qualified; col char(1) dim(Oszlop); end-ds; dcl-ds TempM dim(Sorok) qualified; col char(1) dim(Oszlop); end-ds; //--------------------------------------------------------- exsr DetailSettings; *in80 = *On; GameOver = *blanks; WsmezoArry(1) = 'Press F5 to start the game!'; WsmezoArry(3) = 'Nyomj F5-ot a jatek elkezdesehez!'; //?detail cursor position csrRow = 10; cSrCol = 23; row = 1; col = 1; 1b dow *on; exfmt screen1; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2e endif; QsnGetCsrAdr(QsnCursorRow: QsnCursorCol: 0: ApiErrDS); csrRow = QsnCursorRow; cSrCol = QsnCursorCol; //?Kiertekeles exsr Kiertekeles; // evaluation //--------------------------------------------------------- //?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; //--------------------------------------------------------- //?F5 Computer generate mines 2x elseif InfdsFkey = f05; *in80 = *off; csrRow = 6; cSrCol = 4; aGameover = *blanks; GameOver = *blanks; WsmezoArry(*) = *blanks; wstempArry(*) = *blanks; WsBumm1 = *blanks; WsBumm2 = *blanks; WsBumm3 = *blanks; WsBumm4 = *blanks; WsBumm5 = *blanks; Mines(*) = *all'0'; TempM(*) = *all' '; aknak = 0; // number of mines xx = f_GetRandom(30); 3b if xx < 11; xx += 10; 3e endif; // mine placement 3b for akt = 1 to xx; Mines(f_GetRandom(Sorok)).Col(f_GetRandom(Oszlop)) = Akna; 3e endfor; 3b for row = 1 to Sorok; 4b for col = 1 to Oszlop; 5b if Mines(row).Col(col) = Akna; aknak += 1; exsr Korbe; 5e endif; 4e endfor; 3e endfor; WSAkna = aknak; 1i iter; 2e endif; 1e enddo; //--------------------------------------------------------- //?Kiertekeles begsr Kiertekeles; 1b for row = 1 to Sorok; 2b if %Scan('X':WsmezoArry(row)) > 0; jeloles = %Scan('X':WsmezoArry(row)); XKeypress += 1; 3b if Mines(row).Col(jeloles) = Akna; exsr eGameOver; 3x else; %Subst(WsmezoArry(row):jeloles:1) = 'x'; exsr NezzukMeg; 3e endif; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- //?Nezzuk meg begsr NezzukMeg; rowK = row; colK = jeloles; 1b if Mines(row).Col(jeloles) <> '0'; %Subst(WsmezoArry(row):jeloles:1) = Mines(row).Col(jeloles); 1x else; clear TempM; %Subst(WsmezoArry(row):jeloles:1) = '0'; TempM(row).Col(colK) = '0'; //?<- 2b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK > 1; colK -= 1; %Subst(WsmezoArry(row):colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 2e Enddo; //?-> colK = jeloles; 2b Dow Mines(row).Col(colK) <> Akna AND Mines(row).Col(colK) = '0' AND colK < %len(WsmezoArry(row)); colK += 1; %Subst(WsmezoArry(row):colK:1) = Mines(row).Col(colK); TempM(row).Col(colK) = Mines(row).Col(colK); 2e Enddo; exsr Felkutat; 1e endif; Ures = 0; 1b for i = 1 to Sorok; 2b for j = 1 to Oszlop; 3b if %Subst(WsmezoArry(i):j:1) = ' '; Ures += 1; 3e endif; 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) <> '*'; 5b monitor; Number = %dec(Mines(i).Col(j):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 if Mines(row).Col(col) = Akna; %Subst(WsmezoArry(row):col:1) = Akna; 3e endif; 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 if Mines(row).Col(col) = Akna; %Subst(WsmezoArry(row):col:1) = MFlag; 3x else; %Subst(WsmezoArry(row):col:1) = ' '; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- //?Felkutat; begsr Felkutat; rowK = row; colK = col; 1b for aa = 1 to Oszlop; 2b for bb = 1 to Sorok; %Subst(wstempArry(bb):aa:1) = TempM(bb).Col(aa); 2e endfor; 1e endfor; //?ha van 0-s, akkor kell veluk foglalkozni vanNulla = ' '; 1b for bb = 1 to Sorok; 2b if %Scan('0':wstempArry(bb)) > 0; vanNulla = 'Y'; 1v leave; 2e endif; 1e endfor; 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; %Subst(wstempArry(bb):aa:1) = TempM(bb).Col(aa); 3b If TempM(bb).Col(aa) = '0'; %Subst(WsmezoArry(bb):aa:1) = NoBomb; 3x else; 4b If TempM(bb).Col(aa) <> ' '; %Subst(WsmezoArry(bb):aa:1) = TempM(bb).Col(aa); 4e endif; 3e endif; 2e endfor; 1e endfor; endsr; //?Detail settings -------------------------------------------------- begsr DetailSettings; scDow = f_GetDayName(); 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; ]]> '); //--------------------------------------------------------- // JCRGMPOK - Video Poker //--------------------------------------------------------- /define ControlStatements /define Dspatr /define FunctionKeys /define f_GetCardFace /define f_GetCardColor /define f_ShuffleDeck /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMPOKD workstn infds(infds) indds(ind); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s Color char(1); dcl-s NewDeck char(2) dim(52); dcl-s ac uns(3); dcl-s AceBucket uns(3); dcl-s ax uns(3); dcl-s Deal uns(3); dcl-s JackBucket uns(3); dcl-s KingBucket uns(3); dcl-s QueenBucket uns(3); dcl-s xx uns(3); dcl-s IsFlush ind; dcl-s IsRoyalStraight ind; dcl-s IsStraight ind; dcl-ds *n; UserHand char(2) dim(5) ascend; UserCard uns(3) overlay(Userhand:1); UserSuite char(1) overlay(UserHand:*next); end-ds; // Name screen indicators dcl-ds ind qualified; ScreenCtl ind pos(10); end-ds; // Card faces and Card attributes 3d array dcl-ds Rowx qualified template; col char(1) dim(4); end-ds; dcl-ds Face dim(5) qualified based(ptr1); row likeds(Rowx) dim(7); end-ds; dcl-s ptr1 pointer inz(%addr(c111)); dcl-ds Attr dim(5) likeds(Face) based(ptr2); dcl-s ptr2 pointer inz(%addr(c111a)); // map screen fields into DS so pointers to data can overlay dcl-ds DisCardDS inz; DisCard1; DisCard2; DisCard3; DisCard4; DisCard5; DisCardArry char(1) dim(5) samepos(Discard1); end-ds; // Card Id field attribute array dcl-ds CardIdAtrDS; CardId1A; CardId2A; CardId3A; CardId4A; CardId5A; CardIdAtr char(1) dim(5) samepos(CardId1A); end-ds; // Card Side Border attributes array dcl-ds BorderAtrDS; Border1A; Border2A; Border3A; Border4A; Border5A; BorderAtr char(1) dim(5) samepos(Border1A); end-ds; dcl-ds BorderTopBotDS; BorderTop1; BorderBot1 overlay(BorderTop1); BorderTop2; BorderBot2 overlay(BorderTop2); BorderTop3; BorderBot3 overlay(BorderTop3); BorderTop4; BorderBot4 overlay(BorderTop4); BorderTop5; BorderBot5 overlay(BorderTop5); BorderTopBot char(11) dim(5) pos(1); end-ds; // top and bottom Border attributes dcl-ds TopBotAtrDS; TopBot1A; TopBot2A; TopBot3A; TopBot4A; TopBot5A; TopBotAtr char(1) dim(5) pos(1); end-ds; dcl-ds CardIdDS; CVALT1; CVALT2; CVALT3; CVALT4; CVALT5; CardId char(2) dim(5) pos(1); end-ds; dcl-ds BorderSidesDS; Side11L; Side12L overlay(Side11L); Side13L overlay(Side11L); Side14L overlay(Side11L); Side15L overlay(Side11L); Side16L overlay(Side11L); Side17L overlay(Side11L); Side18L overlay(Side11L); Side19L overlay(Side11L); Side110L overlay(Side11L); Side111L overlay(Side11L); Side11R overlay(Side11L); Side12R overlay(Side11L); Side13R overlay(Side11L); Side14R overlay(Side11L); Side15R overlay(Side11L); Side16R overlay(Side11L); Side17R overlay(Side11L); Side18R overlay(Side11L); Side19R overlay(Side11L); Side110R overlay(Side11L); Side111R overlay(Side11L); Side21L; Side22L overlay(Side21L); Side23L overlay(Side21L); Side24L overlay(Side21L); Side25L overlay(Side21L); Side26L overlay(Side21L); Side27L overlay(Side21L); Side28L overlay(Side21L); Side29L overlay(Side21L); Side210L overlay(Side21L); Side211L overlay(Side21L); Side21R overlay(Side21L); Side22R overlay(Side21L); Side23R overlay(Side21L); Side24R overlay(Side21L); Side25R overlay(Side21L); Side26R overlay(Side21L); Side27R overlay(Side21L); Side28R overlay(Side21L); Side29R overlay(Side21L); Side210R overlay(Side21L); Side211R overlay(Side21L); Side31L; Side32L overlay(Side31L); Side33L overlay(Side31L); Side34L overlay(Side31L); Side35L overlay(Side31L); Side36L overlay(Side31L); Side37L overlay(Side31L); Side38L overlay(Side31L); Side39L overlay(Side31L); Side310L overlay(Side31L); Side311L overlay(Side31L); Side31R overlay(Side31L); Side32R overlay(Side31L); Side33R overlay(Side31L); Side34R overlay(Side31L); Side35R overlay(Side31L); Side36R overlay(Side31L); Side37R overlay(Side31L); Side38R overlay(Side31L); Side39R overlay(Side31L); Side310R overlay(Side31L); Side311R overlay(Side31L); Side41L; Side42L overlay(Side41L); Side43L overlay(Side41L); Side44L overlay(Side41L); Side45L overlay(Side41L); Side46L overlay(Side41L); Side47L overlay(Side41L); Side48L overlay(Side41L); Side49L overlay(Side41L); Side410L overlay(Side41L); Side411L overlay(Side41L); Side41R overlay(Side41L); Side42R overlay(Side41L); Side43R overlay(Side41L); Side44R overlay(Side41L); Side45R overlay(Side41L); Side46R overlay(Side41L); Side47R overlay(Side41L); Side48R overlay(Side41L); Side49R overlay(Side41L); Side410R overlay(Side41L); Side411R overlay(Side41L); Side51L; Side52L overlay(Side51L); Side53L overlay(Side51L); Side54L overlay(Side51L); Side55L overlay(Side51L); Side56L overlay(Side51L); Side57L overlay(Side51L); Side58L overlay(Side51L); Side59L overlay(Side51L); Side510L overlay(Side51L); Side511L overlay(Side51L); Side51R overlay(Side51L); Side52R overlay(Side51L); Side53R overlay(Side51L); Side54R overlay(Side51L); Side55R overlay(Side51L); Side56R overlay(Side51L); Side57R overlay(Side51L); Side58R overlay(Side51L); Side59R overlay(Side51L); Side510R overlay(Side51L); Side511R overlay(Side51L); BorderSides char(1) dim(5) pos(1); end-ds; // Card Faces dcl-ds *n; C111; C112; C113; C114; C121; C122; C123; C124; C131; C132; C133; C134; C141; C142; C143; C144; C151; C152; C153; C154; C161; C162; C163; C164; C171; C172; C173; C174; C211; C212; C213; C214; C221; C222; C223; C224; C231; C232; C233; C234; C241; C242; C243; C244; C251; C252; C253; C254; C261; C262; C263; C264; C271; C272; C273; C274; C311; C312; C313; C314; C321; C322; C323; C324; C331; C332; C333; C334; C341; C342; C343; C344; C351; C352; C353; C354; C361; C362; C363; C364; C371; C372; C373; C374; C411; C412; C413; C414; C421; C422; C423; C424; C431; C432; C433; C434; C441; C442; C443; C444; C451; C452; C453; C454; C461; C462; C463; C464; C471; C472; C473; C474; C511; C512; C513; C514; C521; C522; C523; C524; C531; C532; C533; C534; C541; C542; C543; C544; C551; C552; C553; C554; C561; C562; C563; C564; C571; C572; C573; // Card face attributes C574; C111A; C112A; C113A; C114A; C121A; C122A; C123A; C124A; C131A; C132A; C133A; C134A; C141A; C142A; C143A; C144A; C151A; C152A; C153A; C154A; C161A; C162A; C163A; C164A; C171A; C172A; C173A; C174A; C211A; C212A; C213A; C214A; C221A; C222A; C223A; C224A; C231A; C232A; C233A; C234A; C241A; C242A; C243A; C244A; C251A; C252A; C253A; C254A; C261A; C262A; C263A; C264A; C271A; C272A; C273A; C274A; C311A; C312A; C313A; C314A; C321A; C322A; C323A; C324A; C331A; C332A; C333A; C334A; C341A; C342A; C343A; C344A; C351A; C352A; C353A; C354A; C361A; C362A; C363A; C364A; C371A; C372A; C373A; C374A; C411A; C412A; C413A; C414A; C421A; C422A; C423A; C424A; C431A; C432A; C433A; C434A; C441A; C442A; C443A; C444A; C451A; C452A; C453A; C454A; C461A; C462A; C463A; C464A; C471A; C472A; C473A; C474A; C511A; C512A; C513A; C514A; C521A; C522A; C523A; C524A; C531A; C532A; C533A; C534A; C541A; C542A; C543A; C544A; C551A; C552A; C553A; C554A; C561A; C562A; C563A; C564A; C571A; C572A; C573A; C574A; end-ds; //--------------------------------------------------------- // Load initial splash screen to get game started scDow = f_GetDayName(); 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; exfmt screen; 1b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 1e endif; //--------------------------------------------------------- // Play the game //--------------------------------------------------------- 1b dow *on; 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 in %list(f03 :f12); 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 in %list(f03 :f12); 1v leave; 2e endif; 1e enddo; *inlr = *on; return; //-------------------------------------------------- // See what is highest value of hand and payout // 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; HandValue = *blanks; 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. Note an ACE can either be 1 or 11. 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 must 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 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 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 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 there are 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 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; //--------------------------------------------------------- // Return 7R X 4C array of selected character //--------------------------------------------------------- dcl-proc f_LoadFace; dcl-pi *n char(4) dim(7); pBaseChar char(2) const; end-pi; dcl-s Line char(4) dim(7); 1b if pBaseChar = 'A' or pBaseChar = 'A1'; Line(*) = 'A A'; Line(1) = ' AA '; Line(4) = 'AAAA'; 1x elseif pBaseChar = 'K'; Line = %list( 'K K': 'K K ': 'KK ': 'K ': 'KK ': 'K K ': 'K K'); 1x elseif pBaseChar = 'Q'; Line(*) = 'Q Q'; Line(1) = ' QQ '; Line(6) = 'Q QQ'; Line(7) = ' QQ '; 1x elseif pBaseChar = 'J'; Line(*) = ' J '; Line(1) = 'JJJJ'; Line(6) = 'J J '; Line(7) = 'JJJ '; 1x elseif pBaseChar = '10'; Line(*) = '10 0'; Line(1) = '1000'; Line(7) = '1000'; 1x elseif pBaseChar = '9'; Line = %list( '9999': '9 9': '9 9': '9999': ' 9': ' 9': '9999'); 1x elseif pBaseChar = '8'; Line = %list( '8888': '8 8': '8 8': '8888': '8 8': '8 8': '8888'); 1x elseif pBaseChar = '7'; Line = %list( '7777': ' 7': ' 7': ' 7 ': ' 7 ': '7 ': '7 '); 1x elseif pBaseChar = '6'; Line = %list( '6666': '6 ': '6 ': '6666': '6 6': '6 6': '6666'); 1x elseif pBaseChar = '5'; Line = %list( '5555': '5 ': '5 ': '5555': ' 5': ' 5': '5555'); 1x elseif pBaseChar = '4'; Line = %list( ' 44': ' 4 4': '4 4': '4444': ' 4': ' 4': ' 4'); 1x elseif pBaseChar = '3'; Line = %list( '3333': ' 3': ' 3': ' 333': ' 3': ' 3': '3333'); 1x elseif pBaseChar = '2'; Line = %list( '2222': ' 2': ' 2': '2222': '2 ': '2 ': '2222'); 1x elseif pBaseChar = 'P'; Line = %list( 'PPPP': 'P P': 'P P': 'PPPP': 'P ': 'P ': 'P '); 1x elseif pBaseChar = 'O'; Line(*) = 'O O'; Line(1) = ' OO '; Line(7) = ' OO '; 1x elseif pBaseChar = 'E'; Line = %list( 'EEEE': 'E ': 'E ': 'EEE ': 'E ': 'E ': 'EEEE'); 1x elseif pBaseChar = 'R'; Line = %list( 'RRR': 'R R': 'R R': 'RRR ': 'R R ': 'R R': 'R R'); 1e endif; return Line; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA12 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME 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) ]]> '); //--------------------------------------------------------- // JCRGMPYR - Pyramid Solitaire // Addictive fun! // Select two cards whose sum=13 till all cards played // J + 2 = 13 Q + A = 13 // // Program re-deals hands that are mathmatically impossible to win. // Still not easy to win! // // 'Auto-match' code cuts down on pressing the tab key. // If 9 is selected, the program will find the corresponding 4. etc. //--------------------------------------------------------- /define ControlStatements /define psds /define Dspatr /define FunctionKeys /define f_GetCardFace /define f_RmvSflMsg /define f_ShuffleDeck /define f_GetRowColumn /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMPYRD workstn infds(infds); dcl-ds Infds; InfdsFile char(10) pos(83); InfdsLib char(10) pos(93); InfdsRcdfmt char(10) pos(261); InfdsFkey char(1) pos(369); end-ds; dcl-s scrCardFaces char(2) dim(35) based(ptr1); dcl-s scrSelect char(1) dim(35) based(ptr2); dcl-s PrvCards char(2) dim(17) based(ptr3); dcl-s ptr1 pointer inz(%addr(r1c1)); dcl-s ptr2 pointer inz(%addr(x1c1)); dcl-s ptr3 pointer inz(%addr(prvCard)); dcl-s XinArrayCnt uns(3); dcl-s XinTotalCnt uns(3); dcl-s IndexFrom uns(3); dcl-s IndexTo uns(3); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s zz uns(3); dcl-s row uns(3) inz(1); dcl-s col uns(3) inz(1); dcl-s AutoMatchVal uns(3); dcl-s FaceCounts uns(3) dim(13); dcl-s RowHigh uns(3) dim(13); dcl-s RowLow uns(3) dim(13); dcl-s RowMapper uns(3) dim(35); dcl-s ColMapper uns(3) dim(35); dcl-s SaveXIndex uns(3) dim(2); dcl-s UnDoArray dim(37) like(screends); dcl-s UnDoCount uns(3); dcl-s IsError ind; dcl-s IsPlayFromDeck ind; dcl-s IsPlayFromPrv ind; dcl-s IsPossible ind; dcl-s IsAutoMatch ind; dcl-s AutoMatchXLOC char(10); dcl-ds Deck len(2) dim(52) qualified; Card uns(3); end-ds; dcl-ds CardAtr dim(8) qualified based(ptr4); col char(1) dim(7); end-ds; dcl-s ptr4 pointer inz(%addr(CardAtrDS)); dcl-ds SelcRow dim(8) likeds(CardAtr) based(ptr5); dcl-s ptr5 pointer inz(%addr(SelcAtrDS)); dcl-ds scrCardFaces2d dim(8) likeds(CardAtr) inz; // map screen fields into DS so ptrs to data can overlay // and undo function can work dcl-ds screends inz; r1c1; r2c1; r2c2; r3c1; r3c2; r3c3; r4c1; r4c2; r4c3; r4c4; r5c1; r5c2; r5c3; r5c4; r5c5; r6c1; r6c2; r6c3; r6c4; r6c5; r6c6; r7c1; r7c2; r7c3; r7c4; r7c5; r7c6; r7c7; rfc1; rfc2; rfc3; rfc4; rfc5; rfc6; rfc7; 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; NextX; PrvX; PrvCard; PrvCard2; PrvCard3; PrvCard4; PrvCard5; PrvCard6; PrvCard7; PrvCard8; PrvCard9; PrvCard10; PrvCard11; PrvCard12; PrvCard13; PrvCard14; PrvCard15; PrvCard16; PrvCard17; CardsLeft; CardsInDec; NextCard; PrvCardVal uns(3); DeckCardVal uns(3); NxtPlayC uns(3); end-ds screends; // Asymmetrical 2 dim array in the shape of a pyramid // row 1 is 1,1 // row 2 is 2,1 then 2,2, etc. dcl-ds CardAtrDS; CardAtr11; CardAtr21 pos(8); CardAtr22; CardAtr31 pos(15); CardAtr32; CardAtr33; CardAtr41 pos(22); CardAtr42; CardAtr43; CardAtr44; CardAtr51 pos(29); CardAtr52; CardAtr53; CardAtr54; CardAtr55; CardAtr61 pos(36); CardAtr62; CardAtr63; CardAtr64; CardAtr65; CardAtr66; CardAtr71 pos(43); CardAtr72; CardAtr73; CardAtr74; CardAtr75; CardAtr76; CardAtr77; CardAtr81 pos(50); CardAtr82; CardAtr83; CardAtr84; CardAtr85; CardAtr86; CardAtr87; end-ds CardAtrDS; dcl-ds SelcAtrDS; SelcAtr11; SelcAtr21 pos(8); SelcAtr22; SelcAtr31 pos(15); SelcAtr32; SelcAtr33; SelcAtr41 pos(22); SelcAtr42; SelcAtr43; SelcAtr44; SelcAtr51 pos(29); SelcAtr52; SelcAtr53; SelcAtr54; SelcAtr55; SelcAtr61 pos(36); SelcAtr62; SelcAtr63; SelcAtr64; SelcAtr65; SelcAtr66; SelcAtr71 pos(43); SelcAtr72; SelcAtr73; SelcAtr74; SelcAtr75; SelcAtr76; SelcAtr77; SelcAtr81 pos(50); SelcAtr82; SelcAtr83; SelcAtr84; SelcAtr85; SelcAtr86; SelcAtr87; end-ds SelcAtrDS; //-------------------------------------------------------------------- // If user selects a single X and there is not // auto-match, Position the cursor on the field name // that was X'ed. Need to know the name of that field // to retrieve row/column to put the cursor //-------------------------------------------------------------------- dcl-ds PositionToDS; *n char(10) inz('X1C1'); *n char(10) inz('X2C1'); *n char(10) inz('X2C2'); *n char(10) inz('X3C1'); *n char(10) inz('X3C2'); *n char(10) inz('X3C3'); *n char(10) inz('X4C1'); *n char(10) inz('X4C2'); *n char(10) inz('X4C3'); *n char(10) inz('X4C4'); *n char(10) inz('X5C1'); *n char(10) inz('X5C2'); *n char(10) inz('X5C3'); *n char(10) inz('X5C4'); *n char(10) inz('X5C5'); *n char(10) inz('X6C1'); *n char(10) inz('X6C2'); *n char(10) inz('X6C3'); *n char(10) inz('X6C4'); *n char(10) inz('X6C5'); *n char(10) inz('X6C6'); *n char(10) inz('X7C1'); *n char(10) inz('X7C2'); *n char(10) inz('X7C3'); *n char(10) inz('X7C4'); *n char(10) inz('X7C5'); *n char(10) inz('X7C6'); *n char(10) inz('X7C7'); *n char(10) inz('XFC1'); *n char(10) inz('XFC2'); *n char(10) inz('XFC3'); *n char(10) inz('XFC4'); *n char(10) inz('XFC5'); *n char(10) inz('XFC6'); *n char(10) inz('XFC7'); FieldsNameArry char(10) dim(35) pos(1); end-ds; scDow = f_GetDayName(); //--------------------------------------------------------- // The program works with cards either as a string of values or a two dim array. // 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 //--------------------------------------------------------- 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 dow *on; 2b if cardsleft = 0; snd-msg ' ************** WINNER **************'; 2e endif; 2b if not(IsError or 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 in %list(f03 :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; snd-msg ' 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 not(Deck(NxtPlayC).Card = 13); NxtPlayC += 1; 3b if NxtPlayC >= 53; NextCard = *blanks; DeckCardVal = 0; CardsInDec = 0; 2v leave; 3x else; NextCard = f_GetCardFace(Deck(NxtPlayC).Card); DeckCardVal = Deck(NxtPlayC).Card; CardsInDec -= 1; 3e endif; 2e enddo; 1e endif; endsr; //--------------------------------------------------------- // Make sure user only X's two selections and they total 13. // If single value is selected, evoke the auto-match // function to find the corresponding = 13 matching card. // It is important to know the single X location (AutoMatchXLOC) // as different search patterns routines are executed based on // what 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 = Deck(xx).Card; 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; snd-msg ' 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 snd-msg ' TOO MANY CARDS SELECTED'; IsError = *on; 1x elseif XinTotalCnt < 1; //None selected snd-msg ' PLEASE SELECT CARDS'; IsError = *on; 1x elseif XinTotalCnt = 2; 2b if XinArrayCnt = 2; //both from array 3b if Deck(SaveXIndex(1)).Card + Deck(SaveXIndex(2)).Card <> 13; snd-msg ' 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 Deck(SaveXIndex(1)).Card + DeckCardVal <> 13; snd-msg ' 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 Deck(SaveXIndex(1)).Card + PrvCardVal <> 13; snd-msg ' 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; snd-msg ' 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, 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 (triangle) starting at the bottom right and // working up to the top to find a 5 that is open to play. // 2) the side (previous card first then card from deck) // 3) the free card or bottom. // 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. // // 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 (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 (Deck(xx).Card + AutoMatchVal) = 13; isAutoMatch = *on; XinTotalCnt += 1; XinArrayCnt += 1; 1v leave; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srNewStart; csrrow = 9; csrcol = 7; clear screenDS; // Deal 35 cards to pyramid and free use cards 1b dou IsPossible; RowHigh(*) = 9; RowLow(*) = 0; IsPossible = *on; FaceCounts(*) = 0; Deck = f_ShuffleDeck(); // easier if free deck is full (no kings) 2b for xx = 29 to 35; 3b if Deck(xx).Card = 13; IsPossible = *off; 2v leave; 3e endif; 2e endfor; 2b if not IsPossible; 1i iter; 2e endif; sorta %subarr(Deck(*).Card :29:7); scrCardFaces(*) = *blanks; //--------------------------------------------------------- // check for hands that are impossible to win // FaceCounts array is loaded with count of each type card // Element 1 is total count of aces in pyramid. // Element 2 is total count of two in pyramid. //--------------------------------------------------------- 2b for xx = 1 to 35; zz = Deck(xx).Card; 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 not(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 Deck(xx).Card = 13; // skip kings xx += 1; 1e enddo; CardsInDec = 53 - xx; NextCard = f_GetCardFace(Deck(xx).Card); DeckCardVal = Deck(xx).Card; NxtPlayC = xx; 1b for row = 7 to 8; SelcRow(row).Col(*) = %bitor(Green:UL); 1e endfor; exsr srSetHiLite; UnDoCount = 0; snd-msg ' X TWO CARDS=13. PRESS ENTER'; endsr; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA01 CA03 CA05 CA09 CA12 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME 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'Previous' 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> '); //--------------------------------------------------------- // JCRGMTIC - TicTacToe //--------------------------------------------------------- /define ControlStatements /define Dspatr /define FunctionKeys /define f_GetRandom /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMTICD workstn infds(infds); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s CheckXO char(1); dcl-s row uns(3); dcl-s col uns(3); dcl-s IsFirstMove ind; dcl-s IsPlaced ind; dcl-s IsWinner ind; // control attributes of selection field two-dim array dcl-ds ProtectA dim(3) qualified based(ProtectPtr); col char(1) dim(3); end-ds; dcl-s ProtectPtr pointer inz(%addr(ProtectDS)); // selection grid two-dim array dcl-ds Choice dim(3) likeds(ProtectA) based(SelPtr); dcl-s SelPtr pointer inz(%addr(SelectionDS)); // map screen fields into DS dcl-ds SelectionDS inz; Row1 char(3); r1c1 overlay(Row1:1); r1c2 overlay(Row1:2); r1c3 overlay(Row1:3); Row2 char(3); r2c1 overlay(Row2:1); r2c2 overlay(Row2:2); r2c3 overlay(Row2:3); Row3 char(3); r3c1 overlay(Row3:1); r3c2 overlay(Row3:2); r3c3 overlay(Row3:3); end-ds; dcl-ds ProtectDS; ProcAtr11; ProcAtr12; ProcAtr13; ProcAtr21; ProcAtr22; ProcAtr23; ProcAtr31; ProcAtr32; ProcAtr33; end-ds; dcl-ds DspDS; Grid11Row1; Grid11Row2; Grid11Row3; Grid11Row4; Grid11Row5; Grid12Row1; Grid12Row2; Grid12Row3; Grid12Row4; Grid12Row5; Grid13Row1; Grid13Row2; Grid13Row3; Grid13Row4; Grid13Row5; Grid21Row1; Grid21Row2; Grid21Row3; Grid21Row4; Grid21Row5; Grid22Row1; Grid22Row2; Grid22Row3; Grid22Row4; Grid22Row5; Grid23Row1; Grid23Row2; Grid23Row3; Grid23Row4; Grid23Row5; Grid31Row1; Grid31Row2; Grid31Row3; Grid31Row4; Grid31Row5; Grid32Row1; Grid32Row2; Grid32Row3; Grid32Row4; Grid32Row5; Grid33Row1; Grid33Row2; Grid33Row3; Grid33Row4; Grid33Row5; end-ds; dcl-ds ATRDS; atr11; atr12; atr13; atr21; atr22; atr23; atr31; atr32; atr33; end-ds; // row, column, then 5 lines three-dim array dcl-ds DspColx qualified template; DspLine char(9) dim(5); end-ds; dcl-ds DspRow dim(3) qualified based(DspPtr); DspCol likeds(DspColx) dim(3); end-ds; dcl-s DspPtr pointer inz(%addr(DspDs)); dcl-ds AtrRow dim(3) qualified based(AtrPtr); AtrCol char(1) dim(3); end-ds; dcl-s AtrPtr pointer inz(%addr(AtrDs)); //--------------------------------------------------------- scDow = 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 in %list(f03 :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 dow *on; exfmt screen; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2e endif; 2b if InfdsFkey = f05; 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 first move and center square not X, load O to center square. // If center square is X, load random O. //--------------------------------------------------------- 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; // See if 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 available spaces for a strategy move, ie game is a tie and // there are only few spaces left, then use first available space. //--------------------------------------------------------- 4b if not IsPlaced; exsr srFirstOpen; 4e endif; exsr srLoadCharacter; 3e endif; 2e endif; 1e enddo; //--------------------------------------------------------- //--------------------------------------------------------- begsr srFirstOpen; 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; //--------------------------------------------------------- // 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 not a clear game winner // then make sure to 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; //--------------------------------------------------------- // 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; //--------------------------------------------------------- // Code for block or win 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. // If first move is to center then game will always be tie, // 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; //--------------------------------------------------------- // Return 5 X 9 array of characters //--------------------------------------------------------- dcl-proc f_FillGrid; dcl-pi *n char(9) dim(5); pBaseChar char(1) const; end-pi; dcl-s Line char(9) dim(5); 1b if pBaseChar = 'X'; Line = %list( 'xxx xxx': ' xxx xxx ': ' xxx ': ' xxx xxx ': 'xxx xxx'); 1x elseif pBaseChar = 'O'; Line = %list( ' ooooo ': ' oo oo ': 'oo oo': ' oo oo ': ' ooooo '); 1x elseif pBaseChar = 'T'; Line(*) = ' TTT '; Line(1) = 'TTTTTTTTT'; 1x elseif pBaseChar = 'I'; Line(*) = ' III '; Line(1) = ' IIIIIII '; Line(5) = ' IIIIIII '; 1x elseif pBaseChar = 'C'; Line = %list( ' CCCCC ': ' CCC ': 'CCC ': ' CCC ': ' CCCCC '); 1x elseif pBaseChar = 'A'; Line = %list( ' AAA ': ' AA AA ': 'AAAAAAAAA': 'AA AA': 'AA AA'); 1x elseif pBaseChar = 'E'; Line = %list( ' EEEEEE ': 'EE ': 'EEEEE ': 'EE ': ' EEEEEE '); 1e endif; return Line; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA05 CA12 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A GRID11ROW1 9A O 2 13DSPATR(&ATR11) A 2 25' ' COLOR(BLU) DSPATR(RI) A GRID12ROW1 9A O 2 29DSPATR(&ATR12) A 2 41' ' COLOR(BLU) DSPATR(RI) A GRID13ROW1 9A O 2 45DSPATR(&ATR13) A GRID11ROW2 9A O 3 13DSPATR(&ATR11) A 3 25' ' COLOR(BLU) DSPATR(RI) A GRID12ROW2 9A O 3 29DSPATR(&ATR12) A 3 41' ' COLOR(BLU) DSPATR(RI) A GRID13ROW2 9A O 3 45DSPATR(&ATR13) A 3 57'Welcome to TIC TAC TOE!' A DSPATR(&AWELCOME) A GRID11ROW3 9A O 4 13DSPATR(&ATR11) A 4 25' ' COLOR(BLU) DSPATR(RI) A GRID12ROW3 9A O 4 29DSPATR(&ATR12) A 4 41' ' COLOR(BLU) DSPATR(RI) A GRID13ROW3 9A O 4 45DSPATR(&ATR13) A GRID11ROW4 9A O 5 13DSPATR(&ATR11) A 5 25' ' COLOR(BLU) DSPATR(RI) A GRID12ROW4 9A O 5 29DSPATR(&ATR12) A 5 41' ' COLOR(BLU) DSPATR(RI) A GRID13ROW4 9A O 5 45DSPATR(&ATR13) A 5 57'PRESS ENTER TO BEGIN' A DSPATR(&AWELCOME) A GRID11ROW5 9A O 6 13DSPATR(&ATR11) A 6 25' ' COLOR(BLU) DSPATR(RI) A GRID12ROW5 9A O 6 29DSPATR(&ATR12) A 6 41' ' COLOR(BLU) DSPATR(RI) A GRID13ROW5 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 GRID21ROW1 9A O 10 13DSPATR(&ATR21) A 10 25' ' COLOR(BLU) DSPATR(RI) A GRID22ROW1 9A O 10 29DSPATR(&ATR22) A 10 41' ' COLOR(BLU) DSPATR(RI) A GRID23ROW1 9A O 10 45DSPATR(&ATR23) A GRID21ROW2 9A O 11 13DSPATR(&ATR21) A 11 25' ' COLOR(BLU) DSPATR(RI) A GRID22ROW2 9A O 11 29DSPATR(&ATR22) A 11 41' ' COLOR(BLU) DSPATR(RI) A GRID23ROW2 9A O 11 45DSPATR(&ATR23) A 11 57'You can win if you' DSPATR(&ANOTES) A GRID21ROW3 9A O 12 13DSPATR(&ATR21) A 12 25' ' COLOR(BLU) DSPATR(RI) A GRID22ROW3 9A O 12 29DSPATR(&ATR22) A 12 41' ' COLOR(BLU) DSPATR(RI) A GRID23ROW3 9A O 12 45DSPATR(&ATR23) A 12 57'start with center' DSPATR(&ANOTES) A GRID21ROW4 9A O 13 13DSPATR(&ATR21) A 13 25' ' COLOR(BLU) DSPATR(RI) A GRID22ROW4 9A O 13 29DSPATR(&ATR22) A 13 41' ' COLOR(BLU) DSPATR(RI) A GRID23ROW4 9A O 13 45DSPATR(&ATR23) A 13 57'X and O does not' DSPATR(&ANOTES) A GRID21ROW5 9A O 14 13DSPATR(&ATR21) A 14 25' ' COLOR(BLU) DSPATR(RI) A GRID22ROW5 9A O 14 29DSPATR(&ATR22) A 14 41' ' COLOR(BLU) DSPATR(RI) A GRID23ROW5 9A O 14 45DSPATR(&ATR23) A 14 57'start in a corner.' 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 16 13'----------------------------------- A -------' COLOR(BLU) A 17 25' ' COLOR(BLU) DSPATR(RI) A 17 41' ' COLOR(BLU) DSPATR(RI) A GRID31ROW1 9A O 18 13DSPATR(&ATR31) A 18 25' ' COLOR(BLU) DSPATR(RI) A GRID32ROW1 9A O 18 29DSPATR(&ATR32) A 18 41' ' COLOR(BLU) DSPATR(RI) A GRID33ROW1 9A O 18 45DSPATR(&ATR33) A GRID31ROW2 9A O 19 13DSPATR(&ATR31) A 19 25' ' COLOR(BLU) DSPATR(RI) A GRID32ROW2 9A O 19 29DSPATR(&ATR32) A 19 41' ' COLOR(BLU) DSPATR(RI) A GRID33ROW2 9A O 19 45DSPATR(&ATR33) A GRID31ROW3 9A O 20 13DSPATR(&ATR31) A 20 25' ' COLOR(BLU) DSPATR(RI) A GRID32ROW3 9A O 20 29DSPATR(&ATR32) A 20 41' ' COLOR(BLU) DSPATR(RI) A GRID33ROW3 9A O 20 45DSPATR(&ATR33) A GRID31ROW4 9A O 21 13DSPATR(&ATR31) A 21 25' ' COLOR(BLU) DSPATR(RI) A GRID32ROW4 9A O 21 29DSPATR(&ATR32) A 21 41' ' COLOR(BLU) DSPATR(RI) A GRID33ROW4 9A O 21 45DSPATR(&ATR33) A GRID31ROW5 9A O 22 13DSPATR(&ATR31) A 22 25' ' COLOR(BLU) DSPATR(RI) A GRID32ROW5 9A O 22 29DSPATR(&ATR32) A 22 41' ' COLOR(BLU) DSPATR(RI) A GRID33ROW5 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'F5=New Game' COLOR(BLU) ]]> '); //--------------------------------------------------------- // JCRGMYAT - Yahtzee //--------------------------------------------------------- /define ControlStatements /define psds /define Dspatr /define FunctionKeys /define f_GetRandom /define f_GetDayName /define f_RmvSflMsg /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGMYATD workstn infds(infds) indds(ind); dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s Color char(1); dcl-s DiceNum uns(3); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s row uns(3); dcl-s col uns(3); dcl-s Throw uns(3); dcl-s OriginalDice uns(3); dcl-s UserDice uns(3) dim(5) ascend; dcl-s FourDice uns(3) dim(4); dcl-s DropDice uns(3); dcl-s SumAllDots uns(3); dcl-s IsOneXed ind; dcl-s ThreeShots uns(3); dcl-s pCount uns(3); dcl-s TotGrandA char(3); dcl-ds SumDS; CalcSixes uns(3); CalcFives uns(3); CalcFours uns(3); CalcThrees uns(3); CalcTwos uns(3); CalcOnes uns(3); Calc3ofaKind uns(3); Calc4ofaKind uns(3); CalcFullHouse uns(3); CalcRunof4s uns(3); CalcRunof5s uns(3); CalcYahtzee uns(3); CalcChance uns(3); SumArry uns(3) dim(13) pos(1); end-ds; // array of what selections will score dcl-ds IsScoreDS; IsSixes ind; IsFives ind; IsFours ind; IsThrees ind; IsTwos ind; IsOnes ind; Is3ofaKind ind; Is4ofaKind ind; IsFullHouse ind; IsRunof4s ind; IsRunof5s ind; IsYahtzee ind; IsChance ind; IsScoreArry ind dim(13) pos(1); end-ds; // Protect already made selections dcl-s ProtectArry char(1) dim(13); // Total up selections dcl-ds TotalsDS; Tot6S; Tot5S; Tot4S; Tot3S; Tot2S; Tot1S; Tot3OfKind; Tot4OfKind; TotFullHou; Tot4InRow; Tot5InRow; TotYahtzee; TotChance; TotArry dim(13) pos(1) like(Tot6S); end-ds; // highlight selections that will score dcl-ds BucketAttrDS; A6SA; A5SA; A4SA; A3SA; A2SA; A1SA; A3OFA; A4OFA; AFULLA; A4ROWA; A5ROWA; AYAHA; aChanceA; BucketArryAtr char(1) dim(13) pos(1); end-ds; // highlight text of selections that will score dcl-ds TextAttrDS; A6SB; A5SB; A4SB; A3SB; A2SB; A1SB; A3OFB; A4OFB; AFULLB; A4ROWB; A5ROWB; AYAHB; aChanceB; TextArryAtr char(1) dim(13) pos(1); end-ds; // highlight totals of selections that will score dcl-ds TotAttrDS; A6SC; A5SC; A4SC; A3SC; A2SC; A1SC; A3OFC; A4OFC; AFULLC; A4ROWC; A5ROWC; AYAHC; aChanceC; TotArryAtr char(1) dim(13) pos(1); end-ds; // highlight ancillary text of selections that will score dcl-ds Text2AttrDS; A3OFD pos(7); A4OFD pos(8); AFULLD pos(9); A4ROWD pos(10); A5ROWD pos(11); AYAHD pos(12); aChanceD pos(13); Text2ArryAtr char(1) dim(13) pos(1); end-ds; // load selections into array for validity checking dcl-ds BucketsDS; Sel6S; Sel5S; Sel4S; Sel3S; Sel2S; Sel1S; Sel3OfKind; Sel4OfKind; SelFullHou; Sel4InRow; Sel5InRow; SelYahtzee; SelChance; xBucketArry char(1) dim(13) pos(1); end-ds; // dice outline Border attributes dcl-ds BorderADS; Border1A; Border2A; Border3A; Border4A; Border5A; BorderA char(1) dim(5) pos(1); end-ds; // Name screen indicators dcl-ds ind qualified; ScreenCtl ind pos(10); end-ds; // map screen fields into DS so pointers to data can overlay dcl-ds DiscardDS; Discard1; Discard2; Discard3; Discard4; Discard5; DiscardArry char(1) dim(5) pos(1); end-ds; // dice faces and attributes 3d array dcl-ds Rowx qualified template; col char(1) dim(3); end-ds; dcl-ds Face dim(5) qualified based(ptr1); row likeds(Rowx) dim(3); end-ds; dcl-s ptr1 pointer inz(%addr(s0111)); dcl-ds FaceAttr dim(5) likeds(Face) based(ptr2); dcl-s ptr2 pointer inz(%addr(s0111a)); // large roll counter and final total 2d array dcl-ds RollCnt dim(7) qualified based(ptr6); // large roll counter col char(1) dim(4); end-ds; dcl-s ptr6 pointer inz(%addr(C111)); dcl-ds RollCntA dim(7) likeds(RollCnt) based(ptr7); dcl-s ptr7 pointer inz(%addr(C111a)); dcl-ds LargeGrand10s dim(7) likeds(RollCnt) based(ptr8); // large grand 10s dcl-s ptr8 pointer inz(%addr(C211)); dcl-ds LargeGrand10sA dim(7) likeds(RollCnt) based(ptr9); dcl-s ptr9 pointer inz(%addr(C211a)); dcl-ds LargeGrand1s dim(7) likeds(RollCnt) based(ptr10); // large grand 1s dcl-s ptr10 pointer inz(%addr(C311)); dcl-ds LargeGrand1sA dim(7) likeds(RollCnt) based(ptr11); dcl-s ptr11 pointer inz(%addr(C311a)); // map screen fields into DS so arrays can manipulate values // Dice Faces dcl-ds *n; s0111; s0112; s0113; s0121; s0122; s0123; s0131; s0132; s0133; s0211; s0212; s0213; s0221; s0222; s0223; s0231; s0232; s0233; s0311; s0312; s0313; s0321; s0322; s0323; s0331; s0332; s0333; s0411; s0412; s0413; s0421; s0422; s0423; s0431; s0432; s0433; s0511; s0512; s0513; s0521; s0522; s0523; s0531; s0532; s0533; C111; C112; C113; C114; C121; C122; C123; C124; C131; C132; C133; C134; C141; C142; C143; C144; C151; C152; C153; C154; C161; C162; C163; C164; C171; C172; C173; C174; C211; C212; C213; C214; C221; C222; C223; C224; C231; C232; C233; C234; C241; C242; C243; C244; C251; C252; C253; C254; C261; C262; C263; C264; C271; C272; C273; C274; C311; C312; C313; C314; C321; C322; C323; C324; C331; C332; C333; C334; C341; C342; C343; C344; C351; C352; C353; C354; C361; C362; C363; C364; C371; C372; C373; C374; // dice face attributes s0111a; s0112a; s0113a; s0121a; s0122a; s0123a; s0131a; s0132a; s0133a; s0211a; s0212a; s0213a; s0221a; s0222a; s0223a; s0231a; s0232a; s0233a; s0311a; s0312a; s0313a; s0321a; s0322a; s0323a; s0331a; s0332a; s0333a; s0411a; s0412a; s0413a; s0421a; s0422a; s0423a; s0431a; s0432a; s0433a; s0511a; s0512a; s0513a; s0521a; s0522a; s0523a; s0531a; s0532a; s0533a; C111A; C112A; C113A; C114A; C121A; C122A; C123A; C124A; C131A; C132A; C133A; C134A; C141A; C142A; C143A; C144A; C151A; C152A; C153A; C154A; C161A; C162A; C163A; C164A; C171A; C172A; C173A; C174A; C211A; C212A; C213A; C214A; C221A; C222A; C223A; C224A; C231A; C232A; C233A; C234A; C241A; C242A; C243A; C244A; C251A; C252A; C253A; C254A; C261A; C262A; C263A; C264A; C271A; C272A; C273A; C274A; C311A; C312A; C313A; C314A; C321A; C322A; C323A; C324A; C331A; C332A; C333A; C334A; C341A; C342A; C343A; C344A; C351A; C352A; C353A; C354A; C361A; C362A; C363A; C364A; C371A; C372A; C373A; C374A; end-ds; //--------------------------------------------------------- scDow = f_GetDayName(); 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 in %list(f03 :f12); *inlr = *on; return; 1e endif; BorderA(*) = Green; exsr srNewStart; //--------------------------------------------------------- // Play the game 1b dow *on; 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; C fixerror tag 4b if ThreeShots = 3; snd-msg 'Select a section category'; 4e endif; 3e endif; write msgctl; exfmt screen; f_RmvSflMsg(ProgId); 3b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 3x elseif InfdsFkey = F05 or pCount = 13; exsr srNewStart; 2v leave; 3e endif; // See if any selection has been 'X'ed thus ending turn // If player tries to X multiple categories, use first X. 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; snd-msg 'Must select category after three rolls'; GO C goto fixerror 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 <> F05; 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; //--------------------------------------------------------- // 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; snd-msg 'Game Over - Press F5 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! //--------------------------------------------------------- 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 by the need // to remove one dice in hand from consideration. // Example 1 2 2 3 4 // 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. If first 2 match then last 3 must match // or first 3 match then last 2 must 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; 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; //--------------------------------------------------------- // Return 4 column X 7 row array of roll count number //--------------------------------------------------------- dcl-proc f_LoadRollCnt; dcl-pi *n char(4) dim(7); pBaseNum uns(3); end-pi; dcl-s Line char(4) dim(7); 1x if pBaseNum = 1; Line(*) = ' 1'; Line(1) = ' 11 '; Line(7) = ' 111'; 1x elseif pBaseNum = 2; line = %list( '222 ': ' 2': ' 2': ' 22 ': '2 ': '2 ': '2222'); 1x elseif pBaseNum = 3; line = %list( '333 ': ' 3': ' 3': ' 333': ' 3': ' 3': '333 '); 1x elseif pBaseNum = 4; line = %list( ' 44': ' 4 4': '4 4': '4444': ' 4': ' 4': ' 4'); 1x elseif pBaseNum = 5; line = %list( ' 555': '5 ': '5 ': '555 ': ' 5': ' 5': '555 '); 1x elseif pBaseNum = 6; line = %list( ' 666': '6 ': '6 ': '6666': '6 6': '6 6': ' 66 '); 1x elseif pBaseNum = 7; line = %list( '7777': ' 7': ' 7': ' 7 ': ' 7 ': '7 ': '7 '); 1x elseif pBaseNum = 8; line = %list( ' 88 ': '8 8': '8 8': ' 88 ': '8 8': '8 8': ' 88 '); 1x elseif pBaseNum = 9; line = %list( ' 999': '9 9': '9 9': ' 999': ' 9': ' 9': '9999'); 1x elseif pBaseNum = 0; Line(*) = '0 0'; Line(1) = ' 00 '; Line(7) = ' 00 '; 1e endif; return Line; end-proc; //--------------------------------------------------------- // Return 3 X 3 array of dice face //--------------------------------------------------------- dcl-proc f_LoadFace; dcl-pi *n char(3) dim(3); pBaseNum char(1) const; end-pi; dcl-s Line char(3) dim(3); 1b if pBaseNum = '6'; Line = %list('666':' ':'666'); 1x elseif pBaseNum = '5'; Line = %list('5 5':' 5 ':'5 5'); 1x elseif pBaseNum = '4'; Line = %list('4 4':' ':'4 4'); 1x elseif pBaseNum = '3'; Line = %list('3 ':' 3 ':' 3'); 1x elseif pBaseNum = '2'; Line = %list('2 ':' ':' 2'); 1x elseif pBaseNum = '1'; Line = %list(' ':' 1 ':' '); 1x elseif pBaseNum = 'Y'; Line = %list('Y Y':' Y ':' Y '); 1x elseif pBaseNum = 'A'; Line = %list(' A ':'A A':'A A'); 1x elseif pBaseNum = 'H'; Line = %list('H H':'HHH':'H H'); 1x elseif pBaseNum = 'T'; Line = %list('TTT':' T ':' T '); 1x elseif pBaseNum = 'Z'; Line = %list('ZZ ':' Z ':' ZZ'); 1e endif; return Line; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA12 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'YAHTZEE' COLOR(BLU) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) 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 2 72SYSNAME COLOR(BLU) 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'F5=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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> '); //--------------------------------------------------------- // JCRHEXCHR - display biton codes to produce hex characters. // decode integer counter into pseudo-binary bit for checking. // use %bitor biff to set screen character bits. // use C function _cvth to generate hex representations. //--------------------------------------------------------- /define ControlStatements /define BitMask /define Cvthc /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRHEXCHRD workstn sfile(sbfdta1: rrn); dcl-s rrn uns(3); dcl-s Base2Divisor uns(3); dcl-s BitOn uns(10); dcl-s Count uns(3); dcl-s CountWrk uns(3); //--------------------------------------------------------- rrn = 0; scDow = f_GetDayName(); 1b for Count = 65 to 254; scBinVal = x'00'; scBitOn = *blanks; CountWrk = Count; Base2Divisor = 128; //--------------------------------------------------------- 2b for BitOn = 0 to 7; 3b if %uns(CountWrk/Base2Divisor) = 1; //binary bit on 4b if BitOn = 0; scBinVal = %bitor(bit0: scBinVal); 4x elseif BitOn = 1; scBinVal = %bitor(bit1: scBinVal); 4x elseif BitOn = 2; scBinVal = %bitor(bit2: scBinVal); 4x elseif BitOn = 3; scBinVal = %bitor(bit3: scBinVal); 4x elseif BitOn = 4; scBinVal = %bitor(bit4: scBinVal); 4x elseif BitOn = 5; scBinVal = %bitor(bit5: scBinVal); 4x elseif BitOn = 6; scBinVal = %bitor(bit6: scBinVal); 4x elseif BitOn = 7; scBinVal = %bitor(bit7: scBinVal); 4e endif; 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; write sbfctl1; exfmt sfooter1; *inlr = *on; return; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT CA03 CA12 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(2) A *DS4 SFLLIN(2) A SFLPAG(95) SFLSIZ(285) A SFLDSP A SFLDSPCTL A N34 SFLEND(*MORE) A 1 2'JCRHEXCHR' COLOR(BLU) A 1 20'Hex/Bit Values To Produce Characte- A rs' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) 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) ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A PRINT CA03 CA12 A R SCREEN A 1 3'JCRHEX' COLOR(BLU) A 1 25'Hex To Decimal To Hex Convertor' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A SDEC 5Y 0B 4 5EDTCDE(4) A 4 12'num' A SHEX 5A B 7 5CHECK(RZ) A 7 12'hex' A MESSAGE 30A O 9 5DSPATR(HI) A 13 3'Enter number or hex value' A 23 5'F3=Exit' A COLOR(BLU) ]]> '); //--------------------------------------------------------- // JCRHEXR - hex to decimal to hex convertor // // The TCP/IP security exit program documentation shows // the hex values X'1803 etc.. for the various functions. Nice, as // as the exit program parameters are int(10) numbers. // // This program helps you translate the hex documentation to actual numbers. //--------------------------------------------------------- /define ControlStatements /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRHEXD workstn; dcl-s new uns(10); dcl-s work uns(10); dcl-s xx uns(3); dcl-s ss uns(3); dcl-s yy uns(10); dcl-s NextHex char(16) inz('123456789ABCDEF'); //--------------------------------------------------------- scDow = f_GetDayName(); 1b dow *on; exfmt screen; 2b if *inkc or *inkl; *inlr = *on; return; 2e endif; message = *blanks; 2b if sdec > 0; work = sdec; shex = '00000'; ss = 0; 3b for xx = 5 downto 1 by 1; yy = 16**(xx-1); ss += 1; new = %int(work / yy); 4b if new > 0; %subst(shex:ss:1) = %subst(NextHex:new:1); work -= (yy * new); 4e endif; 3e endfor; //------------------------------------------------- 2x elseif shex > *blanks; shex = %scanrpl(' ':'0':shex); 3b if %check('0'+NextHex:shex) > 0; message = 'Invalid Hex Character'; 1i iter; 3e endif; work = 0; ss = 0; 3b for xx = 5 downto 1 by 1; yy = 16**(xx-1); ss += 1; 4b if not(%subst(shex:ss:1) = '0'); new = %scan(%subst(shex:ss:1):NextHex); work += new * yy; 4e endif; 3e endfor; message = %triml(%editc(work:'1')); 2e endif; 1e enddo; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Rpg H,F,D to free') PARM KWD(RPG4MBR) TYPE(*NAME) MIN(1) + PROMPT('Input source member') PARM KWD(INFILE) TYPE(INFILE) PROMPT('Source file') INFILE: QUAL TYPE(*NAME) DFT(QRPGLESRC) QUAL TYPE(*NAME) DFT(*LIBL) SPCVAL((*LIBL)) + PROMPT('Library') PARM KWD(FREEMBR) TYPE(*NAME) MIN(1) PROMPT('New + source member to generate') PARM KWD(FREEFIL) TYPE(INFILE) PROMPT('Source file') ]]> .*-------------------------------------------------------------------- :P.Reads selected RPGLE source and generates new source member with H, F, and D specs converted to free format. :P.:HP2.Conversions::EHP2. :UL COMPACT. :LI.CLASS, DATFMT, PROCPTR, and TIMFMT are converted to datatype extensions. :LI.VARYING keyword removed and the VARCHAR datatype is used. :LI.*NEXT is removed if the overlay keyword is the data structure name. :LI.DS LEN is not allowed with extname. Will require change to extname object. :LI.*DELETE is added to the usage keyword if record is deleted in main or procedure. :LI.*+ or - lengths are now part of the data type extension, packed(1: +2). :LI.UDS requires DTAARA{{(name)} {*AUTO}. fixed column allowed IN and OUT with uds. Need to change *auto to *userctl if using these opcodes. :LI.Data area names are quoted and upper cased. :LI.Data area *VAR modifier is removed. These will not be quoted and upper cased. :LI.Continuation lines (+ and -) are reformatted as keywords are expanded/removed. :LI.Program described with EADD on output need to be E only after conversion. :LI.External names and record formats are wrapped in quotes. dcl-ds ScreenFieldDS extname(JCRFFDF) end-ds; is not valid unless JCRFFDF is a constant or a defined field name. :LI.Removes all /free and /end-free statements. :LI.H specs with embedded compiler directives will not be converted. :LI.Review embedded compiler directives in source member before conversion. Remove any OS version directives as after conversion will only run on v7 or better. Source with embedded directives should be reviewed after conversion as converter is not directive aware. :LI.If any constants, inz or *java objects are longer than 2048, scan/replace 2048 in jcrhfdr source and change size of last variable in FspecDS in JCRCMDSCPY before recompiling jcrgetfilr and jcrhfdr :EUL. :P.For the file reformat to work, the files must be available through the library list. Recommend compiling the source program first into qtemp to ensure all objects can be found at conversion run time. :EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRHFD/RPG4MBR'.Input source mbr - Help :XH3.Input source mbr(RPG4MBR) :P.Member whose source is to be used as input.:EHELP. :HELP NAME='JCRHFD/INFILE'.Source file - Help :XH3.Source file (INFILE) :P.Source file containing source program.:EHELP. :HELP NAME='JCRHFD/FREEMBR'.New source member to generate - Help :XH3.New source member to generate (FREEMBR) :P.Member name to be generated by utility. Do not use same member/source file and lib name as Input member!:EHELP. :HELP NAME='JCRHFD/FREEFIL'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRHFDR - Rpg H,F,D to free // Source lines with (columns 6 and 7 = blanks and columns 8 to 80 > *blanks) // are free format. Any columns 6 and 7 > *blanks are fixed column. // The program will deal with sets, find the starting rrn and ending // rrn of a structure, pass that to a function to find the set of each entity // inside that structure, then process the inner and outer sets. // // CLASS, DATFMT, PROCPTR, TIMFMT, and VARYING are converted to datatype extensions. // varying keyword is replaced with varchar datatype. // *next is removed if the overlay keyword is the data structure name. // ds len is not allowed with extname. Will require change to extname object. // *delete is added to the usage keyword if record is deleted in main or proc. // + or - lengths are now part of the data type extension, packed(1: +2). // uds requires DTAARA{{(name)} {*AUTO}. Fixed column allowed IN and OUT // with uds. Need to change *auto to *userctl if using these opcodes // data area names are quoted and upper cased. // data area *var modifier is removed. // continuation lines (+ and -) are reformatted as keywords are expanded/removed. // H specs with embedded compiler directives will not be converted. // Program described with EADD on output will need to be E only after conversion // // Review embedded compiler directives in the source // and remove any OS directives. aftermath will only run on v7 or better. // Conversion is not directive aware. // // If any constants, inz or *java objects longer that 2048, // scan replace 2048 with proper size, then change last field in // fspecds in jcrcmdscpy before recompiling jcrgetfilr and this program. // // This program is an exception to the general rule that functions should be // self-contained entities. Here procedures are used like subroutines. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); //------------------------------------------------ // rpgle source member input file //------------------------------------------------ dcl-f InputSrc disk(112) extfile(extIfile) extmbr(p_InMbr) usropn infds(Infds) block(*no); // block no so rrn will work dcl-ds InputDS len(112) qualified; CompileArry char(3) pos(13); SrcSeq zoned(6: 2) pos(1); SrcDat zoned(6: 0) pos(7); Src112 char(100) pos(13); Src74 char(74) pos(19); SrcComment char(20) pos(93); Src94 char(94) pos(19); SpecType char(1) pos(18); FileName char(10) pos(19); FieldName char(14) pos(19); Asterisk char(1) pos(19); Designation char(1) pos(30); // full, primary, second, etc.. RecordAddressType char(1) pos(46); dReservedWord char(8) pos(38); // *PROC, *ROUTINE, *FILE etc... dSdsExternal char(1) pos(34); // E for External dSdsType char(1) pos(35); // Sds or Uds dType char(3) pos(36); // s ds c pi pr dFromLen char(7) pos(38); dLen char(7) pos(45); dDataType char(1) pos(52); dDecimals char(2) pos(53); dKeyWords char(37) pos(56); end-ds; //------------------------------------------------ // new source member written out with free H,F and D specs //------------------------------------------------ dcl-f NewSrc disk(112) usage(*output: *update) extfile(extOfile) extmbr(p_OutMbr) usropn; dcl-ds OutDS len(112) inz qualified; SrcSeq zoned(6: 2) pos(1); SrcDat zoned(6: 0) pos(7); SrcOut char(100) pos(13); end-ds; /define Infds /define f_IsIgnoreLine /define Constants /define f_GetQual /define f_SndCompMsg /define f_IsCompileTimeArray /define f_GetDataTypeKeyWords /define f_GetInternalProcNames /define f_ReturnZeroIfBetweenQuotes /define f_ReturnZeroIfAfterComments /define f_EllipsisLoc /define FspecDS /define p_JCRGETFILR // *ENTRY /define p_JCRHFDR /COPY JCRCMDS,JCRCMDSCPY dcl-s UpSpec char(1); dcl-s IsH ind; dcl-s IsF ind; dcl-s IsD ind; dcl-s IsP ind; dcl-s IsCopyEndIf ind; dcl-s BigFirst uns(5); dcl-s BigLast uns(5); dcl-s LastGoodRrn uns(5); dcl-s IsFirstCompileTimeArray ind; dcl-s FileName char(10); dcl-s CSorDS char(3); dcl-s string varchar(94); dcl-s s7 char(7); dcl-s IsCompileArray ind; dcl-s IsFirstFile ind inz(*on); dcl-s JustWroteOne ind; dcl-s dFromLen like(InputDS.dFromLen); dcl-s dLen like(InputDS.dLen); dcl-s dDataType like(InputDS.dDataType); dcl-s dDecimals like(InputDS.dDecimals); dcl-s dReservedWord like(InputDS.dReservedWord); dcl-s dSdsType like(InputDS.dSdsType); dcl-s dSdsExternal like(InputDS.dSdsExternal); dcl-s dxname varchar(74); dcl-s dComment char(20); dcl-s StructureType like(InputDS.dType); dcl-s dFromLenUns uns(10); dcl-s dLenUns uns(10); dcl-s ApostropheCnt uns(5); dcl-s DimSize packed(9); dcl-s pEntityLast uns(5); // needed global definition for sameline end- dcl-s IsStructureName ind; dcl-s ds_Name varchar(74); dcl-s IsExclude ind; dcl-s IsLikeDS ind; // no end-ds dcl-s DefineDangler varchar(37); dcl-s CurrPrName char(74); dcl-s kw uns(5); // keyword start dcl-s kwstring varchar(2048); dcl-s dddkey char(2048); dcl-s dddpos uns(5); dcl-s dddcnt uns(5); dcl-s EntityKeyword varchar(2048) dim(100); dcl-s KeyCnt uns(3); dcl-s EndDash varchar(6); dcl-s Block varchar(74); dcl-s BlockLen uns(5); dcl-s BaseLen uns(3) inz(74); dcl-c up const('ABCDEFGHIJKLMNOPQRSTUVWXYZ'); //--------------------------------------------- // Prototypes to exclude // with V7 do not need prototypes for internal procedures //---------------------------------------------- dcl-ds ExcludePR qualified; Cnt uns(5); Arry char(74) dim(500); end-ds; //--------------------------------------------- // Keep up with the number values of any constants // that could be used on a dim statement. Use that value to calculate // the free field lengths. //---------------------------------------------- dcl-ds Constant dim(1000) qualified; Name char(74); Value packed(9); end-ds; dcl-s ConstantCnt uns(5); //--------------------------------------------------------- extIfile = f_GetQual(p_InFileQual); extOfile = f_GetQual(p_OutFileQual); IsFirstCompileTimeArray = *off; ExcludePR = f_GetInternalProcNames(p_InMbr: p_InFileQual); open NewSrc; open InputSrc; exsr srReadInput; close InputSrc; close NewSrc; f_SndCompMsg('Free H,F,D mbr ' +%trimr(p_OutMbr)+ ' generated.'); *inlr = *on; return; //--------------------------------------------- //--------------------------------------------- begsr srReadInput; read InputSrc InputDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(InputDS.CompileArry); IsCompileArray = *on; //--------------------------------------------------------------- // if the procedure ends at a compile time array // write the end-proc and reset the rrn to get the compile time array //--------------------------------------------------------------- 3b if not IsFirstCompileTimeArray; IsFirstCompileTimeArray = *on; 4b if IsP; f_PspecWrite(BigFirst:LastGoodRrn); IsP = *off; setgt LastGoodRrn InputSrc; read InputSrc InputDS; IsCompileArray = f_IsCompileTimeArray(InputDS.CompileArry); 4e endif; 3e endif; 2e endif; 2b if IsCompileArray; f_WriteAsIs(); 2x else; JustWroteOne = *off; string = %trimr(InputDS.Src74); 3b if not f_IsIgnoreLine(string); // save for procedures ending just before ** arrays LastGoodRrn = InfdsDbRrn; exsr srCheckEndOfStructure; 4b if not JustWroteOne; exsr srStartOfStructure; 4e endif; 3e endif; 3b if not(IsH or IsF or IsD or IsP or JustWroteOne); f_WriteAsIs(); 3e endif; 2e endif; read InputSrc InputDS; 1e enddo; //---------------------------------------------------------- // deal with copy books when the last line is /endif or // no other executable lines to provide event trigger for write. //---------------------------------------------------------- 1b if IsH or IsD or IsP or IsF; LastGoodRrn = InfdsDbRrn; IsCopyEndif = *off; 2b if %upper(InputDS.FieldName) = '/ENDIF'; IsCopyEndif = *on; LastGoodRrn = InfdsDbRrn - 1; 2e endif; 2b if IsH; f_HspecWrite(BigFirst:LastGoodRrn); 2x elseif IsF; f_FspecWrite(FileName); 2x elseif IsD; f_DspecWrite(BigFirst:LastGoodRrn); 2x elseif IsP; f_PspecWrite(BigFirst:LastGoodRrn); 2e endif; // now write last /endif 2b if IsCopyEndif; setgt LastGoodRrn InputSrc; read InputSrc InputDS; f_WriteAsIs(); 2e endif; 1e endif; endsr; //----------------------------------------------------- // Get if at end of structure // Structure constructions rely on DS or S or C Values to // to determine where structures start and stop. // Deal with continuation lines for ... long variable names // the first... can always be first rrn, but never that last of a group // and the check end of group ignores... lines //----------------------------------------------------- begsr srCheckEndOfStructure; UpSpec = %upper(InputDS.SpecType); 1b if UpSpec = 'D'; CSorDs = %upper(InputDS.dType); 1e endif; //--------------------------------------------- // cannot be after quote or in a quoted continuation string // d.... inz('+ // ... ') // also ... inside a structure are ignored // a ds // subf1... // which massively complicates things as // a ds // b... // s 1a // Skip ahead two records to see if at the end // of the DS structure or if b is a subfield of a. //--------------------------------------------- 1b if IsD; 2b if f_IsInEllipsis(InputDS.Src74); 3b dou not f_IsIgnoreLine(string); read InputSrc InputDS; 4b if %eof; 3v leave; 4e endif; string = %trimr(InputDS.Src74); 3e enddo; 2e endif; UpSpec = %upper(InputDS.SpecType); CSorDs = %upper(InputDS.dType); 2b if (UpSpec = 'D' and (CSorDS = 'C ' or CSorDS = 'S ' or CSorDS = 'PR ' or CSorDS = 'PI ' or CSorDS = 'DS ')) or UpSpec <> 'D'; f_DspecWrite(BigFirst:BigLast); JustWroteOne = *on; setgt BigLast InputSrc; IsD = *off; BigFirst = 0; BigLast = 0; 2e endif; //---------------------------------------------- 1x elseif IsF; 2b if (UpSpec ='F' and InputDS.FileName > *blanks) OR UpSpec <> 'F'; f_FspecWrite(FileName); JustWroteOne = *on; setgt BigLast InputSrc; IsF = *off; BigFirst = 0; BigLast = 0; 2e endif; //---------------------------------------------- 1x elseif IsH; 2b if UpSpec <> 'H'; f_HspecWrite(BigFirst:BigLast); JustWroteOne = *on; setgt BigLast InputSrc; IsH = *off; BigFirst = 0; BigLast = 0; 2e endif; //---------------------------------------------- 1x elseif IsP; f_PspecWrite(BigFirst:BigLast); JustWroteOne = *on; setgt BigLast InputSrc; IsP = *off; BigFirst = 0; BigLast = 0; 1e endif; endsr; //----------------------------------------------------- // Get start of structure //----------------------------------------------------- begsr srStartOfStructure; 1b if UpSpec = 'D'; IsD = *on; BigLast = InfdsDbRrn; 2b if BigFirst = 0; BigFirst = InfdsDbRrn; 3b if f_IsInEllipsis(InputDS.Src74); 4b dou not f_IsIgnoreLine(string); read InputSrc InputDS; 5b if %eof; 4v leave; 5e endif; string = %trimr(InputDS.Src74); BigLast = InfdsDbRrn; 4e enddo; 3e endif; 2e endif; //---------------------------------------------- 1x elseif UpSpec = 'F'; BigLast = InfdsDbRrn; IsF = *on; 2b if BigFirst = 0; BigFirst = InfdsDbRrn; FileName = InputDS.FileName; 2e endif; //---------------------------------------------- 1x elseif UpSpec = 'H'; IsH = *on; BigLast = InfdsDbRrn; 2b if BigFirst = 0; BigFirst = InfdsDbRrn; 2e endif; //---------------------------------------------- 1x elseif UpSpec = 'P'; IsP = *on; BigLast = InfdsDbRrn; 2b if BigFirst = 0; BigFirst = InfdsDbRrn; 3b if f_IsInEllipsis(InputDS.Src74); 4b dou not f_IsIgnoreLine(string); read InputSrc InputDS; 5b if %eof; 4v leave; 5e endif; string = %trimr(InputDS.Src74); BigLast = InfdsDbRrn; 4e enddo; 3e endif; 2e endif; 1e endif; endsr; //------------------------------ //------------------------------ // Now that keywords are parsed, fit best into 74 characters // Tempting to put a 2d cutting stock solution here // to get best fits, but that is something for another day. // For now, if next keyword will not fit in current line, // start a new line. //------------------------------- dcl-proc f_OutputBestFit; dcl-pi *n; base varchar(148); comment char(20); end-pi; dcl-s BlocksWrittenCnt uns(5); dcl-s KeyLen uns(5); dcl-s InLineLen uns(5); dcl-s SpaceLen uns(5); dcl-s EndColonLen uns(5); dcl-s cmnt varchar(24); BlockLen = 0; BlocksWrittenCnt = 0; KeyLen = 0; SpaceLen = 1; EndColonLen = 1; InLineLen = %len(EndDash); //---------------------------------------------------------- 1b if not f_IsFit(0:%len(Base)); OutDS.SrcOut = s7 + %subst(base:1:BaseLen); f_WriteFreeSpec(); base = %subst(base:BaseLen+1); 1e endif; 1b if comment > *blanks; cmnt = ' // ' + %trim(comment); 1e endif; //---------------------------------------------------------- // prime the pump to fall into fitter loop 1b if KeyCnt = 0; KeyCnt = 1; %len(EntityKeyword(1)) = 0; 1e endif; block = base + ' '; //--------------------------------------------------------------- 1b for kw = 1 to KeyCnt; BlockLen = %len(block); KeyLen = %len(EntityKeyword(kw)); //---------------------------------------------- // keyword will not fit, write out what is built so far //---------------------------------------------- 2b if not f_isFit(BlockLen: KeyLen + SpaceLen); // next block will fit in 74 3b if f_isFit(0: KeyLen + SpaceLen); OutDS.SrcOut = s7 + block + cmnt; BlocksWrittenCnt += 1; f_WriteFreeSpec(); %len(block) = 0; %len(cmnt) = 0; 3x else; EntityKeyword(kw) = f_ParseLongKeyword(EntityKeyword(kw)); 3e endif; 2e endif; //---------------------------------------------- block += EntityKeyword(kw) + ' '; 1e endfor; //----------------------------------------------------- // last one BlockLen = %len(block); %len(EndDash) = 0; // in line end 1b if IsStructureName = *on; endDash = f_BuildEndDash(); 1e endif; 1b If %len(EndDash) > 0; SpaceLen = 2; 1x else; SpaceLen = 1; 1e endif; 1b if not f_isFit(BlockLen: %len(endDash)+SpaceLen); OutDS.SrcOut = s7 + block + cmnt; f_WriteFreeSpec(); OutDS.SrcOut = s7 + enddash +';'; f_WriteFreeSpec(); 1x else; 2b if %len(enddash) = 0; OutDS.SrcOut = s7 + %trimr(block) + ';' + cmnt; 2x else; OutDS.SrcOut = s7 + %trimr(block) + ' ' + enddash + ';' + cmnt; 2e endif; f_WriteFreeSpec(); 1e endif; 1b if IsStructureName = *off; endDash = f_BuildEndDash(); 2b if %len(EndDash) > 0; OutDS.SrcOut = s7+ enddash + ';'; f_WriteFreeSpec(); 2e endif; 1e endif; return; end-proc; //--------------------------- //---------------------------------------------- // now start complex task of reparsing // continuation lines and breaking keywords on : // rule 1: quoted strings have to break inside the quotes // inz(+ // 'A'); is not valid. // inz('+ // A'); is valid. // Get keyword and the first quote+ on same line. //---------------------------------------------- dcl-proc f_ParseLongKeyword; dcl-pi *n varchar(2048); string varchar(2048); end-pi; dcl-s fq uns(5); dcl-s fStart uns(5); dcl-s fEnd uns(5); dcl-s fLen uns(5); dcl-s sLen uns(5); dcl-s HowMuchLeft uns(5); dcl-s NextStart uns(5); dcl-s RemainingSpaces uns(5); BlockLen = %len(block); RemainingSpaces = 0; fStart = 1; fq = %scan(qs:string); 1b if fq > 0; 2b if f_isFit(BlockLen: fq + 2); // load block with entity leaving room for - continuation RemainingSpaces = %len(block:*MAX) - BlockLen - 2; fEnd = RemainingSpaces; fLen = (fEnd -fStart); block = block + %subst(string:fStart:Flen) + '-'; OutDS.SrcOut = s7 + block; f_WriteFreeSpec(); %len(block) = 0; 2e endif; 1e endif; //------------------------------------------------------ // 'Consume' all of the keyword, except // return whatever will occupy the last line = block // so our outer loop in bestfit will continue parsing any // remaining keywords //------------------------------------------------------ slen = %len(string); 1b dow *on; NextStart = (fStart + Flen); HowMuchLeft = slen - NextStart; //--------------- 2b if HowMuchLeft < BaseLen; %len(block)=0; string = %subst(string:NextStart); return string; 2e endif; //--------------- flen = BaseLen - 3; block = %subst(string:NextStart:Flen) + '-'; OutDS.SrcOut = s7 + block; f_WriteFreeSpec(); fStart = NextStart; 1e enddo; end-proc; //--------------------------- //--------------------------- dcl-proc f_IsFit; dcl-pi *n ind; CurrLen uns(5) const; AddLen uns(5) const; end-pi; return ((Currlen + addlen) <= Baselen); end-proc; //--------------------------- //--------------------------- dcl-proc f_BuildEndDash; dcl-pi *n varchar(6); end-pi; dcl-s string varchar(6); %len(string) = 0; 1b if BigLast = pEntityLast and (StructureType = 'PR ' or StructureType = 'PI ' or (StructureType = 'DS ' and IsLikeDS = *off)); string = 'end-' + %trimr(%lower(StructureType)); 1e endif; return string; end-proc; //---------------------------------------------------- // global function to write as-is lines //---------------------------------------------------- dcl-proc f_WriteAsIs; 1b if %upper(InputDS.FieldName) = '/FREE' or %upper(InputDS.FieldName) = '/END-FREE'; 1x else; 2b monitor; OutDS.SrcDat = InputDS.SrcDat; 2x on-error; OutDS.SrcDat = 0; 2e endmon; OutDS.SrcSeq += .01; OutDS.SrcOut = InputDS.Src112; write NewSrc OutDS; 1e endif; end-proc; //---------------------------------------------------- // the *delete usage keyword on dcl-f has proven to be a major pain. // why IBM did not leave it *update is beyond me. // Call jcrgetfilr to return file list with associated delete flag //---------------------------------------------------- dcl-proc f_FspecWrite; dcl-pi *n; pName char(10); end-pi; dcl-s ff uns(5); dcl-s IsDelete ind; dcl-s fcomment char(20); dcl-s fNameCvt varchar(148); dcl-s UsageKeyWord char(32); dcl-s DeviceKeyWord char(14); dcl-s KeyedKeyword char(20); //-------------------------------- pName = %upper(pName); //-------------------------------- // program to load F and dcl-f into element per file //-------------------------------- 1b if IsFirstFile; callp p_JCRGETFILR( p_InMbr: p_InFileQual: FileCount: OnePerRcdFmt: FspecArry: CommentArry: PrNameArry: DeleteArry); IsFirstFile = *off; 1e endif; //-------------------------- // find this file name in returned file array //-------------------------- 1b for ff = 1 to FileCount; FspecDS = %upper(FspecArry(ff)); Fcomment = CommentArry(ff); 2b if FspecDS.Name = pName and PrNameArry(ff) = CurrPrName; //--------------------------------------------------------- //--------------------------------------------------------- // no free format for primary, secondary, table 3b if FspecDS.Designation in %list(' ':'F') and FspecDS.RecordAddressType in %list(' ':'A':'K'); IsDelete = (DeleteArry(ff) = 'Y'); // from jcrfilgetr exsr srFspecFree; 3x else; fNameCvt = fSpecDS.FixedFormat; f_ReParseKeywords('F':'0':fNameCvt:fComment:fSpecDS.KeyWords); 3e endif; //-------------------------- 1v leave; 2e endif; 1e endfor; return; //-------------------------- // finally! start building new F specs // The FSPEC array returned from JCRGETFILR has // one element per file. // 1-74 are the fixed column F spec from the program source // the remain string elements is all the keywords compressed // ***load commentarry into a field when file is found // ***then leave room on first line for //commentfield // reference RPG FREE manual.pdf on desk top //-------------------------- begsr srFspecFree; // DEVICE{(record-length)} DeviceKeyword = f_GetDevice( FspecDS.Device: FspecDS.RecordLength); // USAGE(*UPDATE: *DELETE: *OUTPUT) UsageKeyWord = f_GetUsage( FspecDS.FileType: FspecDS.Designation: FSpecDS.FileAddition: FspecDS.Device: IsDelete); // KEYED{(*CHAR: key-length)} KeyedKeyword = f_GetKeyed( FspecDS.LengthOfKeyedField: FspecDS.RecordAddressType: UsageKeyWord); fNameCvt = 'dcl-f ' + %trimr(FspecDS.Name); 1b if DeviceKeyword > *blanks; fNameCvt += ' ' + %trimr(DeviceKeyword); 1e endif; 1b if KeyedKeyword > *blanks; fNameCvt += ' ' + %trimr(KeyedKeyword); 1e endif; 1b if UsageKeyWord > *blanks; fNameCvt += ' ' + %trimr(UsageKeyWord); 1e endif; f_ReParseKeywords('F':'1':fNameCvt: fComment: fSpecDS.KeyWords); endsr; end-proc; //------------------------------ // do not lower case between apostrophes //------------------------------- dcl-proc f_MakeLowerCase; dcl-pi *n varchar(2048); string varchar(2048); end-pi; dcl-s aa uns(5); ApostropheCnt = 0; 1b for aa = 1 to %len(string); 2b if %subst(string:aa:1) = qs; ApostropheCnt += 1; 2e endif; 2b if %rem(ApostropheCnt: 2) = 0; %subst(string:aa:1) = %lower(%subst(string:aa:1)); 2e endif; 1e endfor; return string; end-proc; //------------------------------ // reference RPG FREE manual.pdf specifications section 5-39 //------------------------------ dcl-proc f_GetUsage; dcl-pi *n char(32); FileType char(1); Designation char(1); FileAddition char(1); Device char(7); IsDelete ind; end-pi; dcl-s string char(32); string = *blanks; //------------------------------- 1b if FileType = 'I' and Designation = 'F' and FileAddition = ' '; 2b if not(Device = 'DISK' or Device = 'SEQ' or Device = 'SPECIAL'); string = 'usage(*input)'; 2e endif; //------------------------------- 1x elseif FileType = 'I' and Designation = 'F' and FileAddition = 'A'; string = 'usage(*input: *output)'; //------------------------------- 1x elseif FileType = 'U' and Designation = 'F' and FileAddition = ' '; 2b if IsDelete; string = 'usage(*update: *delete)'; 2x else; string = 'usage(*update)'; 2e endif; //------------------------------- 1x elseif FileType = 'U' and Designation = 'F' and FileAddition = 'A'; 2b if IsDelete; string = 'usage(*update: *delete: *output)'; 2x else; string = 'usage(*update: *output)'; 2e endif; //------------------------------- 1x elseif FileType = 'O' and Designation = ' '; 2b if not(Device = 'PRINTER'); string = 'usage(*output)'; 2e endif; 1e endif; return string; end-proc; //------------------------------ //------------------------------ dcl-proc f_GetDevice; dcl-pi *n char(14); Device char(7) const; RecordLength char(5); end-pi; dcl-s string char(14); dcl-s LoDev like(Device); string = *blanks; LoDev = %lower(Device); 1b if LoDev = 'disk '; 2b if RecordLength <> *blanks; string = 'disk(' + %trim(RecordLength) +')'; 2e endif; 1x else; 2b if RecordLength <> *blanks; string = %trimr(LoDev) + '('+ %trim(RecordLength) +')'; 2x else; string = LoDev; 2e endif; 1e endif; return string; end-proc; //------------------------------ //------------------------------ dcl-proc f_GetKeyed; dcl-pi *n char(20); LengthOfKeyedField char(5); RecordAddressType char(1); Usage char(32); end-pi; dcl-s string char(20); string = *blanks; 1b if Usage = 'usage(*output)'; return string; 1e endif; 1b if RecordAddressType = 'K'; string = 'keyed'; 1x elseif RecordAddressType = 'A'; string = 'keyed(*char: ' + %trim(LengthOfKeyedField) + ')'; 1e endif; return string; end-proc; //------------------------------ // String everything together but break nothing across the end of a line // treat keywords as a entity - name( ) //------------------------------- dcl-proc f_ReParseKeywords; dcl-pi *n; SpecType char(1) const; IsFreeFspec ind const; base varchar(148); comment char(20); KeyWords char(2048); end-pi; dcl-s aa uns(5); dcl-s bb uns(5); dcl-s kwlen uns(5); dcl-s ParenthCnt uns(3); KeyCnt = 0; 1b if keywords > *blanks; kwstring = %trim(KeyWords); kwstring = f_MakeLowerCase(kwstring); kwlen = %len(kwstring); kw = 0; // keyword start //------------------------------ // rule: a single keyword entity is either a standalone keyword // or a keyword( ). get each keyword entity into a varlen string // to know how long it is when time comes to write // out specs. Ignore everything between quotes //------------------------------ 2b for kw = 1 to kwlen; // start of a new entity 3b if %subst(kwstring: kw: 1) > ' ' and %subst(kwstring: kw: 1)<> '(' and %subst(kwstring: kw: 1)<> ')'; // trick here: is the next position, following spaces, a character // for start of next keyword, or is the next character a '(' ? aa = kw; 4b dou %subst(kwstring: aa: 1) = ' ' or %subst(kwstring: aa: 1) = '(' or aa > kwlen; // last entity in list 5b if aa = kwlen; KeyCnt += 1; EntityKeyword(KeyCnt) = %subst(kwstring: kw); kw = kwlen; // exit big loop 4v leave; // exit inner loop 5e endif; aa += 1; // keyword keyword 5b if %subst(kwstring: aa: 1) = ' '; 6b dou %subst(kwstring: aa: 1) <> ' '; aa += 1; 6e enddo; 6b if %subst(kwstring: aa: 1) <> '('; KeyCnt += 1; EntityKeyword(KeyCnt) = %subst(kwstring: kw: (aa-kw)-1); kw = aa-1; // reset to start next keyword 4v leave; // exit inner loop 6x else; exsr srFindOuterParenth; 4v leave; // exit inner loop 6e endif; 5x elseif %subst(kwstring: aa: 1) = '('; exsr srFindOuterParenth; 4v leave; // exit inner loop //----------------------------------------------- 5e endif; 4e enddo; 3e endif; 2e endfor; 1e endif; 1b if SpecType <> 'X'; // skip write 1st pass reparse D specs 2b if IsFreeFspec; f_OutputBestFit(base:comment); //-------------------------------------------- // for fixedformat (Input Primary, Secondary, etc. // write out the fixed portion with the first of any // keywords, then write out a F spec per remaining keywords //-------------------------------------------- 2x else; OutDS.SrcOut = ' F' + base; 3b if KeyCnt > 0; %subst(OutDS.SrcOut:44) = EntityKeyword(1); 3e endif; 3b If comment > *blanks; %subst(OutDS.SrcOut:82) = comment; 3e endif; f_WriteFreeSpec(); 3b for kw = 2 to KeyCnt; OutDS.SrcOut = ' F'; %subst(OutDS.SrcOut:44) = EntityKeyword(kw); f_WriteFreeSpec(); 3e endfor; 2e endif; 1e endif; return; //-------------------------------------------- // a(b) or b ( c ) c('((())))))))') or inz(%addr(e)) // increment and decrement a count // of (=1 (=2 )=2 )=1 until find a )=count of 0 // ignoring anything inside quotes //-------------------------------------------- begsr srFindOuterParenth; ApostropheCnt = 0; ParenthCnt = 0; 1b for bb = aa to kwlen; 2b if %subst(kwstring: bb: 1) = qs; ApostropheCnt += 1; 2e endif; 2b if %rem(ApostropheCnt: 2) = 0; 3b if %subst(kwstring: bb: 1) = '('; ParenthCnt += 1; 3x elseif %subst(kwstring: bb: 1) = ')'; ParenthCnt -= 1; 4b if ParenthCnt = 0; // found last outer ) KeyCnt += 1; EntityKeyword(KeyCnt) = %subst(kwstring: kw: (bb-kw)+1); kw = bb; // reset to start next keyword LV leavesr; 4e endif; 3e endif; 2e endif; 1e endfor; endsr; end-proc; //--------------------------- //--------------------------- dcl-proc f_WriteFreeSpec; dcl-pi *n end-pi; OutDS.SrcDat = 0; OutDS.SrcSeq += .01; write NewSrc OutDS; end-proc; //---------------------------------------------------- // Passed in was the rrn range of the entire d spec structure. // // Break the structure down and process the discrete components. // ds, pi, pr will have a structure header (what type of structure and keywords) // then // retrieve discrete structure components (fields ) one at a time // // so D prname PR n // Header 1 // d name1 3a // discrete component 1 // d name2... // start of discrete component 2 // d 3a // d varying // end of discrete component 2 // --------- // s and c structures will only have a header // d name3 s 3u inz(19) // Header 1 //------------------------------------------------------------------ dcl-proc f_DspecWrite; dcl-pi *n; pFirst uns(5) const; pLast uns(5) const; end-pi; dcl-s FirstE uns(5); dcl-s LastE uns(5); dcl-s rrne uns(5); dcl-s string varchar(94); dcl-s dots uns(3); dcl-s IsE ind; dcl-s IsEntityName ind; Dots = 0; StructureType = *blanks; %len(dxname) = 0; //------------------------------------------------------ // as in the main code to get the rrn limits of the entire structure, // now parse out the limits of each entity in that structure. // pFirst and pLast define the range of the entire protype // eStart is the beginning of the namespace for this entity // Build the name of the entity, // then populate the structure with each of it's individual entities, // then extract each entity and the associated keywords. //------------------------------------------------------ IsEntityName = *on; IsStructureName = *on; 1b for rrne = pFirst to pLast; chain rrne InputSrc InputDS; string = %trimr(InputDS.Src74); 2b if not f_IsIgnoreLine(string); //----------------------------------------------------- // Get if at end of structure // Structure constructions rely on DS or S or C Values to // to determine where structures start and stop. // Deal with continuation lines for ... long variable names // the first... can always be first rrn, but never that last of a group // and the check end of group ignores... lines //----------------------------------------------------- UpSpec = %upper(InputDS.SpecType); 3b if UpSpec = 'D'; CSorDs = %upper(InputDS.dType); 3e endif; 3b if IsE and (CSorDS = 'C ' or CSorDS = 'S ' or CSorDS = 'PR ' or CSorDS = 'PI ' or CSorDS = 'DS ' or Inputds.FieldName > *blanks or Inputds.Dlen > *blanks or InputDS.dDataType > *blanks or f_IsInEllipsis(InputDS.Src74)); f_dCommonFields(FirstE:LastE); 4b if IsExclude; return; 4e endif; //reset file position as may have been moved chain rrne InputSrc InputDS; UpSpec = %upper(InputDS.SpecType); CSorDs = %upper(InputDS.dType); FirstE = 0; LastE = 0; IsE = *off; IsStructureName = *off; 3e endif; //----------------------------------------------------- // Get start of structure //----------------------------------------------------- 3b if UpSpec = 'D'; IsE = *on; LastE = rrne; 4b if FirstE = 0; //---------------------------------------- // Deal with ... to extract field name Dots = f_EllipsisLoc(InputDS.Src74); 5b if Dots = 0; dxname = %trim(%subst(InputDS.Src74:1:15)); 5x else; dxname = %trim(%subst(InputDS.Src74:1:Dots-1)); 5e endif; //---------------------------------------- 5b if f_IsInEllipsis(InputDS.Src74); 6b dou not f_IsIgnoreLine(string); rrne += 1; read InputSrc InputDS; 7b if %eof; 6v leave; 7e endif; string = %trimr(InputDS.Src74); LastE = rrne; 6e enddo; 5e endif; 5b if IsEntityName; StructureType = %upper(InputDS.dType); 5e endif; FirstE = rrne; 4e endif; IsEntityName = *off; 3e endif; 2x else; OutDS.SrcOut = InputDS.Src112; 3b monitor; OutDS.SrcDat = InputDS.SrcDat; 3x on-error; OutDS.SrcDat = 0; 3e endmon; OutDS.SrcSeq += .01; write NewSrc OutDS; 2e endif; 1e endfor; // get last one f_dCommonFields(FirstE:LastE); return; end-proc; //---------------------------- // some fairly ugly stuff here. First load the keywords // for the entity into an array and scan for // varying and like(+ -) and alter the data type and the // keywords to allow for varchar and like(field: -9) // *auto and quotes around non-var data structure and extnames //---------------------------- dcl-proc f_dCommonFields; dcl-pi *n; pEntityStart uns(5); MakeGlobalLast uns(5); end-pi; dcl-s aa uns(5); dcl-s xa uns(5); dcl-s start uns(5); dcl-s end uns(5); dcl-s namespace varchar(148); dcl-s charSize char(9); dcl-s SizeName char(74); dcl-s dnobase varchar(148); dcl-s rebuild char(2048); dcl-s IsFoundDtaaraKeyword ind; dcl-s IsFoundExtNameKeyword ind; //----------------------------------------- pEntityLast = MakeGlobalLast; ApostropheCnt = 0; %len(DefineDangler) = 0; dddkey = *blanks; dddpos = 1; dddcnt = 0; 1b if IsStructureName; IsLikeDS = *off; 1e endif; DimSize = 0; 1b for rrn = pEntityStart to pEntityLast; chain rrn InputSrc InputDS; 2b if rrn = pEntityStart; dFromLen = InputDS.dFromLen; dLen = InputDS.dLen; dDataType = %upper(InputDS.dDataType); dDecimals = InputDS.dDecimals; dSdsType = %upper(InputDS.dSdsType); dSdsExternal = %upper(InputDS.dSdsExternal); dReservedWord = InputDS.dReservedWord; dComment = *blanks; 3b if StructureType = 'PR '; //--------------------------------------------------------- // Use a one character field for a place // holder if my prototype has a like define. Do not // want to move that field name into the comments. // otherwise move any field names in the prototype to // the comments as the field name are replaced with *n. //--------------------------------------------------------- 4b if %len(dxname) > 1 and InputDS.dType = *blanks; dComment = dxname+' '+%triml(inputds.SrcComment); 4x else; 5b if inputds.SrcComment > *blanks; dComment = %triml(inputds.SrcComment); 5e endif; 4e endif; 3x else; 4b if inputds.SrcComment > *blanks; dComment = %triml(inputds.SrcComment); 4e endif; 3e endif; 2e endif; //----------------------------------------- // was doing great until strings inside quotes with + and - spacing. // Several keywords get extended to include quotes or the varying keyword // is replaced by varchar, it became impossible to retain original spacing // in the d specs. // now get the (' ') into one string so work can begin // on parsing it out as a standalone process. // Get all the other keywords into a single string to process // continuation lines as a object instead across spread across different records //----------------------------------------- string = %trimr(InputDS.Src74); 2b if not f_IsIgnoreLine(string) and InputDS.dKeyWords > *blanks; %subst(dddKey:dddpos:37) = InputDS.dKeyWords; dddpos += 37; dddcnt += 1; 2e endif; 1e endfor; dddkey = f_RemoveContinuationSpacing(dddcnt: dddkey); //------------------------------------------------------ // let the reparser do the heavy lifting of breaking keywords // into string elements, now // process all the things that change lengths and keyword formats //------------------------------------------------------ f_ReParseKeywords('X':'1': dnobase: dcomment: dddKey); //-------------------------------------- // special little section here to generate missing *auto and dtaara keywords IsFoundDtaaraKeyword = *off; // for uds to (*auto) conversions 1b if dSdsType = 'U'; 2b if KeyCnt = 0; KeyCnt = 1; EntityKeyword(1) = 'dtaara'; 2x else; 3b for aa = 1 to KeyCnt; 4b if %len(EntityKeyword(aa)) >= 6 and %subst(EntityKeyword(aa):1:6) = 'dtaara'; IsFoundDtaaraKeyword = *on; // for uds to (*auto) conversions 4e endif; 3e endfor; 3b if not IsFoundDtaaraKeyword; KeyCnt += 1; EntityKeyword(KeyCnt) = 'dtaara'; 3e endif; 2e endif; 1e endif; //--------------------------------------------------------- // generate ext keyword if extname keyword not found. // extra effort as the ext keyword has to appear before any // other keyword else will not compile // smurf //--------------------------------------------------------- IsFoundExtNameKeyword = *off; 1b if dSdsExternal = 'E'; 2b for aa = 1 to KeyCnt; 3b if %len(EntityKeyword(aa)) >= 7 and %subst(EntityKeyword(aa):1:7) = 'extname'; IsFoundExtNameKeyword = *on; 2v leave; 3e endif; 2e endfor; 2b if not IsFoundExtNameKeyword; 3b if KeyCnt = 0; KeyCnt = 1; EntityKeyword(1) = 'ext'; 3x else; // roll all keywords forward 1 position, then insert ext in first element 4b for aa = KeyCnt downto 1; EntityKeyword(aa+1) = EntityKeyword(aa); 4e endfor; EntityKeyword(1) = 'ext'; KeyCnt += 1; 3e endif; 2e endif; 1e endif; //--------------------------------------------------------- //-------------------------------------- 1b for aa = 1 to KeyCnt; rebuild=EntityKeyword(aa); 2b if rebuild = 'varying'; dDataType = 'V'; %len(EntityKeyword(aa))=0; 2x elseif %subst(rebuild:1:7) = 'procptr'; DefineDangler='(*proc)'; %len(EntityKeyword(aa))=0; 2x elseif %subst(rebuild:1:6) = 'dtaara'; IsFoundDtaaraKeyword = *on; EntityKeyword(aa) = f_ExtendDtaara(EntityKeyword(aa): dSdsType); 2x elseif %subst(rebuild:1:6) = 'datfmt'; exsr srLoadSuffix; %len(EntityKeyword(aa))=0; 2x elseif %subst(rebuild:1:6) = 'timfmt'; exsr srLoadSuffix; %len(EntityKeyword(aa))=0; 2x elseif dFromLen > *blanks and %subst(rebuild:1:4) = 'dim('; exsr srLoadDimSize; 2x elseif %subst(rebuild:1:6) = 'const('; exsr srLoadConstant; 2x elseif (%subst(rebuild:1:5) = 'like ' or %subst(rebuild:1:5) = 'like(' ) and (%scan('+': dLen) > 0 or %scan('-': dLen) > 0); EntityKeyword(aa) = f_ExtendLikeLength(EntityKeyword(aa): dLen); dlen = 'LIKEXXX'; 2x elseif %subst(rebuild:1:8) = 'packeven'; 2x elseif %subst(rebuild:1:8) = 'fromfile'; // do something here if a problem 2x elseif %subst(rebuild:1:5) = 'class'; // D MyString S O CLASS(*JAVA: java.lang.String ) // DCL-S MyString OBJECT(*JAVA: java.lang.String ); // // remove class keyword but let go as an entity for now. // it could require reparsing the string depending // on continuation lines. EntityKeyword(aa) = %subst(EntityKeyword(aa):6); // DefineDangler=%subst(EntityKeyword(aa):7); 2x elseif IsStructureName; 3b if %subst(rebuild:1:6) = 'likeds' or %subst(rebuild:1:7) = 'likerec'; IsLikeDS = *on; 3x elseif StructureType = 'DS ' and %subst(rebuild:1:7) = 'extname'; EntityKeyword(aa) = f_DsExtName(EntityKeyword(aa)); 3e endif; 2e endif; 1e endfor; KeyCnt = f_CompressBlankElements(KeyCnt); //------------------------------------------------------ //------------------------------------------------------ IsExclude = *off; 1b if StructureType = 'S ' or StructureType = 'C '; namespace = f_NameSpaceStandAlone(); 1x elseif StructureType = 'DS '; namespace = f_NameSpaceDataStructure(); 1x elseif StructureType = 'PR '; // internal procedures do not need prototypes 2b if ExcludePr.Cnt > 0 and %lookup(dxname: ExcludePr.Arry: 1: ExcludePr.Cnt) > 0; IsExclude = *on; return; 2e endif; namespace = f_NameSpaceProtoType(); 1x elseif StructureType = 'PI '; namespace = f_NameSpaceProcedureInterface(); 1e endif; // do some final DS work to get positional notation keywords 1b if StructureType = 'DS '; 2b if IsStructureName; ds_Name = %upper(dxname); 2e endif; 2b for aa = 1 to KeyCnt; EntityKeyword(aa) = f_PosNotation(ds_Name:EntityKeyword(aa)); 2e endfor; 1e endif; f_OutputBestFit(namespace:dcomment); return; //------------------------------- begsr srLoadSuffix; // find ( and ) start = %scan('(':rebuild: 6); end = %scan(')':rebuild: start); 1b if start > 0 and end > 0; DefineDangler= %subst(rebuild: start: (end-start)+1); 1e endif; endsr; //------------------------------- begsr srLoadDimSize; DimSize = 1; // just in case start = %scan('(':rebuild: 4); end = %scan(')':rebuild: start); 1b if start > 0 and end > start; SizeName = %trim(%subst(rebuild: start+1: (end-start)-1)); 2b if %check('0123456789': %trim(SizeName)) = 0; evalr charSize = '000000000' + %trim(SizeName); dimsize = %dec(charSize:9:0); 2x else; SizeName = %upper(SizeName); 3b if ConstantCnt > 0; xa = %lookup(SizeName: Constant(*).Name: 1: ConstantCnt); 4b if xa > 0; 5b if Constant(xa).Value > 0; dimsize = Constant(xa).Value; 5e endif; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //------------------------------- // Only care about the value for numeric constants that may be a DIM(xx) later //------------------------------- begsr srLoadConstant; start = %scan('(':rebuild: 3); end = %scan(')':rebuild: start); 1b if start > 0 and end > start; SizeName = %trim(%subst(rebuild: start+1: (end-start)-1)); 2b if %check('0123456789': %trim(SizeName)) = 0; evalr charSize = '000000000' + %trim(SizeName); ConstantCnt += 1; Constant(ConstantCnt).Name = %upper(dxname); Constant(ConstantCnt).Value = %dec(charSize:9:0); 2e endif; 1e endif; endsr; end-proc; //------------------------------------------------------ // in several instances, the keyword was removed // as in datfmt and timfmt keywords. // here compress out the 0 length keywords and reduce keycnt //----------------------------------------------------- dcl-proc f_CompressBlankElements; dcl-pi *n uns(3); pCnt uns(3); end-pi; dcl-s aa uns(3); dcl-s bb uns(3); 1b for aa = 1 to pCnt; 2b if %len(EntityKeyword(aa)) = 0; 3b for bb = aa to (Pcnt-1); EntityKeyword(bb) = EntityKeyword(bb+1); 3e endfor; pCnt -= 1; aa -= 1; 2e endif; 1e endfor; return pCnt; end-proc; //------------------------------- // Fixed column allows EXTNAME(File:RcdFmt:*Output) with no quotes. // free requires either a constant value defined before the extname or // that file and rcdfmt be upper cased and wrapped in quotes. // This is complicated as the constant could already // have quotes around either, both, or none of the values //------------------------------- dcl-proc f_DsExtName; dcl-pi *n varchar(2048); string varchar(2048); end-pi; dcl-s BigEnd uns(5); dcl-s curStart uns(5); dcl-s curEnd uns(5); dcl-s xx uns(3); dcl-s Build varchar(2048); dcl-ds *n; exFirst varchar(23); exSecond varchar(23); exThird varchar(23); exParms varchar(23) dim(3) pos(1); end-ds; CurStart = %scan('(':string: 3); BigEnd = %scan(')':string: CurStart); 1b if CurStart > 0 and BigEnd > CurStart; CurEnd = CurStart; // prime for the loop 2b for xx = 1 to 3; %len(exParms(xx)) = 0; 3b if CurEnd <> BigEnd; CurStart = CurEnd; CurEnd = f_exCurEnd(CurStart: BigEnd: string); exParms(xx) = f_exTearDown(Curstart: CurEnd: string); 3e endif; 2e endfor; //--------------------------------------- // now put back together //--------------------------------------- Build = 'extname(' + exFirst; 2b if %len(exSecond) > 0; Build = Build + ':' + exSecond; 3b if %len(exThird) > 0; Build = Build + ':' + exThird; 3e endif; 2e endif; Build += ')'; return build; 1x else; return string; 1e endif; end-proc; //--------------------------------------- // get current end of parameter //--------------------------------------- dcl-proc f_exCurEnd; dcl-pi *n uns(5); Start uns(5); BigEnd uns(5); string varchar(2048); end-pi; dcl-s cc uns(5); cc = %scan(':':string: start+1); 1b if cc = 0 or cc>BigEnd; return BigEnd; 1x else; return cc; 1e endif; end-proc; //--------------------------------------- // return extname parm value, quoted with no spaces //--------------------------------------- dcl-proc f_exTearDown; dcl-pi *n varchar(23); start uns(5); curend uns(5); string varchar(2048); end-pi; dcl-s Polished varchar(23); Polished = %subst(string: start+1: (CurEnd-start)-1); Polished = %trim(%scanrpl(qs:'': Polished)); Polished = %upper( Polished); 1b if polished = '*LDA' or (%subst(Polished:1:1) = '*' and %subst(Polished:1:2) <> '*L'); Polished = %lower(Polished); 1x else; Polished = qs + Polished + qs; 1e endif; return Polished; end-proc; //---------------------------------------------- // **** if second half of namespace is populated, write two lines **** // if will not fit in 74 (name too long) then load two halves //---------------------------------------------- dcl-proc f_NameSpaceStandAlone; dcl-pi *n varchar(148) end-pi; dcl-s dstring varchar(148); dcl-s longss char(148); 1b if Dlen = 'LIKEXXX'; dstring = 'dcl-s ' + dxname; 1x elseif StructureType = 'S ' and dLen = ' ' and dDataType = ' '; dlen = *blanks; dstring = 'dcl-s ' + dxname; 1x else; 2b monitor; dLenUns = %uns(dLen); 2x on-error; dLenUns = 0; 2e endmon; 2b if StructureType = 'S '; 3b if dDataType = ' ' and dLenUns > 0; 4b if dDecimals > *blanks; dDataType = 'P'; 4x else; dDataType = 'A'; 4e endif; 3e endif; //------------------------------------ dstring = 'dcl-s ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); //-------------------------------------------- 3b if %len(dstring) > 74; // too long; longss = 'dcl-s ' + dxname; %subst(longss:75) = %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); dstring = %trimr(longss); 3e endif; //-------------------------------------------- 2x elseif StructureType = 'C'; dstring = 'dcl-c ' + dxname; 2e endif; 1e endif; return dstring; end-proc; //---------------------------------------------- // **** if second half of namespace is populated, write two lines **** // if will not fit in 74 (name too long) then load two halves // one section is for IsStructureName. then not IsStructureName // for all the subfields in that structure; //---------------------------------------------- dcl-proc f_NameSpaceProtoType; dcl-pi *n varchar(148) end-pi; dcl-s dstring varchar(148); dcl-s longss char(148); 1b if Dlen = 'LIKEXXX'; 2b if IsStructureName; dstring = 'dcl-pr ' + dxname; 2x else; dstring = ' *n'; 2e endif; 1x elseif dLen = ' ' and dDataType = ' '; dlen = *blanks; 2b if IsStructureName; dstring = 'dcl-pr ' + dxname; 2x else; dstring = ' *n'; 2e endif; 1x else; 2b monitor; dLenUns = %uns(dLen); 2x on-error; dLenUns = 0; 2e endmon; 2b if dDataType = ' ' and dLenUns > 0; 3b if dDecimals > *blanks; dDataType = 'P'; 3x else; dDataType = 'A'; 3e endif; 2e endif; //------------------------------------ 2b if IsStructureName; dstring = 'dcl-pr ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2x else; dstring = ' *n ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2e endif; //-------------------------------------------- 2b if %len(dstring) > 74; // too long; 3b if IsStructureName; longss = 'dcl-pr ' + dxname; 3x else; longss = ' *n '; 3e endif; %subst(longss:75) = %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); dstring = %trimr(longss); 2e endif; //-------------------------------------------- 1e endif; return dstring; end-proc; //---------------------------------------------- // sds converts to psds and predefined subfields look like this // DCL-DS pgm_stat PSDS; // status *STATUS; // routine *ROUTINE; // END-DS; //---------------------------------------------- dcl-proc f_NameSpaceDataStructure; dcl-pi *n varchar(148) end-pi; dcl-s dstring varchar(148); dcl-s longss char(148); dcl-s dummyup varchar(37); dcl-s len1 uns(3); dcl-s len2 uns(3); dcl-s len3 uns(3); 1b if %len(dxname) = 0; dxname = '*n'; 1e endif; 1b if Dlen = 'LIKEXXX'; 2b if IsStructureName; dstring = 'dcl-ds ' + dxname; 2x else; dstring = ' ' + dxname; 2e endif; 1x elseif %subst(dReservedWord:1:1) = '*'; dstring = ' ' + dxname + ' ' + %trim(dReservedWord); 1x elseif dLen = ' ' and dDataType = ' '; dlen = *blanks; 2b if IsStructureName; dstring = 'dcl-ds ' + dxname; 2x else; dstring = ' ' + dxname; 2e endif; 1x else; 2b monitor; dLenUns = %uns(dLen); 2x on-error; dLenUns = 0; 2e endmon; 2b monitor; dFromLenUns = %uns(dFromLen); 2x on-error; dFromLenUns = 0; 2e endmon; //------------------------------------------------------------------ // Convert from/to notation to datatype() and // pos() notation. Already have code to convert overlay(:) // to pos so dummy up a overlay(data structure name:from) // keyword and let the f_PosNotation function do the dirty work. //------------------------------------------------------------------ 2b if dFromLenUns > 0; 3b if not(dDataType = 'G' or dDataType = 'O'); dLenUns = (dLenUns - dFromLenUns) + 1; 4b if dDataType = ' '; 5b if dDecimals > *blanks; dDataType = 'S'; 5x else; dDataType = 'A'; 5e endif; 4x elseif dDataType = 'B'; dDataType = 'I'; 5b if dLenUns = 2; dLenUns = 5; 5x elseif dLenUns = 4; dLenUns = 10; 5e endif; 4x elseif dDataType = 'I' or dDataType = 'U'; 5b if dLenUns = 1; dLenUns = 3; 5x elseif dLenUns = 2; dLenUns = 5; 5x elseif dLenUns = 4; dLenUns = 10; 5x elseif dLenUns = 8; dLenUns = 20; 5e endif; 4x elseif dDataType = 'P'; dLenUns = (2 * dLenUns) - 1; 4e endif; 4b if DimSize > 0; dLenUns /= DimSize; 4e endif; dummyup = 'OVERLAY('+ds_name+':'+ %trimr(%char(dFromLenUns)) + ')'; 4b if KeyCnt > 0; len1 = %len(EntityKeyword(KeyCnt)); len2 = %len(dummyup); len3 = %len(EntityKeyword(1)); 4e endif; // see if pos will fit on same line 4b if KeyCnt > 0 and ((len1 + len2 + 1) <= len3); EntityKeyword(KeyCnt) = %trimr(EntityKeyword(KeyCnt)) +' '+ dummyup; 4x else; KeyCnt += 1; EntityKeyword(KeyCnt) = dummyup; 4e endif; 3e endif; 2e endif; //------------------------------------------------------------------ 2b if dDataType = ' ' and dLenUns > 0; 3b if dDecimals > *blanks; dDataType = 'S'; 3x else; dDataType = 'A'; 3e endif; 2e endif; //------------------------------------ // data structures data types are len() so pass arbitrary // & character so function will return len() instead of char() 2b if IsStructureName; dDataType = '&'; dstring = 'dcl-ds ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2x else; dstring = ' ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2e endif; //-------------------------------------------- 2b if %len(dstring) > 74; // too long; 3b if IsStructureName; longss = 'dcl-ds ' + dxname; dDataType = '&'; 3x else; longss = ' ' + dxname; 3e endif; %subst(longss:75) = %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); dstring = %trimr(longss); 2e endif; 1e endif; 1b if IsStructureName and (dSdsType = 's' or dSdsType = 'S'); 2b if (dSdsExternal = 'e' or dSdsExternal='E'); dstring += ' ext PSDS'; 2x else; dstring += ' PSDS'; 2e endif; 1e endif; return dstring; end-proc; //---------------------------------------------- //---------------------------------------------- dcl-proc f_NameSpaceProcedureInterface; dcl-pi *n varchar(148) end-pi; dcl-s dstring varchar(148); dcl-s longss char(148); 1b if %len(dxname) = 0; dxname = '*n'; 1e endif; 1b if Dlen = 'LIKEXXX'; 2b if IsStructureName; dstring = 'dcl-pi ' + dxname; 2x else; dstring = ' ' + dxname; 2e endif; 1x elseif dLen = ' ' and dDataType = ' '; dlen = *blanks; 2b if IsStructureName; dstring = 'dcl-pi ' + dxname; 2x else; dstring = ' ' + dxname; 2e endif; 1x else; 2b monitor; dLenUns = %uns(dLen); 2x on-error; dLenUns = 0; 2e endmon; 2b if dDataType = ' ' and dLenUns > 0; 3b if dDecimals > *blanks; dDataType = 'P'; 3x else; dDataType = 'A'; 3e endif; 2e endif; //------------------------------------ 2b if IsStructureName; dstring = 'dcl-pi ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2x else; dstring = ' ' + dxname + ' ' + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); 2e endif; //-------------------------------------------- 2b if %len(dstring) > 74; // too long; 3b if IsStructureName; longss = 'dcl-pi ' + dxname; 3x else; longss = ' ' + dxname; 3e endif; %subst(longss:75) = %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( dDataType: dLenUns: dDecimals:DefineDangler))); dstring = %trimr(longss); 2e endif; //-------------------------------------------- 1e endif; return dstring; end-proc; //---------------------------------------------------- // Reformat continuation lines as keywords were expanded // or contracted. This function removes the + and minus - sign continuation // while adjusting the string so the desired spacing is retained. // 'extproc(*java : aclass ' // ' : 'getSmack') // converts to // 'extproc(*java:aclass:'getSmak') // // When time comes to write this back out, may // have to split on a : or reassign + - continuation spacing. //---------------------------------------------------- dcl-proc f_RemoveContinuationSpacing; dcl-pi *n char(2048); LoopCnt uns(5); pstring char(2048); end-pi; dcl-s block char(37) based(bptr); dcl-s aa uns(5); dcl-s slampos uns(5); dcl-s NewString varchar(2048); 1b if LoopCnt = 0; return pstring; 1e endif; %len(NewString) = 0; bptr = %addr(pstring); newstring = %trim(block); 1b for aa = 2 to LoopCnt; bptr += 37; slampos = %len(newstring); 2b if %subst(newstring:slampos:1) = '+'; %len(newstring) -= 1; // drop + newstring += %trim(block); 2x elseif %subst(newstring:slampos:1) = '-'; %len(newstring) -= 1; // drop - newstring += %trimr(block); 2x else; newstring = newstring + ' ' + %trimr(block); 2e endif; 1e endfor; return newstring; end-proc; //-------------------------------------------------- // if the overlay name is the same as the ds name, // get positional notation. // EntityKeyword(XX) = overlay(GetAllocSizeDS:5) // would change to pos(5) // if not same name, then leave overlay notation // Watch out for between quotes and ignore those //-------------------------------------------------- dcl-proc f_PosNotation; dcl-pi *n varchar(2048); pDsName varchar(74); pString varchar(2048); end-pi; dcl-s loc uns(3); dcl-s xx uns(3); dcl-s string varchar(94); dcl-s comparestring varchar(74); dcl-s OvrEnd uns(3); dcl-s ColonPos uns(3); dcl-s NextKeyWord uns(3); dcl-s EndCap varchar (10); string = %trimr(%upper(pString)); Loc = %scan('OVERLAY(':string); 1b if loc > 0; Loc = f_ReturnZeroIfBetweenQuotes(Loc:string); 2b if loc > 0; // extract the overlay name (name:2) // watch out for (name), change these to POS(1) xx = %scan(':': string: loc+8); 3b if xx = 0; xx = %scan(')': string: loc+8); 3e endif; 3b if xx = 0; return pstring; 3x else; comparestring = %trim(%subst(string: loc+8: xx-(loc+8))); 4b if comparestring = pDsName; exsr srgetpositionalnotation; 4e endif; 3e endif; //------------------------------------------ 2e endif; 1e endif; pstring = %trim(pstring); return pstring; // inz overlay(GetAllocSizeDS:5) aaa = inz pos(5) aaa // remove overlay, remove name, remove : // loc and OvrEnd is my range begsr srgetpositionalnotation; OvrEnd = %scan(')': pString: loc+8); ColonPos = %scan(':': Pstring: loc+8); 1b if ColonPos > OvrEnd; ColonPos = 0; 1e endif; 1b if ColonPos = 0; EndCap = '1)'; 1x else; EndCap = %subst(pstring: ColonPos+1: (OvrEnd-Colonpos)); 1e endif; 1b if %scan('*NEXT': %upper(EndCap)) > 0; %len(pstring) = 0; return pstring; 1e endif; %subst(pstring: Loc: (OvrEnd-Loc)+1) = 'pos('+EndCap; // now go back and compress out any spaces between the end cap // and the next keyword xx = %scan(')': pString: loc); NextKeyWord = %check(' ':pstring:xx+1); 1b if NextKeyWord > 0; %subst(pstring: xx + 2) = %subst(pstring: NextKeyWord); 1e endif; endsr; end-proc; //---------------------------------------------------- // Output from +len or -len is second parm of like keyword // and cannot have spaces between the + and number // '+ 1' is not valid. +1 is valid. //---------------------------------------------------- dcl-proc f_ExtendLikeLength; dcl-pi *n varchar(2048); string varchar(2048); len char(7); end-pi; dcl-s cpar uns(5); // close parenth dcl-s compressedlen varchar(7); compressedlen = %scanrpl(' ':'': len); cpar = %scan(')':string:5); %subst(string:cpar) = ':'; string = string + compressedlen + ')'; return string; end-proc; //---------------------------------------------------- // Dtaara(*VAR : runtimeDA) - dtaara(runtimeDA) // Dtaara(runtimeDA) - dtaara('RUNTIMEDA') // uds dtaara(TESTX73) - dtaara(*auto: 'TESTX73') // uds dtaara(*lda) - dtaara(*auto: *LDA); // uds - dtaara(*auto) // uds dtaara - dtaara(*auto) // Dtaara - dtaara //---------------------------------------------------- dcl-proc f_ExtendDtaara; dcl-pi *n varchar(2048); string varchar(2048); uds char(1); end-pi; 1b if uds = 'U'; //-------------------------------- 2b if string = 'dtaara'; string = string + '(*auto)'; return string; //-------------------------------- 2x elseif %scan('dtaara':string) = 0; string = 'dtaara(*auto) ' + string; return string; //-------------------------------- 2x elseif %scan('*lda':string) > 0 and %scan('*auto':string) = 0; string = %scanrpl('*lda':'*auto: *lda':string); return string; //-------------------------------- 2x elseif %scan('*var':string) > 0; string = %scanrpl('*var':'*auto':string); // replace *var return string; //-------------------------------- 2x elseif %scan('*auto':string) = 0; string = %scanrpl('(':'(*auto: ':string); // add *auto 2e endif; 1e endif; //-------------------------------- 1b if %scan('*var':string) > 0; string = %scanrpl('*var':'': string); // get rid of *var string = %scanrpl(':':'': string); // get rid of : string = %scanrpl(' ':'': string); // remove : space return string; 1e endif; //-------------------------------- 1b if string <> 'dtaara'; string = %scanrpl('extname(':'dtaara(':f_DsExtName(string)); 1e endif; return string; end-proc; //---------------------------------------------------- // Write DCL-PROC END-PROC statements //---------------------------------------------------- dcl-proc f_PspecWrite; dcl-pi *n; pFirst uns(5); pLast uns(5); end-pi; dcl-s keywords char(2048); dcl-s rrn uns(5); dcl-s pcomment char(20); dcl-s string varchar(94); dcl-s pstring varchar(148); dcl-s dots uns(3); dcl-s prNameSpace varchar(74); Dots = 0; StructureType = *blanks; %len(prNameSpace) = 0; //------------------------------------------------------ // get the P NAME or NAME... // If ... start getting attributes at the next record. //------------------------------------------------------ // build keyword string. 1b for rrn = pFirst to pLast; chain rrn InputSrc InputDS; string = %trimr(InputDS.Src74); 2b if not f_IsIgnoreLine(string); 3b if rrn = pFirst; Dots = f_EllipsisLoc(InputDS.Src74); // Deal with ... to extract field name 4b if Dots = 0; prNameSpace = %trim(%subst(InputDS.Src74:1:15)); exsr srpCommonFields; 4x else; prNameSpace = %trim(%subst(InputDS.Src74:1:Dots-1)); 4e endif; CurrPrName = %upper(prNameSpace); // for file arry match 3x elseif (rrn = pFirst + 1) and Dots > 0; exsr srpCommonFields; 3x else; KeyWords = %trimr(Keywords) + ' ' + %triml(InputDS.dKeyWords); 3e endif; 2e endif; 1e endfor; //------------------------------------------------------------------ 1b if StructureType = 'B'; pstring = 'dcl-proc ' + prNameSpace; 1x elseif structureType = 'E'; pstring = 'end-proc'; 1e endif; f_ReParseKeywords('P':'1': pstring: pcomment: KeyWords); return; //---------------------------- begsr srpCommonFields; StructureType = %upper(InputDS.dType); KeyWords = ' ' + %triml(InputDS.dKeyWords); pComment = inputds.SrcComment; endsr; end-proc; //---------------------------------------------------- // get all H specs into a string, then call reparse to compress // to full line use. // unless hspec has compiler directive, then just write back out as-is // ....5...10...15...20. // /IF DEFINED(*V6R1M0) // /ELSE // /ENDIF //---------------------------------------------------- dcl-proc f_HspecWrite; dcl-pi *n; pFirst uns(5); pLast uns(5); end-pi; dcl-s keywords char(2048); dcl-s rrn uns(5); dcl-s ctlopt varchar(148) inz('ctl-opt'); dcl-s hcomment char(20); dcl-s string varchar(94); // check for embedded compiler directives 1b for rrn = pFirst to pLast; chain rrn InputSrc InputDS; 2b if f_CompilerDirective(InputDS.Src74); 3b for rrn = pFirst to pLast; chain rrn InputSrc InputDS; f_WriteAsIs(); 3e endfor; return; 2e endif; 1e endfor; // build keyword string. 1b for rrn = pFirst to pLast; chain rrn InputSrc InputDS; string = %trimr(InputDS.Src74); 2b if not f_IsIgnoreLine(string); KeyWords = %trimr(keywords) + ' ' + %triml(InputDS.Src74); 3b if hcomment = *blanks; hcomment = inputds.SrcComment; 3e endif; 2e endif; 1e endfor; f_ReParseKeywords('H':'1': CtlOpt: Hcomment: KeyWords); return; end-proc; //------------------------------------------------------------------ // return *on if ... is not between ( ) like inz('...') //------------------------------------------------------------------ dcl-proc f_IsInEllipsis export; dcl-pi *n ind; string char(74); end-pi; // ignore ... in the keywords section 1b if %len(%trimr(string)) > 35 and %subst(string:1:35) = *blanks; return *off; 1e endif; 1b If %scan('...':string) > 0 and (%scan('(':string) = 0 or %scan('...':string) < %scan('(':string)); return *on; 1x else; return *off; 1e endif; end-proc; //---------------------------------------------------- // see if compiler directives are contained in entity // ....5...10...15...20. // /IF DEFINED(*V6R1M0) // /ELSE // /ENDIF //---------------------------------------------------- dcl-proc f_CompilerDirective; dcl-pi *n ind; pstring char(74); end-pi; dcl-s string char(74); string =%triml(%upper(pstring)); 1b if %subst(string:1:1) = '/' and %check(up: %subst(string:2:1)) =0; return *on; 1x else; return *off; 1e endif; end-proc; ]]> '); //--------------------------------------------------------- // JCRHFDV - Validity checking program for lib/file/member //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_IsValidSrcType /define f_IsSameMbr /define f_SrcFileAddPfm /define f_SndEscapeMsg // *ENTRY /define p_JCRHFDR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_InFileQual: p_InMbr: 'RPGLE': 'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_InMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; f_CheckObj(p_OutFileQual: '*FILE'); 1b if f_IsSameMbr(p_InFileQual: p_InMbr: p_OutFileQual: p_OutMbr); f_SndEscapeMsg('Input file/lib/mbr cannot + be same as New file/lib/mbr name.'); 1e endif; f_SrcFileAddPfm(p_OutFileQual: p_OutMbr: ' ': ' ': p_InFileQual: p_InMbr); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Copy from IFS directory') PARM KWD(PATHNAME) TYPE(*CHAR) LEN(50) + DFT('/rutledgec/') PGM(*YES) PROMPT('IFS Path') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA12 A R SBFDTA1 SFL A HIDEXTEN 10A H A HIDFILENAM 40A H A SBFOPTION 1Y 0B 6 3EDTCDE(4) A DIRNAME 50A O 6 7 A OBJTYPE 11A O 6 58 A SBFACTION 8A O 6 71 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0048) A *DS4 SFLSIZ(0048) A *DS3 SFLPAG(0016) A *DS4 SFLPAG(0016) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRIFSCPY' A COLOR(BLU) A 1 23'Copy from IFS directory' A COLOR(WHT) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A 2 2'Path' A COLOR(BLU) A PATHHEAD 50A O 2 7DSPATR(UL) A 2 72SYSNAME A COLOR(BLU) A 4 3'1=Copy To Stream File' A COLOR(BLU) A 4 26'2=XMLPreview Install' A COLOR(BLU) A 5 2'Opt' A DSPATR(HI) A DSPATR(UL) A 5 7'IFS File Name - A ' A DSPATR(HI) A DSPATR(UL) A 5 58'Type' A DSPATR(HI) A DSPATR(UL) A 5 71'Action' A DSPATR(HI) A DSPATR(UL) *---------------------------------------------------------------- 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(1) SFLSIZ(2) 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(1) SFLSIZ(2) 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(1) SFLSIZ(2) A WINDOW(WINDOW2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Lists directory entries in selected IFS directory name. Select cpyfrmstmf or select xmlpreview as an easy utility install method.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRIFSCPY/PATHNAME'.IFS Path Name - Help :XH3.IFS Path Name (PATHNAME) :P.IFS path name to directory entries.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRIFSCPYR - Copy from IFS directory // Use 'Unix-API's to retrieve IFS directory entries. // 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 be used to upload to data files. In that // case, check max number of members allowed. If only 1, // then overlay member name in upload prompt with data files member. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRIFSCPYD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define FunctionKeys /define Ind /define psds /define f_Runcmd /define f_IsValidObj /define OpenCloseDir /define f_RmvSflMsg /define f_BuildString /define f_SndCompMsg /define f_SndStatMsg /define f_GetDayName /define Qdbrtvfd /define f_Qusrmbrd // *ENTRY /define p_JCRIFSCPYR /COPY JCRCMDS,JCRCMDSCPY dcl-s errFlag int(10); dcl-s dirName char(50); dcl-s EntryName char(1024); dcl-s stringv varchar(500); dcl-s IsSecondTime ind; dcl-s TempName char(16) based(pTempName); // structure must be aligned since C struct does NOT have _Packed dcl-ds d_dirEnt based(pDirEnt) align; // d_Reserved1 char(16); d_Fileno_id uns(10); d_Fileno uns(10); d_Reclen uns(10); d_Reserved2 int(10); d_Reserved3 char(8); d_nlsinfo like(qlg_nls_t); d_namelen uns(10); d_name char(640); nlink_t uns(5); end-ds; dcl-ds qlg_nls_t inz align; // ccsid int(10); Country_id char(2); language_id char(3); nls_Reserved char(3); end-ds; dcl-ds st_stat inz align; // st_mode uns(10); st_ino uns(10); st_nlink uns(5); st_uid uns(10); st_gid uns(10); st_size uns(10); st_atime uns(10); st_mtime uns(10); st_ctime uns(10); st_dev uns(10); st_blksize uns(10); st_allocsize uns(10); st_ObjType char(11); st_codepage uns(5); st_Reservedl char(62); st_ino_gen_id uns(10); end-ds; //--------------------------------------------------------- scDow = f_GetDayName(); SflRcdNbr = 1; 1b if %subst(p_IfsDir: 1: 1) <> '/'; p_IfsDir = '/' + p_IfsDir; 1e endif; wctoLib = *blanks; wctoFile = *blanks; wctoFile2 = '*DEFAULTS'; wctoMbr = *blanks; wcMbrTyp = *blanks; PathHead = p_IfsDir; f_SndStatMsg('List files in path ' + %trimr(p_IfsDir) + ' - in progress.'); pDir = openDir(%trim(p_IfsDir)); 1b if pDir = *null; snd-msg 'Error Found on OPEN DIRECTORY. Check path name.'; 1x else; snd-msg '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 = stat(%trim(EntryName): %addr(st_stat)); ObjType = %str(%addr(st_ObjType)); // extract file extension to allow future // sorting by extension types hidExten = *blanks; hidFileNam = *blanks; 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; snd-msg 'No entries found in directory'; 2e endif; errFlag = closeDir(pDir); 1e endif; // allow user to make selection from subfile Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b dow *on; write sbfctl1; write msgctl; exfmt sfooter1; 2b if (not Ind.sfldsp) or InfdsFkey in %list(f03 :f12); f_SndCompMsg('JCRIFSCPY for path '+ %trimr(p_IfsDir)+' - completed.'); *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); //--------------------------------------- readc sbfdta1; 2b dow not %eof; 3b if sbfOption > 0; 4b if sbfOption in %list(1:2); exsr srExecuteOpts; 4x else; snd-msg 'Option '+%char(sbfOption)+' is not defined.'; 4e endif; sbfOption = 0; update sbfdta1; 3e endif; SflRcdNbr = rrn; readc sbfdta1; 2e enddo; 1e enddo; //--------------------------------------------------------- //--------------------------------------------------------- begsr srExecuteOpts; IsSecondTime = *off; f_RmvSflMsg(ProgId); wcdirname = %trimr(p_IfsDir) + '/' + dirname; 1b if sbfOption = 1; //cpytostmf wctoMbr = %upper(hidFileNam); wcMbrTyp = %upper(hidExten); 2b dow *on; 3b if IsSecondTime; write msgctlw1; 3e endif; IsSecondTime = *on; exfmt window1; f_RmvSflMsg(ProgId); 3b if not (InfdsFkey in %list(f03:f12)); 4b if wctoLib = *blanks or not f_IsValidObj(wctoLib: 'QSYS': '*LIB'); snd-msg 'To Library ' + %trimr(wctoLib) + ' Not Valid.'; 2i iter; 4x elseif wctoFile = *blanks or not f_IsValidObj(wctoFile:wctoLib: '*FILE'); snd-msg 'To File '+%trimr(wctoFile)+' Not Valid.'; 2i iter; 4x elseif wctoMbr = *blanks; snd-msg 'To Member must be entered.'; 2i iter; 4x else; //--------------------------------------------------------- // If uploading to data files, check max // number of members allowed. If only 1 member is allowed, // then overlay member name in upload prompt with data files member. //--------------------------------------------------------- AllocatedSize = f_GetAllocatedSize(wctoFile + wctoLib: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: 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(n) Fild0100ptr; 4e endif; stringv = ('?CPYFRMSTMF FROMSTMF(' + qs + %trimr(%lower(wcdirname)) + qs + ') toMbr(' + qs + '/qsys.Lib/' + %trimr(wctoLib) + '.Lib/' + %trimr(wctoFile) + '.file/' + %trimr(wctoMbr) + '.mbr' + qs + ') '); f_Runcmd(stringv); stringv = ('CHGPFM FILE(' + %trimr(wctoLib) + '/' + %trimr(wctoFile) + ') ' + 'MBR(' + %trimr(wctoMbr) + ') SRCTYPE(' + %trimr(wcMbrTyp) + ') TEXT(' + qs + 'member created by jcr JCRIFSCPY' + qs + ')'); f_Runcmd(stringv); // load message to screen sbfAction = '*COPIED'; snd-msg f_BuildString('File & copied to & in library &.': dirname: wctoFile: wctoLib); 3x else; sbfAction = *blanks; snd-msg '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 = tmpnam(*null); 2b if pTempName <> *null; 3b dow *on; 4b if IsSecondTime; write msgctlw2; 4e endif; IsSecondTime = *on; exfmt window2; f_RmvSflMsg(ProgId); 4b if not (InfdsFkey in %list(f03:f12)); 5b if wctoLib = *blanks or not f_IsValidObj(wctoLib: 'QSYS': '*LIB'); snd-msg 'To Library '+%trimr(wctoLib)+' Not Valid.'; 3i iter; 5e endif; stringv = 'CRTSRCPF FILE(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ') RCDLEN(112) MBR(' + %subst(TempName: 7) + ') TEXT(' + qs + 'TEMP JCRIFSCPY' + qs + ')'; f_Runcmd(stringv); stringv = 'CPYFRMSTMF FROMSTMF(' + qs + %trimr(%lower(wcdirname)) + qs + ') toMbr(' + qs + '/qsys.Lib/' + %trimr(wctoLib) + '.Lib/' + %subst(TempName: 7) + '.file/' + %subst(TempName: 7) + '.mbr' + qs + ') MBROPT(*REPLACE) CVTDTA(*AUTO)'; f_Runcmd(stringv); stringv = 'XMLPREVIEW UPLOADMBR(' + %subst(TempName: 7) + ') UPLOADSRCF(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ') OUTPUTSRCF(' + %trimr(wctoFile2) + ')'; f_Runcmd(stringv); stringv = 'DLTF FILE(' + %trimr(wctoLib) + '/' + %subst(TempName: 7) + ')'; f_Runcmd(stringv); // load message to screen sbfAction = '*INSTALLED'; snd-msg f_BuildString('File & copy/installed to & in library &.': dirname: wctoFile: wctoLib); 4x else; sbfAction = *blanks; snd-msg 'Install Canceled.'; 4e endif; 3v leave; 3e enddo; 2e endif; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRIFSCPYV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckDir // *ENTRY /define p_JCRIFSCPYR /COPY JCRCMDS,JCRCMDSCPY f_CheckDir(p_IfsDir); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Copy member to IFS Path') PARM KWD(MBR) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Member') PARM KWD(FILE) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('File') PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Library') 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(1) + PROMPT('IFS Directory path') PARM KWD(ZIPFILE) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Create + .ZIP file') ]]> .*-------------------------------------------------------------------- :P.Copies source member to selected directory on IFS drive.: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. ]]> '); //--------------------------------------------------------- // JCRIFSMBRR - Copy source member to IFS (with option to zip) // Build copy to stream file command to download members to my IFS directory. // // Set up a PDM option to be CALL JCRIFSMBRR PARM(&N &F &L &S '/my_directory/') // then to execute, place that PDM option beside any member. // Replace '/my_directory/ with actual IFS drive folder. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); // apparently the only sure way to know the file ccsid is to open it // then check the ccsid of the File Information Data Structure dcl-f MBRSRC disk(112) extfile(extifile) extmbr(p_SrcMbr) usropn infds(infds); /define f_GetQual /define ApiErrDS /define Constants /define Infds /define f_BuildString /define f_RunCmd /define f_SndCompMsg /define f_ZipIFS /define f_SndEscapeMsg // *ENTRY /define p_JCRIFSMBRR /COPY JCRCMDS,JCRCMDSCPY dcl-s dbfccsid char(12); //--------------------------------------------------------- // if Coded character set identifier = 65535 (returned as -1 in infds) // (note this is hex format and will not copy) // change ccsid to 37. (other coutries may need to change this) //--------------------------------------------------------- dbfccsid = *blanks; extIfile = f_GetQual(p_SrcFile + p_SrcLib); open MBRSRC; 1b if InfdsCcsid = -1; // 65535 go figure dbfccsid = 'DBFCCSID(37)'; 1e endif; close MBRSRC; //--------------------------------------------------------- p_SrcMbr = %lower(p_SrcMbr); p_SrcFile = %lower(p_SrcFile); p_SrcLib = %lower(p_SrcLib); p_SrcAttr = %lower(p_SrcAttr); p_IfsDir = %lower(p_IfsDir); ApiErrDS.ErrMsgId = *blanks; //--------------------------------------------------------- // copy to stream file command f_RunCmd(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: dbfccsid)); 1b if ApiErrDS.ErrMsgId > *blanks; //error occurred f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': Object Not Copied'); 1e endif; // grant authority to IFS file f_RunCmd(f_BuildString( 'CHGAUT OBJ(&Q&&.&&Q) USER(*PUBLIC) DTAAUT(*RWX)': p_IfsDir: p_SrcMbr: p_SrcAttr)); //------------------------------------------------- 1b if p_CreateZip = '*YES'; f_ZipIFS(p_SrcMbr: p_SrcAttr: p_IfsDir); 1e endif; f_SndCompMsg( f_BuildString('Member &.& copy to IFS directory & - completed': %upper(p_SrcMbr): p_SrcAttr: p_IfsDir)); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRIFSMBRV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckDir // *ENTRY /define p_JCRIFSMBRR /COPY JCRCMDS,JCRCMDSCPY f_CheckMbr(p_SrcFile + p_SrcLib: p_SrcMbr); f_CheckDir(p_IfsDir); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Copy SAVF to IFS Path') PARM KWD(SAVF) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Save file') PARM KWD(LIBRARY) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Library') PARM KWD(DIRECTORY) TYPE(*CHAR) LEN(50) + DFT('/jcr/') PROMPT('IFS Directory path') PARM KWD(ZIPFILE) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Create + .ZIP file') ]]> .*-------------------------------------------------------------------- :P.Copies savf to selected directory on IFS drive. It uses the QzipZip API to create .zip file from copied save file. :P.After execution, a .savf file and .zip file is 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. :HELP NAME='JCRIFSSAV/ZIPFILE'.Create Zip File - Help :XH3.Zip File (ZIPFILE) :P.Create .zip file of downloaded savf.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRIFSSAVR - Copy savf to to IFS (with optional zip) // Build copy to stream file command to download savf to IFS directory. //--------------------------------------------------------- /define ControlStatements /define Constants /define f_RunCmd /define f_BuildString /define f_SndCompMsg /define f_ZipIFS // *ENTRY /define p_JCRIFSSAVR /COPY JCRCMDS,JCRCMDSCPY dcl-s filetype char(10) inz('savf'); //--------------------------------------------------------- p_Savf = %lower(p_Savf); p_Lib = %lower(p_Lib); p_IfsDir = %lower(p_IfsDir); f_RunCmd(f_BuildString( 'CPYTOSTMF FROMMBR(&Q/qsys.lib/&.lib/&.file&Q) TOSTMF(&Q&&&Q) + STMFOPT(*REPLACE) CVTDTA(*NONE) STMFCODPAG(*STMF) + ENDLINFMT(*FIXED)': p_Lib: p_Savf:p_IfsDir: %trimr(p_Savf)+'.savf')); //--------------------------------------------------------- // grant authority to IFS file f_RunCmd(f_BuildString( 'CHGAUT OBJ(&Q&&.&&Q) USER(*PUBLIC) DTAAUT(*RWX)': p_IfsDir: p_Savf: filetype)); //--------------------------------------------------------- 1b if p_CreateZip = '*YES'; f_ZipIFS(p_Savf: filetype: p_IfsDir); 1e endif; f_SndCompMsg( f_BuildString('Savf & copy to IFS directory & - completed': %upper(p_Savf): p_IfsDir)); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRIFSSAVV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_Qusrobjd /define f_CheckDir /define f_RtvMsgAPI /define f_SndEscapeMsg /define f_BuildString // *ENTRY /define p_JCRIFSSAVR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- QusrObjDS = f_QUSROBJD(p_Savf + p_Lib: '*FILE'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; 1b if not(QusrObjDS.ExtendedAttr = 'SAVF'); f_SndEscapeMsg(f_BuildString('Object & in & is not a *SAVF.': p_savf: p_lib)); 1e endif; f_CheckDir(p_IfsDir); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Indicator List') 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') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA12 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'Indicator List' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) 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) ]]> .*-------------------------------------------------------------------- :P.Displays outline view of indicators used in RPGLE, CLP, CLLE, PRTF, and/or DSPF source members. Multiple members can be selected to see cumulative indicator usage.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRIND/SRCMBR'.Source member - Help :XH3.Source member (SRCMBR) :P.Member names whose indicator usage is to be displayed.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRINDR - Indicator List //--------------------------------------------------------- /define ControlStatements /define Constants /define f_BlankCommentsCL /define Dspatr /define SrcDS /define f_GetQual /define f_GetDayName /define f_Qusrmbrd /define f_BuildString /define f_SndCompMsg /define f_IsCompileTimeArray // *ENTRY /define p_JCRINDR /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRINDD workstn; dcl-f RPGSRC disk(112) extfile(extIfile) extmbr(ExtMbr) usropn Infds(Infds); dcl-ds Infds; InfdsRecLen int(5) pos(125); end-ds; dcl-s MbrCount uns(3); dcl-s MbrColon char(4) inz('Mbr:'); dcl-s OffsetToNext int(5) based(displaceptr); dcl-s NumOfLists int(5) based(parmptr); dcl-s col uns(3); dcl-s row uns(3); dcl-s CompMsgString varchar(36); dcl-s ExtMbr char(10); dcl-s FileQual char(20); dcl-s ExtendedF2 char(45); dcl-s yy uns(5); dcl-s IsCalcSpec ind; dcl-s IsFree ind; dcl-s IsComment ind; dcl-s MaybeIN char(6); // CLLE dcl-s scObjHead dim(3) based(ptr1) like(scobjhead1); dcl-s ptr1 pointer inz(%addr(scobjhead1)); // Get number of source file/lib/Mbr names dcl-ds MbrList based(MbrListPtr) qualified; SrcMbr char(10) pos(3); SrcFilQual char(20); end-ds; dcl-ds FoundOne qualified inz; Pos12 char(2); Pos1 char(1) pos(1); Pos2 char(1) pos(2); end-ds; dcl-s tabind char(1) dim(24) ctdata perrcd(1); dcl-s tabrow zoned(2) dim(24) alt(tabind); dcl-ds Indicators dim(12) qualified based(ptr2); col char(2) dim(18); end-ds; dcl-s ptr2 pointer inz(%addr(r0c01)); dcl-ds Attr dim(12) qualified based(ptr3); col char(1) dim(18); end-ds; dcl-s ptr3 pointer inz(%addr(atr0c01)); // map screen fields into program array dcl-ds *n; scObjHead1; scObjHead2; scObjHead3; r0c01; r0c02; r0c03; r0c04; r0c05; r0c06; r0c07; r0c08; r0c09; r0c10; r0c11; r0c12; r0c13; r0c14; r0c15; r0c16; r0c17; r0c18; r1c01; r1c02; r1c03; r1c04; r1c05; r1c06; r1c07; r1c08; r1c09; r1c10; r1c11; r1c12; r1c13; r1c14; r1c15; r1c16; r1c17; r1c18; r2c01; r2c02; r2c03; r2c04; r2c05; r2c06; r2c07; r2c08; r2c09; r2c10; r2c11; r2c12; r2c13; r2c14; r2c15; r2c16; r2c17; r2c18; r3c01; r3c02; r3c03; r3c04; r3c05; r3c06; r3c07; r3c08; r3c09; r3c10; r3c11; r3c12; r3c13; r3c14; r3c15; r3c16; r3c17; r3c18; r4c01; r4c02; r4c03; r4c04; r4c05; r4c06; r4c07; r4c08; r4c09; r4c10; r4c11; r4c12; r4c13; r4c14; r4c15; r4c16; r4c17; r4c18; r5c01; r5c02; r5c03; r5c04; r5c05; r5c06; r5c07; r5c08; r5c09; r5c10; r5c11; r5c12; r5c13; r5c14; r5c15; r5c16; r5c17; r5c18; r6c01; r6c02; r6c03; r6c04; r6c05; r6c06; r6c07; r6c08; r6c09; r6c10; r6c11; r6c12; r6c13; r6c14; r6c15; r6c16; r6c17; r6c18; r7c01; r7c02; r7c03; r7c04; r7c05; r7c06; r7c07; r7c08; r7c09; r7c10; r7c11; r7c12; r7c13; r7c14; r7c15; r7c16; r7c17; r7c18; r8c01; r8c02; r8c03; r8c04; r8c05; r8c06; r8c07; r8c08; r8c09; r8c10; r8c11; r8c12; r8c13; r8c14; r8c15; r8c16; r8c17; r8c18; r9c01; r9c02; r9c03; r9c04; r9c05; r9c06; r9c07; r9c08; r9c09; r9c10; r9c11; r9c12; r9c13; r9c14; r9c15; r9c16; r9c17; r9c18; r10c01; r10c02; r10c03; r10c04; r10c05; r10c06; r10c07; r10c08; r10c09; r10c10; r10c11; r10c12; r10c13; r10c14; r10c15; r10c16; r10c17; r10c18; r11c01; r11c02; r11c03; r11c04; r11c05; r11c06; r11c07; r11c08; r11c09; r11c10; r11c11; r11c12; r11c13; r11c14; r11c15; r11c16; r11c17; r11c18; atr0c01; atr0c02; atr0c03; atr0c04; atr0c05; atr0c06; atr0c07; atr0c08; atr0c09; atr0c10; atr0c11; atr0c12; atr0c13; atr0c14; atr0c15; atr0c16; atr0c17; atr0c18; atr1c01; atr1c02; atr1c03; atr1c04; atr1c05; atr1c06; atr1c07; atr1c08; atr1c09; atr1c10; atr1c11; atr1c12; atr1c13; atr1c14; atr1c15; atr1c16; atr1c17; atr1c18; atr2c01; atr2c02; atr2c03; atr2c04; atr2c05; atr2c06; atr2c07; atr2c08; atr2c09; atr2c10; atr2c11; atr2c12; atr2c13; atr2c14; atr2c15; atr2c16; atr2c17; atr2c18; atr3c01; atr3c02; atr3c03; atr3c04; atr3c05; atr3c06; atr3c07; atr3c08; atr3c09; atr3c10; atr3c11; atr3c12; atr3c13; atr3c14; atr3c15; atr3c16; atr3c17; atr3c18; atr4c01; atr4c02; atr4c03; atr4c04; atr4c05; atr4c06; atr4c07; atr4c08; atr4c09; atr4c10; atr4c11; atr4c12; atr4c13; atr4c14; atr4c15; atr4c16; atr4c17; atr4c18; atr5c01; atr5c02; atr5c03; atr5c04; atr5c05; atr5c06; atr5c07; atr5c08; atr5c09; atr5c10; atr5c11; atr5c12; atr5c13; atr5c14; atr5c15; atr5c16; atr5c17; atr5c18; atr6c01; atr6c02; atr6c03; atr6c04; atr6c05; atr6c06; atr6c07; atr6c08; atr6c09; atr6c10; atr6c11; atr6c12; atr6c13; atr6c14; atr6c15; atr6c16; atr6c17; atr6c18; atr7c01; atr7c02; atr7c03; atr7c04; atr7c05; atr7c06; atr7c07; atr7c08; atr7c09; atr7c10; atr7c11; atr7c12; atr7c13; atr7c14; atr7c15; atr7c16; atr7c17; atr7c18; atr8c01; atr8c02; atr8c03; atr8c04; atr8c05; atr8c06; atr8c07; atr8c08; atr8c09; atr8c10; atr8c11; atr8c12; atr8c13; atr8c14; atr8c15; atr8c16; atr8c17; atr8c18; atr9c01; atr9c02; atr9c03; atr9c04; atr9c05; atr9c06; atr9c07; atr9c08; atr9c09; atr9c10; atr9c11; atr9c12; atr9c13; atr9c14; atr9c15; atr9c16; atr9c17; atr9c18; atr10c01; atr10c02; atr10c03; atr10c04; atr10c05; atr10c06; atr10c07; atr10c08; atr10c09; atr10c10; atr10c11; atr10c12; atr10c13; atr10c14; atr10c15; atr10c16; atr10c17; atr10c18; atr11c01; atr11c02; atr11c03; atr11c04; atr11c05; atr11c06; atr11c07; atr11c08; atr11c09; atr11c10; atr11c11; atr11c12; atr11c13; atr11c14; atr11c15; atr11c16; atr11c17; atr11c18; end-ds; //--------------------------------------------------------- // process parm list by moving data structure pointer ParmPtr = %addr(p_SrcMbrs); DisplacePtr = ParmPtr; 1b for MbrCount = 1 to NumOfLists; DisplacePtr += 2; MbrListPtr = ParmPtr + OffsetToNext; FileQual = MbrList.SrcFilQual; ExtMbr = MbrList.SrcMbr; // get member type QusrmbrdDS = f_Qusrmbrd(FileQual: ExtMbr: 'MBRD0200'); 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); scDow = f_GetDayName(); open RPGSRC; read RPGSRC SrcDS; // Execute different source reader based on source type 2b if QusrmbrdDS.MbrType in %list('RPGLE':'SQLRPGLE'); exsr srReadSrcRPGLE; 2x elseif %subst(QusrmbrdDS.MbrType:1:4) in %list('DSPF':'PRTF'); exsr srReadSrcDDS; 2x elseif %subst(QusrmbrdDS.MbrType: 1: 2) = 'CL'; exsr srReadSrcCL; 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; //--------------------------------------------------------- // Read Rpg4 Source code. // Three types of lines scanned are calc, input, output. // all lines that are comment or have eject character are // ignored. 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 f_IsCompileTimeArray(SrcDS.CompileArray); LV leavesr; 2e endif; SrcDS.SpecType = %upper(SrcDS.SpecType); // O specs will set IsCalcSpec off 2b if SrcDS.SpecType in %list('O':'P':'D':'I':'F'); IsCalcSpec = *off; // if C or c or /free, then inside C specs 2x elseif SrcDS.SpecType = 'C'; IsCalcSpec = *on; 2e endif; // see if inside /free IsFree = *off; 2b if SrcDS.SpecType = ' '; IsFree = *on; IsCalcSpec = *on; 2e endif; // see if /free comment line or /copy / define etc.. IsComment = *off; 2b if SrcDS.Asterisk in %list('*': '/': '+') or (%len(%triml(SrcDS.Src80)) > 1 and %subst((%triml(SrcDS.Src80)): 1: 1) = '/'); IsComment = *on; 2e endif; // check conditioning indicators for calc specs 2b if not IsComment; 3b if IsCalcSpec; 4b if IsFree; SrcDS.Src80 = %upper(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; f_Extract(%subst(SrcDS.Src80: yy: 6)); 6e endif; 5e enddo; 4x else; SrcDS = %upper(SrcDS); f_LoadMatrix(%subst(SrcDS: 22: 2)); //CONDITIONING IND 5b if %subst(SrcDS: 19: 2) = 'L0'; f_LoadMatrix('L0'); 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; f_Extract(%subst(ExtendedF2: yy: 6)); 7e endif; 6e enddo; 5x else; 6b if (%subst(SrcDS: 24: 3) = '*IN') and (%subst(SrcDS: 27: 1) <> 'Z'); f_Extract(%subst(SrcDS: 24: 6)); 6e endif; 6b if (%subst(SrcDS: 48: 3) = '*IN'); //FACTOR 2 *IN f_Extract(%subst(SrcDS: 48: 6)); 6e endif; 6b if (%subst(SrcDS: 62: 3) = '*IN'); //RESULT FIELD *IN f_Extract(%subst(SrcDS: 62: 6)); 6e endif; // load resulting indicators 6b if %subst(SrcDS: 38: 4) <> 'CALL'; 7b if %subst(SrcDS: 83: 2) > *blanks; //HIGH f_Extract(' ' + %subst(SrcDS: 83: 2)); 7e endif; 7b if %subst(SrcDS: 85: 2) > *blanks; //LO f_Extract(' ' + %subst(SrcDS: 85: 2)); 7e endif; 7b if %subst(SrcDS: 87: 2) > *blanks; //EQUAL f_Extract(' ' + %subst(SrcDS: 87: 2)); 7e endif; 6e endif; 5e endif; 4e endif; //--------------------------------------------------------- // I spec indicators //--------------------------------------------------------- 3x elseif SrcDS.SpecType = 'I' or SrcDS.SpecType = 'i'; SrcDS = %upper(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'); f_LoadMatrix(%subst(SrcDS: 33: 2)); 5e endif; 4e endif; f_LoadMatrix(%subst(SrcDS: 75: 2)); //L INDICATORS f_LoadMatrix(%subst(SrcDS: 77: 2)); //MATCHING RECORDS f_LoadMatrix(%subst(SrcDS: 79: 2)); //RELATIONAL f_LoadMatrix(%subst(SrcDS: 81: 2)); //FIELD + f_LoadMatrix(%subst(SrcDS: 83: 2)); //FIELD - f_LoadMatrix(%subst(SrcDS: 85: 2)); //FIELD 0/*BLANK //--------------------------------------------------------- // O spec indicators //--------------------------------------------------------- 3x elseif %upper(SrcDS.SpecType) = 'O'; SrcDS = %upper(SrcDS); f_LoadMatrix(%subst(SrcDS: 34: 2)); //O SPEC INDICATOR 1 f_LoadMatrix(%subst(SrcDS: 37: 2)); //O SPEC IND 2 f_LoadMatrix(%subst(SrcDS: 40: 2)); //O SPEC IND 3 //--------------------------------------------------------- // F spec indicators //--------------------------------------------------------- 3x elseif %upper(SrcDS.SpecType) = 'F'; SrcDS = %upper(SrcDS); yy = %scan('OFLIND(*IN': SrcDS); 4b if yy in %range(56:92); f_LoadMatrix(%subst(SrcDS: yy + 10: 2)); 4x else; yy = %scan('OFLIND(': SrcDS); 5b if yy in %range(56:92); f_LoadMatrix(%subst(SrcDS: yy + 7: 2)); 5e endif; 4e endif; yy = %scan('EXTIND(*IN': SrcDS); 4b if yy in %range(56:92); f_LoadMatrix(%subst(SrcDS: yy + 10: 2)); 4e endif; 3e endif; 2e endif; read RPGSRC SrcDS; 1e enddo; 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 in %range('01':'99'); f_LoadMatrix(SrcDS.ddsCondIn1); 3e endif; 3b if SrcDS.ddsCondIn2 in %range('01':'99'); f_LoadMatrix(SrcDS.ddsCondIn2); 3e endif; 3b if SrcDS.ddsCondIn3 in %range('01':'99'); f_LoadMatrix(SrcDS.ddsCondIn3); 3e endif; // extract indicators that are assigned to keywords 3b if SrcDS.ddsField10 = 'VLDCMDKEY('; f_LoadMatrix(%subst(SrcDS.ddsField: 11: 2)); 3x elseif SrcDS.ddsField9 in %list('PAGEDOWN(':'ROLLDOWN('); f_LoadMatrix(%subst(SrcDS.ddsField: 10: 2)); 3x elseif SrcDS.ddsField7 in %list( 'BLANKS(': 'CHANGE(':'INDTXT(': 'PAGEUP(': 'ROLLUP('); f_LoadMatrix(%subst(SrcDS.ddsField: 8: 2)); 3x elseif SrcDS.ddsField6 in %list('CLEAR(': 'SETOF(') or SrcDS.ddsField7 in %range('PRINT(0': 'PRINT(9'); f_LoadMatrix(%subst(SrcDS.ddsField: 7: 2)); 3x elseif SrcDS.ddsField5 = 'HELP(' or SrcDS.ddsField5 = 'HOME(' or SrcDS.ddsField2 = 'CA' and SrcDS.ddsParenthesis = '(' or SrcDS.ddsField2 = 'CF' and SrcDS.ddsParenthesis = '('; f_LoadMatrix(%subst(SrcDS.ddsField: 6: 2)); 3x elseif SrcDS.ddsField4 = 'DUP('; f_LoadMatrix(%subst(SrcDS.ddsField: 5: 2)); 3e endif; 2e endif; read RPGSRC SrcDS; 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 = %upper(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) in %range('0':'9') and %subst(MaybeIN: 5: 1) in %range('0':'9'); 5b if %subst(MaybeIN: 6: 1) in %list(')':' '); f_LoadMatrix(%subst(MaybeIN: 4: 2)); 5e endif; 4e endif; 3e endif; 2e enddo; read RPGSRC SrcDS; 1e enddo; endsr; //--------------------------------------------------------- // global load indicator to proper Row/Col //--------------------------------------------------------- dcl-proc f_LoadMatrix; dcl-pi *n; p_Ind char(2) const; end-pi; 1b if p_Ind <> 'ZS'; //not *inzsr FoundOne = p_Ind; 2b if FoundOne.Pos1 > ' ' and FoundOne.Pos2 > ' '; row = f_GetRow(FoundOne); 3b if row > 0; col = f_GetColumn(FoundOne); 4b if col > 0; Indicators(row).Col(col) = FoundOne; Attr(row).Col(col) = WHITE; 4e endif; 3e endif; 2e endif; 1e endif; return; end-proc; //--------------------------------------------------------- // 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. //--------------------------------------------------------- dcl-proc f_Extract; dcl-pi *n; IndExtract char(6) const; end-pi; dcl-s TestByte char(1); 1b if (%subst(IndExtract: 4: 1) <> '('); //not array element FoundOne = %subst(IndExtract: 4: 2); //load key // note ds name cannot be used in %list function 2b if FoundOne.Pos12 in %list('OA':'OB':'OC':'OD':'OE':'OF': 'OG':'OV':'L0':'LR':'RT') or FoundOne.Pos12 in %range('KA':'KN') or FoundOne.Pos12 in %range('KP':'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); f_LoadMatrix(FoundOne); 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 f_LoadMatrix(FoundOne); 3e endif; 2e endif; 1e endif; return; end-proc; //--------------------------------------------------------- // Returns screen Row number for passed indicator //--------------------------------------------------------- dcl-proc f_GetRow; dcl-pi *n uns(3); p_Ind char(2) const; end-pi; dcl-s row uns(3); dcl-ds SplitIndDS qualified; pos1 char(1); pos2 char(1); pos2num zoned(1) overlay(pos2); end-ds; 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; 1x elseif p_Ind = 'OV'; row = 8; // ie *in10 would go into row 1 ( 0 + 1) // *in11 would go into row 2 ( 1 + 1) etc. 1x elseif SplitIndDS.pos2 in %range('0':'9'); row = SplitIndDS.pos2num + 1; // process alpha. *INKA-*INKG maps same as OA-OG 1x elseif %tlookup(SplitIndDS.pos2: tabind: tabrow); row = tabrow; 1e endif; return row; end-proc; //--------------------------------------------------------- // Returns location in Column for passed indicator //--------------------------------------------------------- dcl-proc f_GetColumn; dcl-pi *n uns(3); p_Ind char(2) const; end-pi; dcl-s col uns(3); dcl-s pos1 char(1); pos1 = %subst(p_Ind: 1: 1); 1b if p_Ind = '1P' or p_Ind = 'RT' or p_Ind = 'LR'; col = 18; 1x elseif pos1 in %range('0':'9'); col = %dec(pos1:1:0)+1; 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-proc; ** A01 1 B02 2 C03 3 D04 4 E05 5 F06 6 G07 7 H08 8 I09 9 J10 10 K11 1 L12 2 M01 3 N02 4 P03 5 Q04 6 R05 7 S06 8 T07 9 U08 20 V09 1 W10 2 X11 3 Y12 4 ]]> '); //--------------------------------------------------------- // JCRINDV - Validity checking program for lib/file/member //-------------------------------------------------------- /define ControlStatements /define f_CheckMbr // *ENTRY /define p_JCRINDR /COPY JCRCMDS,JCRCMDSCPY dcl-s ForCount uns(3); dcl-s OffsetToNext int(5) based(displaceptr); dcl-s NumOfLists int(5) based(parmptr); // overlay source file/lib/mbr names dcl-ds MbrList based(MbrListPtr) qualified; SrcMbr char(10) pos(3); SrcFilQual char(20); end-ds; //--------------------------------------------------------- // Use pointer to overlay input parm with data structure. // Spin down number of offsets to list entries. // MbrListPtr (start of list + OffsetToNext) moves DS through the list. //--------------------------------------------------------- ParmPtr = %addr(p_SrcMbrs); DisplacePtr = ParmPtr; 1b for ForCount = 1 to NumOfLists; DisplacePtr += 2; MbrListPtr = ParmPtr + OffsetToNext; f_CheckMbr(MbrList.SrcFilQual: MbrList.SrcMbr); 1e endfor; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Search Jobd For Lib,Outq,Jobq') PARM KWD(LIBRARY) TYPE(*CHAR) LEN(10) + PROMPT('Library') PARM KWD(OUTQ) TYPE(*CHAR) LEN(10) PROMPT('Outq') PARM KWD(JOBQ) TYPE(*CHAR) LEN(10) PROMPT('Jobq') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA A CA03 A CA05 A CA06 A CA08 A CA12 A PRINT *---------------------------------------------- A R SBFDTA1 SFL A SFOPT 1A B 6 2 A SFLIB 10A O 6 5 A SFOUTQ 10A O 6 16 A SFOUTQLIB 10A O 6 27 A SFJOBQ 10A O 6 38 A SFJOBQLIB 10A O 6 49 A SFJOBD 10A O 6 61DSPATR(HI) A SFJOBDLIB 10A O 6 72 A SFTEXT 38A O 6 83 A SFLASTUSED 10A O 6122 *---------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(1900) A SFLPAG(0019) A CHANGE(12) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A 1 2'JCRJOBD ' A COLOR(BLU) A 1 23'Search JOBD for Library/Outq/Jobq' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 16'(leading space = contains) ' A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 2'5=DspJobd ' A COLOR(BLU) A SCLIB 10A B 4 5CHANGE(12) A SCOUTQ 10A B 4 16 A SCJOBQ 10A B 4 38 A 5 2'Op' A DSPATR(HI) A DSPATR(UL) A 5 5'Library ' A DSPATR(HI) A DSPATR(UL) A 5 16'Outq ' A DSPATR(HI) A DSPATR(UL) A 5 38'Jobq ' A DSPATR(HI) A DSPATR(UL) A 5 61'Jodb ' A DSPATR(HI) A DSPATR(UL) A 5 83'Text - A ' A DSPATR(HI) A DSPATR(UL) A 5122'Last Used ' A DSPATR(HI) A DSPATR(UL) *---------------------------------------------- A R SFOOTER1 A OVERLAY A 26 2'F3=Exit' A COLOR(BLU) A 26 16'F5=Refresh' A COLOR(BLU) A 26 34'F6=Print' A COLOR(BLU) A 26 54'F8=Wrksplf' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Search JOBD for Library or Outq or Jobq.:EHELP. :HELP NAME='JCRJOBD/LIBRARY'.Library - Help :XH3.Library (LIBRARY) :P.Specifies library name to search for on jobd library list.:EHELP. :HELP NAME='JCRJOBD/OUTQ'.Outq - Help :XH3.Outq (OUTQ) :P.Specifies outq name to search for in jobd.:EHELP. :HELP NAME='JCRJOBD/JOBQ'.Jobq - Help :XH3.Jobq (JOBQ) :P.Specifies jobq name to search for in jobd.:EHELP. :EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRJOBD' A 20'Search JOBD for Library or Outq' A SCDOW 9A O 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'Page' A +1PAGNBR EDTCDE(4) SPACEA(2) *--- A 5'Library ' A 16'Outq' A 38'Jobq' A 61'Jodb' A 83'Text' A 122'Last Used ' A SPACEA(1) *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SFLIB 10A 5 A SFOUTQ 10A 16 A SFOUTQLIB 10A 27 A SFJOBQ 10A 38 A SFJOBQLIB 10A 49 A SFJOBD 10A 61 A SFJOBDLIB 10A 72 A SFTEXT 38A 83 A SFLASTUSED 10A 122 ]]> '); //--------------------------------------------------------------- // JCRJOBDR - Search JOBD for Library or Outq or Jobq //--------------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRJOBDD workstn sfile(sbfdta1:rrn1) infds(infds) indds(ind); dcl-f JCRJOBDP printer oflind(IsOverFlow) usropn; /define psds /define Infds /define Constants /define FunctionKeys /define f_Quscrtus /define ApiErrDS /define f_GetDayName /define f_GetApiISO /define f_BuildString /define f_RunCmd /define f_RmvSflMsg /define Quslobj /define f_Qusrobjd /COPY JCRCMDS,JCRCMDSCPY dcl-s rrn1 uns(5); dcl-s xx uns(5); dcl-s yy uns(5); dcl-s isfirsttime ind; dcl-s IsOk1 ind; dcl-s IsOk2 ind; dcl-s IsOk3 ind; dcl-s lenscan uns(3); dcl-s AstPos uns(3); // name screen indicators dcl-ds ind qualified; changes ind pos(12) inz(*off); sfldsp ind pos(31) inz(*off); sfldspctl ind pos(32) inz(*off); end-ds; // Retrieve Job Description Information dcl-pr Qwdrjobd extpgm('QWDRJOBD'); *n char(1000) options(*varsize); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(20) const; // jobd and lib *n like(ApiErrDS); end-pr; dcl-ds Jobd0100DS len(3000) qualified; Jobd char(10) pos(9); JobdL char(10) pos(19); UsrPrf char(10) pos(29); Jobq char(10) pos(55); JobqL char(10) pos(65); Outq char(10) pos(87); OutqL char(10) pos(97); Text char(50) pos(310); LibraryOffset int(10) pos(361); LibraryCount int(10) pos(365); end-ds; dcl-s JobdLibl char(10) based(jobdliblptr); // *entry----------------- dcl-pi *n; p_Lib char(10); p_Outq char(10); p_Jobq char(10); end-pi; f_RmvSflMsg(ProgId); scDow = f_GetDayName(); ApiHeadPtr = f_Quscrtus(UserSpaceName); isfirsttime = *on; 1b if p_Lib > *blanks or p_Outq > *blanks or p_Jobq > *blanks; sclib = p_Lib; scoutq = p_Outq; scjobq = p_Jobq; exsr srhardrefresh; isfirsttime = *off; 1x else; exsr srclearsfl; 1e endif; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; ind.sfldsp = (rrn1 > 0); ind.sfldspctl = *on; write msgctl; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2x elseif infdsfkey = f05; sclib = *blanks; scjobq = *blanks; scoutq = *blanks; exsr srclearsfl; 2x elseif infdsfkey = f06; exsr srPrint; snd-msg 'Print Completed'; 2x elseif infdsfkey = f08; f_RunCmd('WRKSPLF'); 2x elseif ind.changes; 3b if IsFirsttime; exsr srhardrefresh; isfirsttime = *off; 3x else; exsr srclearsfl; exsr srApplyFilters; 3e endif; //---------------------------------------- 2x elseif (rrn1 > 0); readc sbfdta1; 3b dow not %eof(); 4b if sfopt = '5'; f_RunCmd(f_buildstring( 'DSPJOBD JOBD(&)': %trim(SFJOBDLIB) +'/'+SFJOBD)); 4e endif; clear sfopt; update sbfdta1; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; *inlr = *on; //--------------------------------------------------------- //--------------------------------------------------------- begsr srPrint; open JCRJOBDP; write PrtHead; IsOverFlow = *off; yy = rrn1; 1b for xx = 1 to yy; chain xx sbfdta1; write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; 1e endfor; close JCRJOBDP; endsr; //--------------------------------------------------------- // load user profile names into user space. //--------------------------------------------------------- begsr srhardrefresh; exsr srclearsfl; 1b if not isfirsttime; sclib = *blanks; scjobq = *blanks; scoutq = *blanks; 1e endif; callp QUSLOBJ( UserSpaceName: 'OBJL0100': '*ALL *ALL': '*JOBD': ApiErrDS); exsr srApplyFilters; endsr; //----------------------- //----------------------- begsr srclearsfl; ind.sfldsp = *off; ind.sfldspctl = *off; write SBFCTL1; ind.sfldspctl = *on; rrn1 = 0; sfopt = *blanks; endsr; //----------------------- // if first character is blank, then filter is a wild card // first character <> blank, then trailing is wild card //----------------------- begsr srApplyFilters; QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; Astpos = 0; If scLib <> *Blanks; AstPos = %Scan('*':scLib); EndIf; 1b for ForCount = 1 to ApiHead.ListEntryCount; callp Qwdrjobd( Jobd0100DS: %size(Jobd0100DS): 'JOBD0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); IsOk1 = *off; 2b if sclib > *blanks; JobdLiblPtr = %addr(Jobd0100DS) + Jobd0100DS.LibraryOffset; 3b for ForCount2 = 1 to Jobd0100DS.LibraryCount; 4b if JobdLibl = sclib Or (AstPos > 0 And %SubSt(JobdLibl:1:AstPos-1) = %SubSt(scLib:1:AstPos-1)); sflib = JobdLibl; IsOk1 = *on; 4e endif; JobdLiblPtr += 11; 3e endfor; 2x else; sflib = *blanks; IsOk1 = *on; 2e endif; //----------------------------- IsOk2 = *off; 2b if scjobq > *blanks; 3b if %subst(scjobq:1:1)>*blanks; lenscan = %len(%trimr(scjobq)); 4b if %subst(Jobd0100DS.JobQ:1:lenscan) = scjobq; IsOk2 = *on; 4e endif; 3x else; 4b if %scan(%trim(scjobq): Jobd0100DS.JobQ: 1) > 0; IsOk2 = *on; 4e endif; 3e endif; 2x else; IsOk2 = *on; 2e endif; //------------------------------------- IsOk3 = *off; 2b if scoutq > *blanks; 3b if %subst(scoutq:1:1)>*blanks; lenscan = %len(%trimr(scoutq)); 4b if %subst(Jobd0100DS.Outq:1:lenscan) = scoutq; IsOk3 = *on; 4e endif; 3x else; 4b if %scan(%trim(scoutq): Jobd0100DS.Outq: 1) > 0; IsOk3 = *on; 4e endif; 3e endif; 2x else; IsOk3 = *on; 2e endif; 2b if IsOk1 and IsOk2 and IsOk3; QusrObjDS = f_QUSROBJD(QuslobjDS.ObjNam + QuslobjDS.ObjLib: '*JOBD': 'OBJD0400'); 3b if QusrobjDS.NumDaysUsed > 0; sfLastUsed = f_GetApiISO(QusrobjDS.LastUsedDate + ' '); 3x else; sfLastUsed = *blanks; 3e endif; sftext = Jobd0100DS.text; sfjobq = Jobd0100DS.Jobq; sfjobqlib = Jobd0100DS.JobqL; sfjobd = Jobd0100DS.Jobd; sfjobdlib = Jobd0100DS.JobdL; sfoutq = Jobd0100DS.Outq; sfoutqlib = Jobd0100DS.OutqL; rrn1 += 1; write sbfdta1; 2e endif; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; 1b if rrn1=0; snd-msg 'No Jobds Found'; 1e endif; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Work With Selected Jobs') PARM KWD(JOB) TYPE(JOB) PROMPT('Job') 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(CURRUSER) TYPE(*NAME) LEN(10) DFT(*ALL) + SPCVAL((*ALL)) PROMPT('Filter Current User:') 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) ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A INDARA A CA03 A CA05 A CA08 A CA09 A CA10 A CA12 A R SBFDTA1 SFL A SCURRUSER 10A H A SBFOPTION 2Y 0B 6 2EDTCDE(4) A 10 DSPATR(PC) A SJOBNAME 10A O 6 5 A SUSERNAME 10A O 6 16 A SJOBNUM 6A O 6 27 A SJOBSTATUS 7A O 6 34 A STHREADSTA 4A O 6 42 A SJOBTYPE 10A O 6 47 A SFUNCNAME 10A O 6 58 A SRUNPTY 10A O 6 69 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A *DS3 SFLSIZ(0065) A *DS4 SFLSIZ(0065) A *DS3 SFLPAG(0016) A *DS4 SFLPAG(0016) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRJOBS' A COLOR(BLU) A 1 23'Work With Selected Jobs' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A 2 3'2=Chgjob' A COLOR(BLU) A 2 13'3=Strsrvjob' A COLOR(BLU) A 2 26'4=Endjob' A COLOR(BLU) A 2 35'5=Dspjob' A COLOR(BLU) A 2 45'8=Wrksplf' A COLOR(BLU) A 2 55'9=Job File I/O' A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 2'10=Strdbg' A COLOR(BLU) A 3 12'15=Endsrvjob' A COLOR(BLU) A 3 25'20=Enddbg' A COLOR(BLU) A 3 35'6=Hldjob' A COLOR(BLU) A 3 45'7=Rlsjob' A COLOR(BLU) A PCURRUSER 10A O 4 16 A 4 27'(current user)' A COLOR(BLU) A 4 47'Jobq' A DSPATR(HI) A 4 58'JobqLib' A DSPATR(HI) A 4 69'Subsystem' A DSPATR(HI) A 5 2'Opt' A DSPATR(HI) A 5 7'Job Name' A DSPATR(HI) A TOGGLE1 7A O 5 16DSPATR(HI) A 5 27'Number' A DSPATR(HI) A 5 34'Status' A DSPATR(HI) A 5 47'Or Type' A DSPATR(HI) A 5 58'or Func' A DSPATR(HI) A 5 69'Or RunPty' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Displays subfile with job names meeting the selection criteria. Select useful options to perform from the subfile. :P. Option 9 is slick file I/O monitor that will sort display by IO count or file name. Monitor also has F09=View PFs. This option is useful when analyzing where data is coming from in commercial software. This option sorts open files (PF and LF) down to subset of distinct physicals and executes a data base utility to see contents of each file.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRJOBS/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. QZDASOINIT for sql procedure jobs. :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='JCRJOBS/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 with spooled files.:EPARML.:EHELP. :HELP NAME='JCRJOBS/THREAD'.Thread State - Help :XH3.Thread State (THREAD) :P.Useful to find all jobs in MSGW (message wait) state. :PARML.:PT.:PK def.*ALL:EPK.:PD.Load All. :PT.:PK.MSGW:EPK.:PD.Load jobs in message wait state.:EPARML.:EHELP. :HELP NAME='JCRJOBS/JOBQ'.Job Queue - Help :XH3.Job Queue (JOBQ) :P.Select job queue containing selected jobs. :PARML.:PT.:PK def.*ALL:EPK.:PD.Show all job queues. :PT.:PK.jobq-name:EPK.:PD.Show jobs in selected job queues.:EPARML.:EHELP. :HELP NAME='JCRJOBS/CURRUSER'.Job Queue - Help :XH3.Job Queue (CURRUSER) :P.Select jobs for Current User. (hint select User = *ALL'):EHELP. :EPNLGRP. ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA A CA03 A CA05 A CA07 A CA08 A CA09 A CA12 A R SBFDTA1 SFL A SBOPTION 1Y 0B 5 2EDTCDE(4) A SBFILE 10A O 5 4 A SBLIB 10A O 5 15 A SBMBRDEV 10A O 5 26 A SBRCDFMT 10A O 5 37 A SBFILETYPE 4A O 5 48 A SBTOTALIO 9Y 0O 5 53EDTCDE(4) A SBOPENOPT 3A O 5 64 A SBRRN 9Y 0O 5 68EDTCDE(4) A SBTEXT 50A O 5 80 A*---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0100) A SFLPAG(0020) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRJOBSIOR' A COLOR(BLU) A 1 23'Job File I/O' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A 2 2'Job Name:' A COLOR(BLU) A PJOBNAM 10A O 2 12 A 2 25'User:' A COLOR(BLU) A PJOBUSR 10A O 2 31 A 2 45'Number:' A COLOR(BLU) A PJOBNBR 6A O 2 53 A 2 72SYSNAME A COLOR(BLU) A SCHEADOPT 65A O 3 2COLOR(BLU) A 4 4'File' A DSPATR(HI) A 4 15'Library' A DSPATR(HI) A 4 26'Mbr/Device' A DSPATR(HI) A 4 37'RcdFmt' A DSPATR(HI) A 4 48'Type' A DSPATR(HI) A 4 59'I/O' A DSPATR(HI) A 4 64'Opt' A DSPATR(HI) A 4 70'Record#' A DSPATR(HI) A 4 80'Text' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 26 2'F3=Exit' COLOR(BLU) A 26 14'F5=Refresh' COLOR(BLU) A 26 26'F7=I/O seq' COLOR(BLU) A 26 39'F8=File Seq' COLOR(BLU) A FOOTF09 15 26 53COLOR(BLU) A 26 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> '); //--------------------------------------------------------- // JCRJOBSIOR - Work with selected jobs - I/O display //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRJOBSIOD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define psds /define FunctionKeys /define f_GetFileUtil /define f_RunOptionFile /define Ind /define Qlgsort /define f_Qusrobjd /define Qdbrtvfd /define f_RmvSflMsg /define f_RtvMsgAPI /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-s KeyFld char(10); dcl-s Quick char(200) based(opPtr); dcl-s LengthOfBuffer int(10); dcl-s Count uns(5); dcl-s PfNamesArry char(20) dim(400); dcl-s FileLib char(20); dcl-s dbUtility char(8); // List Open Files dcl-pr qdmlopnf extpgm('QDMLOPNF'); *n char(8) options(*varsize); // Receiver *n int(10) const; // Length *n char(8) const; // Api Format *n like(jidf0100DS); // Job ID *n char(8) const; // Job ID Format *n like(ApiErrDS); end-pr; // header receiver variable dcl-ds opnf0100DS qualified based(opnf0100ptr); BytesReturned int(10); BytesAvail int(10); NumFilesOpen int(10); OffsetToList int(10); NumFilesRtrned int(10); LenOpenEntry int(10); end-ds; // repeating receiver variable dcl-ds opRepeatDS based(opPtr) qualified; FileName char(10); LibName char(10); Mbr char(10); FileType char(10); RcdFmt char(10); ActivatGroup char(10); ThreadID char(8); OpenOption char(1); Reserved char(3); TotalIO int(20); WriteCount int(20); ReadCount int(20); Write_Read int(20); OtherIO int(20); RRN int(20); SharedOpens int(20); end-ds; // Job identification information dcl-ds jidf0100DS inz qualified; JobName char(10); UserName char(10); JobNumber char(6); *n char(16) inz; // internal job ID *n char(2) inz(*allx'00'); // reserved *n int(10) inz(3); // thread indicator *n char(8) inz(*allx'00'); // thread id end-ds; dcl-ds GetAllocSizeDS qualified; SizeReturned int(10) pos(5); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; pJobnam char(10); pJobUsr char(10); pJobNbr char(6); end-pi; //--------------------------------------------------------- scDow = f_GetDayName(); sflrcdnbr = 1; DbUtility = '2=' + f_GetFileUtil(); scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 3=Record Formats'; FootF09 = 'F9=' + %trimr(%subst(DbUtility:3)) + ' PFs'; rrn = 0; KeyFld = 'IO'; OPNF0100ptr = %alloc(1); // so realloc will work jidf0100DS.JobName = pJobnam; jidf0100DS.UserName = pJobUsr; jidf0100DS.JobNumber = pJobNbr; exsr srRefreshScreen; //--------------------------------------------------------- 1b dow *on; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write msgctl; write sfooter1; exfmt sbfctl1; f_RmvSflMsg(ProgId); 2b if InfdsSflRcdNbr > 0; SflRcdNbr = InfdsSflRcdNbr; 2x else; SflRcdNbr = 1; 2e endif; 2b if (not Ind.sfldsp) or InfdsFkey in %list(f03 :f12); dealloc(n) OPNF0100ptr; *inlr = *on; return; 2x elseif InfdsFkey = f05; //re-sort by whatever sequence is active exsr srRefreshScreen; // sort by io 2x elseif InfdsFkey = f07; KeyFld = 'IO'; exsr srRefreshScreen; // sort by file name 2x elseif InfdsFkey = f08; KeyFld = 'FILENAME'; exsr srRefreshScreen; // view PFs that are open 2x elseif InfdsFkey = f09; exsr srViewPfData; exsr srRefreshScreen; 2x else; //--------------------------------------------------------- // as a precaution, limit options to those visible on screen //--------------------------------------------------------- readc sbfdta1; 3b dow not %eof; 4b if sboption in %list(1:2:3); f_RunOptionFile( sboption: sbFile: sbLib: '*FIRST': '*FIRST': ProgId); 4e endif; sboption = 0; update sbfdta1; SflRcdNbr = rrn; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- //--------------------------------------------------------- begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn = 0; // get open files list callp QDMLOPNF( GetAllocSizeDS: %len(GetAllocSizeDS): 'OPNF0100': jidf0100DS: 'JIDF0100': ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; //error occurred snd-msg %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); SflRcdNbr = 1; LV leavesr; 1e endif; OPNF0100ptr = %realloc(OPNF0100ptr: GetAllocSizeDS.SizeReturned); callp QDMLOPNF( opnf0100DS: GetAllocSizeDS.SizeReturned: 'OPNF0100': jidf0100DS: 'JIDF0100': ApiErrDS); //--------------------------------------------------------- // Problem is to sort by I/O, but total IO is sum of several fields. // Spin though offsets and total the 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 ascend by name or descend 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; sbFile = opRepeatDS.FileName; sbLib = opRepeatDS.LibName; // get object description QusrObjDS = f_QUSROBJD(sbFile + sbLib: '*FILE'); 2b if ApiErrDS.BytesReturned = 0 or sbLib = 'QTEMP '; sbMbrDev = opRepeatDS.Mbr; sbRcdFmt = opRepeatDS.RcdFmt; sbOpenOpt = *blanks; 3b if opRepeatDS.OpenOption = '0'; sbOpenOpt = 'I'; 3x elseif opRepeatDS.OpenOption = '1'; sbOpenOpt = 'O'; 3x elseif opRepeatDS.OpenOption = '2'; sbOpenOpt = 'IO'; 3e endif; 3b if sbLib = 'QTEMP '; sbText = *blanks; 3x else; sbText = QusrObjDS.Text; 3e endif; sbTotalIO = opRepeatDS.TotalIO; sbRrn = opRepeatDS.RRN; sbFileType = %lower(opRepeatDS.FileType); 2x else; sbMbrDev = *blanks; sbRcdFmt = *blanks; sbOpenOpt = *blanks; sbText = 'Not authorized'; sbTotalIO = 0; sbRrn = 0; sbFileType = *blanks; 2e endif; rrn = cc; write sbfdta1; opPtr += opnf0100DS.LenOpenEntry; 1e endfor; 1b if rrn < SflRcdNbr; SflRcdNbr = rrn; 1e endif; 1b if SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; endsr; //--------------------------------------------------------- // load array with distinct PF names //--------------------------------------------------------- begsr srViewPfData; bb = 0; 1b for cc = 1 to opnf0100DS.NumFilesRtrned; chain cc sbfdta1; 2b if sbFileType = 'pf' or sbFileType = 'lf'; FileLib = sbFile + sbLib; // if file type is LF, then go find first PF 3b if sbFileType = 'lf'; AllocatedSize = f_GetAllocatedSize(FileLib:'*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': FileLib: '*FIRST': '0': '*FILETYPE': '*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; ]]> '); //--------------------------------------------------------- // JCRJOBSR - Work with selected jobs // // add filter for Current User filter //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRJOBSD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define FunctionKeys /define Ind /define psds /define f_RunOptionJob /define f_Quscrtus /define f_RmvSflMsg /define f_GetDayName /define Qlgsort /COPY JCRCMDS,JCRCMDSCPY dcl-s FunctionType char(1); dcl-s Status char(10); dcl-s aJobq char(10); dcl-s aJobqLib char(10); dcl-s aSubSystem char(10); dcl-s aJobqStat like(sthreadsta); dcl-s LenofDataBuff int(10); dcl-s NumberOfKeys int(10) inz(7); dcl-s rrnsave like(rrn); dcl-s Filter char(10); dcl-s FilterLen uns(3); dcl-s IsGeneric ind; dcl-s IsSelected ind; dcl-s QuickSort char(200) based(qusljobptr); dcl-s SwapName char(10); dcl-s savrcdnbr like(sflrcdnbr); dcl-s tabtyp char(1) dim(9) ctdata perrcd(1); dcl-s tabdesc char(10) dim(9) alt(tabtyp); // Retrieve Jobq Info dcl-pr Qsprjobq extpgm('QSPRJOBQ'); *n char(145); // Receiver *n int(10) const; // Receiver Length *n char(8) const; // Api Format *n char(20) const; // Qualified JobQ Name *n like(ApiErrDS); end-pr; // List Jobs dcl-pr Qusljob extpgm('QUSLJOB'); *n char(20); // user space *n char(8) const; // api format *n char(26); // qualified job name *n char(10); // status *n like(ApiErrDS); *n char(1) const; // type jobs *n int(10); // number of keys *n char(16); // integer key array end-pr; // retrieve job list entries dcl-ds QusljobDS qualified based(QusljobPtr); JobName char(10) pos(1); UserName char(10) pos(11); JobNumber char(6) pos(21); IntJobID char(16) pos(27); JobStatus char(8) pos(43); JobType char(1) pos(53); KeyReturnCtn int(10) pos(61); CurrUser char(10) pos(101); end-ds; // load request key values dcl-ds KeyValues qualified; *n int(10) inz(0101); // active job status *n int(10) inz(0305); // active job status *n int(10) inz(0601); // function name *n int(10) inz(0602); // function type *n int(10) inz(1004); // job queue *n int(10) inz(1802); // runpty *n int(10) inz(1903); // status on queue end-ds; dcl-ds RunDS qualified; RunPriority int(10); // 1802 end-ds; dcl-ds keyds qualified based(uKeyPtr); LengthReturn int(10) pos(1); KeyField int(10) pos(5); LengthOfData int(10) pos(13); Data char(20) pos(17); end-ds; dcl-ds QSPRJOBQDS len(145) qualified; SubSys char(10) pos(63); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; pJobNameQual char(26); pJobStatus char(7); pThreadStat char(4); pCurrUser char(10); pSelectJobq char(10); end-pi; //--------------------------------------------------------- Status = pJobStatus; IsGeneric = *off; Toggle1 = 'User'; scDow = f_GetDayName(); // Extract jobq scan value and length of scan value 1b if not(pSelectJobq = '*ALL'); 2b if not (%subst(pSelectJobq: 10: 1) in %list(' ':'*')); Filter = pSelectJobq; FilterLen = 10; 2x else; aa = %scan('*': pSelectJobq: 1); 3b if aa > 0; IsGeneric = *on; 3x else; aa = %scan(' ': pSelectJobq: 1); 3e endif; Filter = %subst(pSelectJobq: 1: aa - 1); FilterLen = aa-1; 2e endif; 1e endif; //--------------------------------------------------------- // load user space with job information ApiHeadPtr = f_Quscrtus(UserSpaceName); exsr srRefresh; 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; f_RmvSflMsg(ProgId); savrcdnbr = InfdsSflRcdNbr; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; // sort by job name or user name 2x elseif InfdsFkey in %list(f09:f10); Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn = 0; qlgSortDS = %subst(qlgSortDS: 1: 80); //drop off keys QusljobPtr = ApiHeadPtr + ApiHead.OffSetToList; qlgsortDS.RecordLength = ApiHead.ListEntrySize; qlgsortDS.RecordCount = ApiHead.ListEntryCount; qlgsortDS.NumOfKeys = 1; 3b if InfdsFkey = f09; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1: 10); 3x else; 4b if Toggle1 = 'Current'; // current user qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(101: 10); 4x else; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(11: 10); 4e endif; 3e endif; qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); LenofDataBuff = ApiHead.ListEntryCount *ApiHead.ListEntrySize; callp QLGSORT( qlgsortDS: QuickSort: QuickSort: LenofDataBuff: LenofDataBuff: ApiErrDS); exsr srLoadFromUserSpace; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; SflRcdNbr = 1; 2x elseif InfdsFkey = f05; exsr srRefresh; 2x elseif InfdsFkey = f08; 3b if Toggle1 = 'User '; // swap column headings Toggle1 = 'Current'; 3x else; Toggle1 = 'User '; 3e endif; 3b for rrn = 1 to rrnsave; chain rrn sbfdta1; SwapName = sUserName; sUserName = sCurrUser; sCurrUser = SwapName; update sbfdta1; 3e endfor; sflrcdnbr = savrcdnbr; //--------------------------------------------------------- // process selected subfile records //--------------------------------------------------------- 2x elseif Ind.sfldsp; readc sbfdta1; 3b if %eof; *inlr = *on; return; 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 current screen sbfOption = 0; update sbfdta1; 4e endif; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- //--------------------------------------------------------- begsr srRefresh; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn = 0; callp QUSLJOB( UserSpaceName: 'JOBL0200': pJobNameQual: Status: ApiErrDS: '*': NumberOfKeys: KeyValues); exsr srLoadFromUserSpace; Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); snd-msg 'No Jobs were found'; 1e endif; Ind.sfldspctl = *on; SflRcdNbr = 1; endsr; //--------------------------------------------------------- // Process list entries in user space //--------------------------------------------------------- begsr srLoadFromUserSpace; QusljobPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; IsSelected = *on; 2b if not (QusljobDS.JobStatus in %list('*ACTIVE':'*JOBQ')); sFuncName = *blanks; sRunPty = *blanks; QusljobDS.JobType = *blanks; sThreadSta = *blanks; 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; 5b if not (pCurrUser in %list('*ALL ':sCurrUser)); IsSelected = *off; 3v leave; 5e endif; 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; aJobq = %subst(keyds.Data: 1: 10); // validate jobq selection; 6b if pSelectJobq = '*ALL' or (IsGeneric and %subst(aJobq: 1: FilterLen) = %subst(Filter: 1: FilterLen)) or (not IsGeneric and aJobq = Filter); 6x else; IsSelected = *off; 3v leave; 6e endif; aJobqLib = %subst(keyds.Data: 11: 10); // get jobq attached subsystem name callp QSPRJOBQ( QSPRJOBQDS: 145: 'JOBQ0100': aJobq + aJobqLib: ApiErrDS); aSubSystem = QSPRJOBQDS.SubSys; 5x elseif keyds.KeyField = 1903; aJobqStat = 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 %tlookup(QusljobDS.JobType: tabtyp: tabdesc); sJobType = tabdesc; 3x else; sJobType = *blanks; 3e endif; 2e endif; 2b if IsSelected; 3b if QusljobDS.JobStatus = '*JOBQ'; sJobType = aJobq; sFuncName = aJobqLib; sRunPty = aSubSystem; sThreadSta = aJobqStat; 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 in %list('*ALL':sThreadSta); rrn += 1; write sbfdta1; 3e endif; 2e endif; QusljobPtr += ApiHead.ListEntrySize; 1e endfor; rrnsave = rrn; endsr; ** Invalid 1 AAuto Start 2 BBatch 3 IInteractve 4 MSbs Monitr 5 RSpooledRdr 6 SSystem 7 WSpooledWtr 8 XSCPF 9 ]]> '); //--------------------------------------------------------- // JCRLICUSE - List users with license lock // Change product id and feature subfield to monitor whatever product. // Execute WRKLICINF command to get these values // Currently set to monitor license usage for ASC Sequel //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /COPY JCRCMDS,JCRCMDSCPY dcl-s TextString char(6800); dcl-s TextStringLen int(10) inz(6800); dcl-s LineOfText char(68) dim(100) based(ptr); dcl-s ptr pointer inz(%addr(TextString)); dcl-s MessageID char(7); dcl-s MessageFile char(20); dcl-s OutputFormat char(8) inz('LICR0200'); dcl-s ReceiverLen int(10) inz(%len(ReceiverDS)); dcl-s ProductFormat char(8) inz('LICP0100'); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s TotLicAlpha char(13); // Retrieve License Information dcl-pr QLZARTV extpgm('QLZARTV'); *n char(2065); // Receiver *n int(10); // Length of Receiver *n char(8); // Structure Format *n char(8); // Product ID *n char(8); // Product ID Format *n like(ApiErrDS); end-pr; dcl-ds JobDS len(26) qualified; JobName char(10) pos(1); UserName char(10) pos(11); Number char(6) pos(21); end-ds; // Similar to WRKLICINF command values dcl-ds ProductIDDS qualified; ProductID char(7) inz('0ASCSEQ'); ReleaseLevel char(6) inz('*ONLY'); Feature char(4) inz('5001'); end-ds; dcl-ds ReceiverDS len(2065) qualified inz; UsageLimit int(10) pos(9); UsageCount int(10) pos(13); UsersOffset int(10) pos(97); UsersCount int(10) pos(101); UserLength int(10) pos(105); end-ds; // Display Long Text dcl-pr QUILNGTX extpgm('QUILNGTX'); *n char(6800) options(*varsize); // Text *n int(10); // Text Length *n char(7); // Message ID *n char(20); // Message File Name *n like(ApiErrDS); end-pr; //--------------------------------------------------------- callp 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 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 callp QUILNGTX( TextString: TextStringLen: MessageID: MessageFile: ApiErrDS); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Find Desired Access Path') PARM KWD(MBR) TYPE(*CHAR) LEN(10) CONSTANT('*FIRST') PARM KWD(FILE) TYPE(FILE) MIN(1) CHOICE('Long or + Short File Name') PROMPT('File') FILE: QUAL TYPE(*NAME) LEN(130) 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') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA A PRINT A CA03 A CF07 A CA12 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 SCPOS6A 1A P A SCPOS7A 1A P A SCPOS8A 1A P A SCPOS9A 1A P A SCSELECT 1A B 5 5 A SCKEYNAM 10A O 5 7 A SCPOS1 1A O 5 18DSPATR(&SCPOS1A) A SCPOS2 1A O 5 20DSPATR(&SCPOS2A) A SCPOS3 1A O 5 22DSPATR(&SCPOS3A) A SCPOS4 1A O 5 24DSPATR(&SCPOS4A) A SCPOS5 1A O 5 26DSPATR(&SCPOS5A) A SCPOS6 1A O 5 28DSPATR(&SCPOS6A) A SCPOS7 1A O 5 30DSPATR(&SCPOS7A) A SCPOS8 1A O 5 32DSPATR(&SCPOS8A) A SCPOS9 1A O 5 34DSPATR(&SCPOS9A) A SCKEYTXT 38A O 5 39 A SCDATATYPE 16A O 5 78 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0063) A SFLPAG(0021) 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 24'Find Desired Access Path' A DSPATR(HI) A SCDOW 9A O 1108COLOR(BLU) A 1118DATE A EDTCDE(Y) A COLOR(BLU) A 2 5'File:' A COLOR(WHT) A SCOBJHEAD 63A O 2 11 A 2108SYSNAME A COLOR(BLU) A 3 5'X select key in any position or 1,- A 2,3,4,5,6,7,8,9 to select key field- A position(s).' A COLOR(BLU) A 4 5' ' A DSPATR(UL) A DSPATR(HI) A 4 7'Key Field ' A DSPATR(UL) A DSPATR(HI) A 4 18'Key Position ' A DSPATR(UL) A DSPATR(HI) A 4 39'Text - A ' A DSPATR(UL) A DSPATR(HI) A 4 78'Data Type ' A DSPATR(HI) A DSPATR(UL) *---------------------------------------------------------------- A R SFOOTER1 A AFOOTERMSG 1A P A 27 2'F3=Exit' COLOR(BLU) A FOOTERMSG 41 O 27 15DSPATR(&AFOOTERMSG) A 27 69'F12=Cancel' COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Finds logical files or access paths 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 the logical files. Select to include/exclude files with select/omits from the search. :P.Select an X by the field name to list logicals with that key field in any position. If key is needed in a certain position or sequence 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. ]]> '); //--------------------------------------------------------- // JCRLKEYR - Find desired access path //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRLKEYD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define f_BuildString /define FunctionKeys /define Ind /define Qdbldbr /define Qdbrtvfd /define Quslfld /define Dspatr /define BitMask /define f_GetQual /define f_GetDayName /define f_Quscrtus /define f_GetDataTypeKeyWords /define f_CamelCase /define f_SndCompMsg /define p_JCRLONGFIL /COPY JCRCMDS,JCRCMDSCPY dcl-s KeyField char(10); dcl-s WorkFileQual char(20); dcl-s ForCount3 uns(5); dcl-s IsKeysLoaded ind; dcl-s SaveMessage like(footermsg); dcl-s unsignedlength uns(10); dcl-s DecimalPos char(2); // File description display driver dcl-pr p_JCRFDR extpgm('JCRFDR'); *n char(10) const; *n char(20); *n char(10) const; *n char(10) const; *n char(4) const; *n char(101); *n char(10) const; end-pr; dcl-ds *n; KeysArry char(19) dim(1000) inz; FldsArry char(10) overlay(keysarry:1); Pos1Arry char(1) overlay(keysarry:11); Pos2Arry char(1) overlay(keysarry:12); Pos3Arry char(1) overlay(keysarry:13); Pos4Arry char(1) overlay(keysarry:14); Pos5Arry char(1) overlay(keysarry:15); Pos6Arry char(1) overlay(keysarry:16); Pos7Arry char(1) overlay(keysarry:17); Pos8Arry char(1) overlay(keysarry:18); Pos9Arry char(1) overlay(keysarry:19); end-ds; // map screen fields dcl-ds *n; scPos1; scPos2; scPos3; scPos4; scPos5; scPos6; scPos7; scPos8; scPos9; scPosArry char(1) dim(9) samepos(scPos1); // key positions end-ds; dcl-ds *n; scPos1a; scPos2a; scPos3a; scPos4a; scPos5a; scPos6a; scPos7a; scPos8a; scPos9a; scPosArryA char(1) dim(9) samepos(scPos1a); // position attributes end-ds; //--------------------------------------------------------- // Load keys selected from subfile into single field so it can be easily // passed as parameter to data base relations display program p_JCRFDR. //--------------------------------------------------------- dcl-ds ParmDS qualified; KeyFields char(10) dim(9); KeyPosition zoned(1) dim(9); SelectOmit ind; IsFoundKey ind; end-ds; dcl-s p_FileQual char(20); dcl-s shortfil char(10); //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_LongFileQual char(140); p_IncludeSO char(4); end-pi; //--------------------------------------------------------- callp p_JCRLONGFIL(p_LongFileQual: shortfil); p_FileQual = shortfil + %subst(p_LongFileQual:131); aFooterMsg = Blue; 1b if p_IncludeSO = '*YES'; ParmDS.SelectOmit = '1'; FooterMsg = 'F7=Exclude Select/Omit logicals'; 1x else; ParmDS.SelectOmit = '0'; FooterMsg = 'F7=Include Select/Omit logicals'; 1e endif; SaveMessage = FooterMsg; scDow = f_GetDayName(); //--------------------------------------------------------- ApiHeadPtr = f_Quscrtus(UserSpaceName); AllocatedSize = f_GetAllocatedSize(p_FileQual: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': p_FileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); // if selected file is a logical, extract based-on-physical name. fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 1b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; 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 *on; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); dealloc(n) Fild0100ptr; f_SndCompMsg('JCRLKEY for ' + f_GetQual(p_FileQual) + ' - completed'); *inlr = *on; return; 2e endif; 2b if (not Ind.sfldsp); 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 Select/Omit logicals'; 3x else; FooterMsg = 'F7=Include 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 > 9; 2v leave; 4e endif; ParmDS.KeyFields(aa) = scKeyNam; // load zero if do not care about position 4b if scSelect in %range('1':'9'); ParmDS.KeyPosition(aa) = %uns(scSelect); 4x else; ParmDS.KeyPosition(aa) = 0; 4e endif; scSelect = *blanks; update sbfdta1; 3e endif; SflRcdNbr = rrn; readc sbfdta1; 2e enddo; // call data base relations display program 2b if IsKeysLoaded; callp p_JCRFDR( '*FIRST': p_LongFileQual: '*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; //--------------------------------------------------------- begsr srGetDataBaseRelations; FldsArry(*) = *blanks; KeysArry(*) = *blanks; aa = 0; bb = 0; rrn = 0; SflRcdNbr = 1; Ind.sfldspctl = *off; write sbfctl1; // retrieve data base relation names callp QDBLDBR( UserSpaceName: 'DBRL0100': p_FileQual: '*ALL': '*ALL': ApiErrDS); // Process list entries in user space QdbldbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 0 to ApiHead.ListEntryCount; // put PF first in output 2b if ForCount > 0; WorkFileQual = QdbldbrDS.DependentFile; 2x else; WorkFileQual = p_FileQual; 2e endif; 2b if not (WorkFileQual in %list(' ':'*NONE')); AllocatedSize = f_GetAllocatedSize(WorkFileQual: '*FIRST'); 3b if ApiErrDS.BytesReturned = 0; Fild0100ptr = %realloc(Fild0100ptr: AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': WorkFileQual: '*ALL': '0': '*FILETYPE': '*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, only care about 9 levels down list. 5b if %bitand(bit6: Fild0100ds.TypeBits) = bit6; // 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'; 7x elseif ForCount2 = 6; Pos6Arry(bb) = '6'; 7x elseif ForCount2 = 7; Pos7Arry(bb) = '7'; 7x elseif ForCount2 = 8; Pos8Arry(bb) = '8'; 7x elseif ForCount2 = 9; Pos9Arry(bb) = '9'; 7e endif; KeySpecsPtr += 32; 6e endfor; 5e endif; 4e endif; 3e endif; 2e endif; 2b if ForCount > 0; QdbldbrPtr += ApiHead.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 to user space //--------------------------------------------------------- begsr srKeyFieldAttributes; callp QUSLFLD( UserSpaceName: 'FLDL0100': p_FileQual: '*FIRST': '0': ApiErrDS); //--------------------------------------------------------- // Process from array so subfile is sorted. // Spin through user space comparing field names, // when one is found, write subfile record. //--------------------------------------------------------- 1b for ForCount3 = 1 to aa; QuslfldPtr = ApiHeadPtr + ApiHead.OffSetToList; 2b for ForCount = 1 to ApiHead.ListEntryCount; KeyField = QuslfldDS.FieldName; 3b if KeyField = FldsArry(ForCount3); scSelect = *blanks; scKeyNam = KeyField; scKeyTxt = f_camelcase(QuslfldDS.FieldText); scPos1 = Pos1Arry(ForCount3); scPos2 = Pos2Arry(ForCount3); scPos3 = Pos3Arry(ForCount3); scPos4 = Pos4Arry(ForCount3); scPos5 = Pos5Arry(ForCount3); scPos6 = Pos6Arry(ForCount3); scPos7 = Pos7Arry(ForCount3); scPos8 = Pos8Arry(ForCount3); scPos9 = Pos9Arry(ForCount3); 4b for cc = 1 to 9; 5b if scPosArry(cc) = ' '; scPosArryA(cc) = Blue; scPosArry(cc) = '.'; 5x else; scPosArryA(cc) = Green; 5e endif; 4e endfor; //--------------------------------------------------------- // load data type //--------------------------------------------------------- 4b if QuslfldDS.Digits > 0; // numeric unsignedlength = QuslfldDS.Digits; DecimalPos = %triml(%editc(QuslfldDS.DecimalPos:'3')); 4x else; unsignedlength = QuslfldDS.FieldLengthA; DecimalPos = *blanks; 4e endif; scDataType = %scanrpl(';':' ': f_GetDataTypeKeyWords( QuslfldDS.FieldType: unsignedlength: DecimalPos)); rrn += 1; write sbfdta1; 2v leave; 3e endif; QuslfldPtr += ApiHead.ListEntrySize; 2e endfor; 1e endfor; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Previously Executed Commands') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA12 CA21 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 EDTCDE(Y) COLOR(BLU) A 2 72SYSNAME COLOR(BLU) A 3 2'1=Run' COLOR(BLU) A 3 8'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Retrieves all commands executed from command line. (Never press F9 Again!). A distinct subfile list is presented to execute or prompt each command. :EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRLOGR - Retrieve previously executed commands // loop through Qmhrtvrq API call to get all previous executed commands // load and display subfile of distinct commands. // prompt selection and execution of commands //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRLOGD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define Dspatr /define FunctionKeys /define Ind /define Qcmdchk /define Quscmdln /define psds /define f_RtvMsgApi /define f_RmvSflMsg /define f_SndCompMsg /define f_RunCmd /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY // Retrieve Message dcl-pr Qmhrtvrq extpgm('QMHRTVRQ'); *n like(rtvq0100DS); // message information *n int(10) const; // message length *n char(8) const; // format name *n char(10) const; // message type *n char(4); // message key *n like(ApiErrDS); end-pr; dcl-ds rtvq0100DS qualified; BytesReturned int(10) pos(1); BytesAvail int(10) pos(5); MsgKey char(4) pos(9); MsgLenReturn int(10) pos(33); MsgLenAvail int(10) pos(37); MsgText char(500) pos(41); MsgText2 char(2) samepos(MsgText); MsgText6 char(6) samepos(Msgtext); end-ds; dcl-s MsgKey char(4); dcl-s MsgType char(10); dcl-s CmdList char(500) dim(500); dcl-s CmdCount uns(5); //--------------------------------------------------------- scDow = f_GetDayName(); exsr srRefreshScreen; 1b dow *on; write msgctl; write sbfctl1; exfmt sfooter1; 2b if (not Ind.sfldsp) or InfdsFkey in %list(f03 :f12); f_SndCompMsg('JCRLOG - completed'); *inlr = *on; return; 2x elseif InfdsFkey = f05; exsr srRefreshScreen; 2x elseif InfdsFkey = f21; //command line callp(e) QUSCMDLN(); 2x else; f_RmvSflMsg(ProgId); readc sbfdta1; 3b dow not %eof; aCmdMsg = Green; 4x if sbfOption = '2'; f_RunCmd('?' + FullCmd); 4b elseif sbfOption > ' '; f_RunCmd(%trimr(FullCmd)); 4e endif; 4b if ApiErrDS.BytesReturned > 0; //error occurred aCmdMsg = %bitor(White: RI); snd-msg ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); 4x else; snd-msg %trimr(%subst(FullCmd: 1: 60)) + ' - completed'; 4e endif; // Update subfile to reflect selected change sbfOption = *blanks; s1recnum = rrn; update sbfdta1; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; aCmdMsg = Green; rrn = 0; write sbfctl1; CmdCount = 0; 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 not(rtvq0100DS.MsgText2 = '/*' or rtvq0100DS.MsgText6 in %list('jcrlog':'JCRLOG':'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 CmdCount = 0 or %lookup(FullCmd: CmdList: 1: CmdCount) = 0; CmdCount += 1; CmdList(CmdCount) = 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; f_RmvSflMsg(ProgId); s1recnum = 1; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; endsr; ]]> '); //--------------------------------------------------------- // JCRLONGFIL - return short file from passed in long file //--------------------------------------------------------- ctl-opt ALWNULL(*INPUTONLY); /define ControlStatements /define f_IsValidObj /COPY JCRCMDS,JCRCMDSCPY dcl-f QADBXLFN keyed rename(QDBXREF:longf) usropn; // check long file name dcl-f QADBXLFI keyed rename(QDBXREF:liblongf) usropn; // check lib.long file name dcl-s shortfilqual char(20); dcl-s llib char(10); dcl-s lfil varchar(130); dcl-s lfilkey char(130); dcl-s shortfil char(10); //--*ENTRY------------------------------------------------- dcl-pi *n; p_FileQual char(140); p_OutShortFil char(10); end-pi; p_OutShortFil = *blanks; shortfil = %subst(p_FileQual:1:10); lfil = %trimr(%subst(p_FileQual:1:130)); // var char llib = %subst(p_FileQual:131); lfilkey = %subst(p_FileQual:1:130); 1b if %len(lfil) < 11; p_OutShortFil = shortfil; 1x elseif llib <> '*LIBL'; open QADBXLFI; chain (llib: lfilkey) liblongf; 2b if %found; p_OutShortFil = DBXFIL; 2e endif; // little more strenuous as have to find long name in your libl // spin through until first object is found 1x elseif llib = '*LIBL'; open QADBXLFN; setll (lfilkey) longf; reade (lfilkey) longf; 2b dow not %eof; 3b if f_IsValidObj(DBXFIL: llib: '*FILE'); p_OutShortFil = DBXFIL; 2v leave; 3e endif; reade (lfilkey) longf; 2e enddo; 1e endif; *inlr = *on; return; ]]> */ /* add *parm as output, see help text for usage */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Pgm/Mod/Srvpgm Source') PARM KWD(PGM) TYPE(PGM) MIN(1) PROMPT('Programs') PGM: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT *OUTFILE *PARM) + PROMPT('Output') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) + PROMPT('Outfile') OUTFILE: QUAL TYPE(*NAME) LEN(10) 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') ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRLSRCF; CREATE TABLE JCRLSRCF ( LPGM CHAR(10) NOT NULL DEFAULT '' , LSRCLIB CHAR(10) NOT NULL DEFAULT '' , LSRCFIL CHAR(10) NOT NULL DEFAULT '' , LSRCMBR CHAR(10) NOT NULL DEFAULT '' , LSRCATTR CHAR(8) NOT NULL DEFAULT '' , LCREATEDT CHAR(10) NOT NULL DEFAULT '' , LLASTUSED CHAR(10) NOT NULL DEFAULT '' , LDAYSUSED DECIMAL(4, 0) NOT NULL DEFAULT 0 , LOBJTEXT CHAR(41) NOT NULL DEFAULT '' ) RCDFMT JCRLSRCFR ; LABEL ON TABLE JCRLSRCF IS 'Source location - Pgm/Mod/Srvpgm info jcr' ; LABEL ON COLUMN JCRLSRCF ( LPGM TEXT IS 'Pgm Name' , LSRCLIB TEXT IS 'Source Lib' , LSRCFIL TEXT IS 'Source File' , LSRCMBR TEXT IS 'Source Mbr' , LSRCATTR TEXT IS 'Source Attr' , LCREATEDT TEXT IS 'Create Date' , LLASTUSED TEXT IS 'Last Used' , LDAYSUSED TEXT IS 'Days Used' , LOBJTEXT TEXT IS 'Text' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRLSRCF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Lists or generates outfile of source lib, file, member for selected program type in selected 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/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print, outfile, parm, or * display the source results. :NT.*PARM was added so other programs could call the JCRLSRCR program direct. If you select *PARM in a program call, entry parameter p_pgmqual will contain 1-10 Source File 11-20 Source Library and 1-10 of p_OutFileQual is source member.:ENT. :EHELP. :HELP NAME='JCRLSRC/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRLSRC/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRLSRC' A 20'List Pgm/Mod/Srvpgm Source Informa- A tion' A SCDOW 9A O 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'Library:' A HEADLIB 10A 11 A 24'Program Select:' A HEADPGM 10A 41 A 81'Days' SPACEA(1) *--- A 2'Program' A 14'SourceLib' A 26'SourceFile' A 38'Mbr/Module' A 50'MbrAttr' A 60'Created' A 71'LastUsed' A 81'Used' A 87'Text' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A LPGM 10A 2 A LSRCLIB 10A 14 A LSRCFIL 10A 26 A LSRCMBR 10A 38 A LSRCATTR 8A 50 A LCREATEDT 10A 59 A LLASTUSED 10A 70 A LDAYSUSED 4 0 81EDTCDE(4) A LOBJTEXT 41A 87 *---------------------------------------------------------------- A R PRTMESSAGE SPACEB(2) A VMESSAGE 100A 3 ]]> '); //--------------------------------------------------------- // JCRLSRCR - List Pgm/Mod/Srvpgm Source information //--------------------------------------------------------- // If you call with output = *PARM // entry parameter p_pgmqual will return // 1-10 Source File 11-20 Source Library and 1-10 of p_OutFileQual // is source member name. //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define FunctionKeys /define Qbnlpgmi /define Qbnrmodi /define Qclrpgmi /define Qbnlspgm /define Quslobj /define f_Qusrobjd /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_DisplayLastSplf // *ENTRY /define p_JCRLSRCR /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRLSRCP printer oflind(IsOverFlow) usropn; dcl-f JCRLSRCF usage(*output) extfile(extOfile) extmbr(ExtOmbr) usropn; dcl-s extOmbr char(10); dcl-s IsPrintEndOfReport ind; dcl-s aster char(10) inz(*all'*'); //--------------------------------------------------------- headpgm = %subst(p_PgmQual: 1: 10); headLib = %subst(p_PgmQual: 11: 10); f_SndStatMsg(f_BuildString('List source for & - in progress': f_GetQual(p_PgmQual))); scDow = 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 elseif p_Output in %list('*':'*PRINT '); f_OvrPrtf('JCRLSRCP': '*JOB': HeadPgm); open JCRLSRCP; write PrtHead; IsOverFlow = *off; 1x elseif p_Output = '*PARM '; // place holder 1e endif; ApiHeadPtr = f_Quscrtus(UserSpaceName); ApiHeadPtr2 = f_Quscrtus(UserSpaceName2); // Load program object names into user space callp QUSLOBJ( UserSpaceName: 'OBJL0100': p_PgmQual: '*ALL': ApiErrDS); // load print file field, print error message 1b if ApiErrDS.BytesReturned > 0; vMessage = ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); 2b if p_Output = '*OUTFILE'; close JCRLSRCF; f_SndCompMsg(vMessage); *inlr = *on; return; 2x elseif p_Output in %list('*':'*PRINT '); exsr srWriteAsterisk; exsr srSendCompletMsg; 2x elseif p_Output = '*PARM '; p_PgmQual = *all'?'; p_OutFileQual = *all'?'; p_OutMbrOpt = vMessage; *inlr = *on; return; 2e endif; 1e endif; // if no matching objects found, print error message 1b if ApiHead.ListEntryCount = 0; vmessage = 'No matching program objects found.'; 2b if p_Output = '*OUTFILE'; f_SndCompMsg(vMessage); *inlr = *on; return; 2x elseif p_Output in %list('*':'*PRINT '); exsr srWriteAsterisk; exsr srSendCompletMsg; 2x elseif p_Output = '*PARM '; p_PgmQual = *all'?'; p_OutFileQual = *all'?'; p_OutMbrOpt = vMessage; *inlr = *on; return; 2e endif; 1e endif; //--------------------------------------------------------- // spin through and retrieve all program object names //--------------------------------------------------------- QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if QuslobjDS.ObjTyp in %list('*PGM':'*MODULE':'*SRVPGM'); exsr srBuildPrint; 2e endif; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; //--------------------------------------------------------- // if no matching objects found, print message and exit 1b if p_Output in %list('*':'*PRINT '); 2b if not IsPrintEndOfReport; vmessage = 'No matching program objects found.'; exsr srWriteAsterisk; 2x else; // end of report vmessage = ' ** End Of Report'; write PrtMessage; 2e endif; 1e endif; exsr srSendCompletMsg; //--------------------------------------------------------- //--------------------------------------------------------- begsr srBuildPrint; IsPrintEndOfReport = *on; QusrObjDS = f_QUSROBJD(QuslobjDS.ObjNam + QuslobjDS.ObjLib: QuslobjDS.ObjTyp: 'OBJD0400'); lCreateDt = f_GetApiISO(QusrobjDS.CreateDateTime); 1b if QusrobjDS.NumDaysUsed > 9999; lDaysUsed = 9999; 1x else; lDaysUsed = QusrobjDS.NumDaysUsed; 1e endif; 1b if QusrobjDS.NumDaysUsed > 0; lLastUsed = f_GetApiISO(QusrobjDS.LastUsedDate + ' '); 1x else; lLastUsed = *blanks; 1e endif; //----------------------------- 1b if QuslobjDS.ObjTyp = '*SRVPGM'; callp QBNLSPGM( UserSpaceName2: 'SPGL0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); 2b if ApiErrDS.BytesReturned > 0; //Source not available f_FmtPrint(aster: aster: aster); exsr srPrintLine; 2x else; SrvPgmPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 3b for ForCount2 = 1 to ApiHead2.ListEntryCount; f_FmtPrint(SrvPgmDs.SrcFil: SrvPgmDs.SrcLib: SrvPgmDs.SrcMbr); lSrcAttr = SrvPgmDs.SrcAttrb; exsr srPrintLine; SrvPgmPtr += ApiHead2.ListEntrySize; 3e endfor; 2e endif; //----------------------------- 1x elseif QuslobjDS.ObjTyp = '*MODULE'; callp QBNRMODI( QbnrmodiDS: %len(QbnrmodiDS): 'MODI0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); f_FmtPrint(QbnrmodiDS.SrcFil: QbnrmodiDS.SrcLib: QbnrmodiDS.SrcMbr); exsr srPrintLine; 1x else; //----------------------------- // check ILE / non-ILE callp QCLRPGMI( QclrpgmiDS: %len(QclrpgmiDS): 'PGMI0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); // OPM------------------ 2b if QclrpgmiDS.PgmType = ' '; f_FmtPrint(QclrpgmiDS.SrcFil: QclrpgmiDS.SrcLib: QclrpgmiDS.SrcMbr); lSrcAttr = QclrpgmiDS.SrcAttrb; exsr srPrintLine; // ILE--------------- 2x elseif QclrpgmiDS.PgmType = 'B'; callp QBNLPGMI( UserSpaceName2: 'PGML0100': QuslobjDS.ObjNam + QuslobjDS.ObjLib: ApiErrDS); 3b if ApiErrDS.BytesReturned > 0; //Source not available f_FmtPrint(aster: aster: aster); exsr srPrintLine; 3x else; QbnlpgmiPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 4b for ForCount2 = 1 to ApiHead2.ListEntryCount; f_FmtPrint(QbnlpgmiDS.SrcFil: QbnlpgmiDS.SrcLib: QbnlpgmiDS.SrcMbr); lSrcAttr = QbnlpgmiDS.SrcAttrb; exsr srPrintLine; QbnlpgmiPtr += ApiHead2.ListEntrySize; 4e endfor; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srPrintLine; lPgm = QuslobjDS.ObjNam; lSrcAttr = QusrObjDS.ExtendedAttr; lObjText = QusrObjDS.Text; 1b if p_Output = '*OUTFILE'; write JCRLSRCFR; 1x elseif p_Output in %list('*':'*PRINT '); write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; // return 1st member found 1x elseif p_Output = '*PARM '; p_PgmQual = lSrcFil + lSrcLib; p_OutFileQual = lSrcMbr; p_OutMbrOpt = lObjText; *inlr = *on; return; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srWriteAsterisk; lPgm = aster; lSrcLib = aster; lSrcFil = aster; lSrcMbr = aster; lSrcAttr = aster; lCreateDt = *blanks; lDaysUsed = 0; lLastUsed = *blanks; lObjText = aster; write PrtDetail; write PrtMessage; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srSendCompletMsg; 1b if p_Output = '*OUTFILE'; close JCRLSRCF; f_SndCompMsg('File ' +%trimr(extOfile)+ ' generated by JCRLSRC'); 1x else; close JCRLSRCP; f_Dltovr('JCRLSRCP'); f_DisplayLastSplf('JCRLSRCR': p_Output); 1e endif; *inlr = *on; return; endsr; //---------------------------------------------------------------- // global function to tidy up mainline code for loading print fields //---------------------------------------------------------------- dcl-proc f_FmtPrint; dcl-pi *n; pFile char(10); pLib char(10); pMbr char(10); end-pi; 1b if ApiErrDS.BytesReturned > 0; //Source not available lSrcFil = aster; lSrcLib = aster; lSrcMbr = aster; 1x else; lSrcFil = pFile; lSrcLib = pLib; lSrcMbr = pMbr; 1e endif; return; end-proc; ]]> '); //--------------------------------------------------------- // JCRLSRCV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_OutFileCrtDupObj // *ENTRY /define p_JCRLSRCR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- 1b if not(%subst(p_PgmQual: 11: 10) = '*LIBL'); f_CheckObj(%subst(p_PgmQual: 11: 10) + 'QSYS': '*LIB'); 1e endif; 1b if p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRLSRCF'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Show Procedure Locations') PARM KWD(PGMNAM) TYPE(PGNNAM) MIN(1) PGM(*YES) + PROMPT('Program Object') PGNNAM: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OBJTYP) TYPE(*CHAR) LEN(10) CONSTANT('*PGM') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.Shows internal and external procedure source locations in selected pgm.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRMIKE/PGMNAM'.PGMNAM Object Name - Help :XH3.PGMNAM Object Name (PGMNAM) :P.Display file and library to be analyzed.:EHELP. :HELP NAME='JCRMIKE/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.*PRINT or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 198) A R PRTHEAD SKIPB(1) SPACEA(2) A SCOBJHEAD 99A 2 A SCSYSTEM 8A +2 A SCDOW 9A O 113 A 123DATE EDTCDE(Y) *---------------------------------------------------------------- A R PRTLINE SPACEA(1) A JCRPROC 74A 1 A LSRCFIL 10A 50 A LSRCLIB 10A 61 A JCRSRVPGM 10A +1 A JCRSRVPGML 10A +1 ]]> '); //--------------------------------------------------------- // JCRMIKER - show programs procedure location / source code // use call and outfile from JCRLSRC to get source code location //--------------------------------------------------------- // 11/7/2016 D.Donohue - Added Column Headings to report //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Qbnlspgm /define Qbnlpgmi /define f_BuildString /define f_GetQual /define f_SndEscapeMsg /define f_Quscrtus /define f_Qusrobjd /define f_RunCmd /define f_GetDayName /define f_GetInternalProcNames /define f_Qusrmbrd /define f_RtvMsgAPI /define f_OvrPrtf /define f_DltOvr /define f_DisplayLastSplf /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRLSRCF usropn extfile('QTEMP/JCRLSRCF'); dcl-f JCRMIKEP printer oflind(IsOverFlow) usropn; //--------------------------------------------- // Prototypes internal to the program source //---------------------------------------------- dcl-ds InternalPR qualified; Cnt uns(5); Arry char(74) dim(500); end-ds; //--------------------------------------------------------- dcl-s extOmbr char(10); dcl-s LibObjQual char(21); dcl-s PgmSpace char(20) inz('JCRPGM QTEMP'); dcl-s SrvPgmSpace char(20) inz('JCRSRVPGM QTEMP'); dcl-s jcrProc char(74); dcl-s jcrSrvPgm char(10); dcl-s jcrSrvPgmL char(10); dcl-s xx uns(5); //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_ObjTyp char(10); p_Output char(8); end-pi; //--------------------------------------------------------- f_OvrPrtf('JCRMIKEP': '*JOB': %subst(p_ObjQual: 1: 10)); open JCRMIKEP; scDow = f_GetDayName(); QusrObjDS = f_QUSROBJD(p_ObjQual: p_ObjTyp); %subst(p_ObjQual: 11: 10) = QusrObjDS.ReturnLib; scObjHead = f_BuildString('& Program: & & &': 'JCRMIKE': QusrObjDS.ObjNam: QusrObjDS.ReturnLib: QusrObjDS.Text); write PrtHead; IsOverFlow = *off; LibObjQual = f_GetQual(p_ObjQual); // UPREHS MODIFICATION - Print Column headings jcrProc = 'Procedure name'; lsrcfil = 'Src File'; lsrclib = 'SrcF Lib'; jcrSrvPgm = 'SvcPgm'; jcrSrvPgmL = 'SvcPgmLib'; write prtLine; f_RunCmd('JCRLSRC PGM(' + %trimr(LibObjQual) + ') OUTPUT(*OUTFILE) OUTFILE(QTEMP/JCRLSRCF)'); open JCRLSRCF; read JCRLSRCFR; 1b if %eof; // throw expection here later as source not found; // how big an error? warning? decide later 1e endif; close JCRLSRCF; QusrmbrdDS = f_Qusrmbrd(lSrcFil + lSrcLib: lSrcMbr: 'MBRD0100'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; InternalPR = f_GetInternalProcNames(lSrcMbr: lSrcFil + lSrcLib); 1b if InternalPr.Cnt > 0; 2b for-each jcrProc in %subarr(InternalPr.Arry:1:InternalPr.Cnt); jcrSrvPgm = %subst(p_ObjQual: 1: 10); jcrSrvPgmL = %subst(p_ObjQual: 11: 10); write prtline; 3b if IsOverFlow; write prthead; IsOverFlow = *off; 3e endif; 2e endfor; 1e endif; ApiHeadPtr = f_Quscrtus(PgmSpace); ApiHeadPtr2 = f_Quscrtus(SrvPgmSpace); f_GetProceduresinPgm(QusrObjDS.ObjNam: QusrObjDS.ReturnLib); close JCRMIKEP; f_DltOvr('JCRMIKEP'); f_DisplayLastSplf('JCRMIKER': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Execute a API to get all service program names used in a program. // Then execute the f_GetSrvPgm to print them out. //--------------------------------------------------------- dcl-proc f_GetProceduresinPgm; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; dcl-ds Pgml0200DS qualified based(Pgml0200PTR); Name char(10) pos(21); Lib char(10) pos(31); end-ds; callp QBNLPGMI( PgmSpace: 'PGML0200': p_ObjName + p_ObjLib: ApiErrDS); Pgml0200Ptr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if Pgml0200DS.Lib <> 'QSYS'; 3b if Pgml0200DS.Lib <> *blanks; Pgml0200DS.Lib = '*LIBL'; 3e endif; f_GetSrvPgm(Pgml0200DS.Name:Pgml0200DS.Lib); 2e endif; Pgml0200Ptr += ApiHead.ListEntrySize; 1e endfor; return; end-proc; //--------------------------------------------------------- dcl-proc f_GetSrvPgm; dcl-pi *n; p_ObjName char(10); p_ObjLib char(10); end-pi; jcrSrvPgm = p_ObjName; jcrSrvPgmL = p_ObjLib; callp QBNLSPGM( SrvPgmSpace: 'SPGL0600': p_ObjName + p_ObjLib: ApiErrDS); SrvPgmPtr = ApiHeadPtr2 + ApiHead2.OffSetToList; 1b for ForCount2 = 1 to ApiHead2.ListEntryCount; JCRProc = %subst(SrvPgmDS.BigProcName: 1: SrvPgmDS.LengthOfName); f_RunCmd('+ JCRLSRC PGM(' + %trim(jcrSrvPgmL) + '/' + %trim(jcrSrvPgm)+ ') OUTPUT(*OUTFILE) OUTFILE(QTEMP/JCRLSRCF)'); open JCRLSRCF; read JCRLSRCFR; 2b if %eof; // throw expection here later as source not found; // how big an error? warnig? decide later 2e endif; close JCRLSRCF; write prtline; 2b if IsOverFlow; write prthead; IsOverFlow = *off; 2e endif; SrvPgmPtr += ApiHead2.ListEntrySize; 1e endfor; return; end-proc; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print Big Characters') PARM KWD(CHARACTERS) TYPE(*CHAR) LEN(10) MIN(1) + ALWUNPRT(*NO) PGM(*NO) PROMPT('String of + Characters') ]]> .*-------------------------------------------------------------------- :P.Print twelve line high by thirteen column wide characters from the selected input.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRMRBIG/CHARACTERS'.String of Characters - Help :XH3.String of Characters (CHARACTERS) :P.Character string to be big printed. :PARML.:PT.characters :PD.Any keyboard character.:EPARML.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTDETAIL A PRINTLINE 130 2 A SPACEA(1) ]]> '); //--------------------------------------------------------- // JCRMRBIGR - Print big 12 row by 13 column characters // Load 2d array with column.row for each character. //--------------------------------------------------------- /define ControlStatements /define Constants /define f_DisplayLastSplf /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRMRBIGP printer oflind(IsOverFlow) usropn; dcl-s PrintRow uns(3); dcl-s ThisChar uns(3); dcl-ds PrintLine; PrintLineArray char(13) dim(10); end-ds; dcl-ds BigChar dim(10) qualified; row char(13) dim(12); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; pString char(10); end-pi; //--------------------------------------------------------- open JCRMRBIGP; pString = %upper(pString); // Load 2d array with big characters 1b for ThisChar = 1 to 10; BigChar(ThisChar).Row(*) = f_GetChar(%subst(pString: ThisChar: 1)); 1e endfor; //--------------------------------------------------------- // Each PrintRow is 'slice' of large characters for printing // at 1, the top row of all 10 big characters will print. // at each iteration, the next row will print until all 12 lines are printed //--------------------------------------------------------- 1b for PrintRow = 1 to 12; 2b for ThisChar = 1 to 10; PrintLineArray(ThisChar) = BigChar(ThisChar).Row(PrintRow); 2e endfor; write PrtDetail; 1e endfor; close JCRMRBIGP; f_DisplayLastSplf('JCRMRBIGR': '*'); *inlr = *on; return; //--------------------------------------------------------- // Load arry with big characters //--------------------------------------------------------- dcl-proc f_GetChar; dcl-pi *n char(13) dim(12); pBaseChar char(1) const; end-pi; dcl-s Big char(13) dim(12); 1b if pBaseChar = ' '; Big(*) = *blanks; 1x elseif pBaseChar = 'A'; Big(*) = 'AA AA'; Big(1) = ' AAAAAAAAAA '; Big(2) = 'AAAAAAAAAAAA'; Big(6) = 'AAAAAAAAAAAA'; Big(7) = 'AAAAAAAAAAAA'; 1x elseif pBaseChar = 'B'; Big=%list( 'BBBBBBBBBB ': 'BBBBBBBBBBB ': 'BB BB': 'BB BB': 'BB BB ': 'BBBBBBBBBB ': 'BBBBBBBBBB ': 'BB BB ': 'BB BB': 'BB BB': 'BBBBBBBBBBB ': 'BBBBBBBBBB '); 1x elseif pBaseChar = '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 pBaseChar = '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 pBaseChar = 'E'; Big(*) = 'EE '; Big(1) = ' EEEEEEEEEEE'; Big(2) = 'EEEEEEEEEEEE'; Big(6) = 'EEEEEEEE '; Big(7) = 'EEEEEEEE '; Big(11)= 'EEEEEEEEEEEE'; Big(12)= ' EEEEEEEEEEE'; 1x elseif pBaseChar = 'F'; Big(*) = 'FF '; Big(1) = ' FFFFFFFFFFF'; Big(2) = 'FFFFFFFFFFFF'; Big(6) = 'FFFFFFFF '; Big(7) = 'FFFFFFFF '; 1x elseif pBaseChar = 'G'; Big=%list( ' GGGGGGGGGG ': 'GGGGGGGGGGGG': 'GG GG': 'GG ': 'GG ': 'GG ': 'GG GGGGGG': 'GG GGGGGG': 'GG GG': 'GG GG': 'GGGGGGGGGGGG': ' GGGGGGGGGG '); 1x elseif pBaseChar = 'H'; Big(*) = 'HH HH'; Big(6) = 'HHHHHHHHHHHH'; Big(7) = 'HHHHHHHHHHHH'; 1x elseif pBaseChar = 'I'; Big(*) = ' II '; Big(1) = 'IIIIIIIIIIII'; Big(2) = 'IIIIIIIIIIII'; Big(11)= 'IIIIIIIIIIII'; Big(12)= 'IIIIIIIIIIII'; 1x elseif pBaseChar = '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 pBaseChar = 'K'; Big=%list( 'KK KK': 'KK KK ': 'KK KK ': 'KK KK ': 'KK KK ': 'KKKKKKK ': 'KKKKKKK ': 'KK KK ': 'KK KK ': 'KK KK ': 'KK KK ': 'KK KK'); 1x elseif pBaseChar = 'L'; Big(*) = 'LL '; Big(11)= 'LLLLLLLLLLLL'; Big(12)= 'LLLLLLLLLLLL'; 1x elseif pBaseChar = '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 pBaseChar = 'N'; Big=%list( 'NN NN': 'NNN NN': 'NNNN NN': 'NN NN NN': 'NN NN NN': 'NN NN NN': 'NN NN NN': 'NN NN NN': 'NN NNNN': 'NN NNN': 'NN NN': 'NN NN'); 1x elseif pBaseChar = 'O'; Big(*) = 'OO OO'; Big(1) = ' OOOOOOOOOO '; Big(2) = 'OOOOOOOOOOOO'; Big(11)= 'OOOOOOOOOOOO'; Big(12)= ' OOOOOOOOOO '; 1x elseif pBaseChar = 'P'; Big(*) = 'PP'; Big(1) = 'PPPPPPPPPPP '; Big(2) = 'PPPPPPPPPPPP'; Big(3) = 'PP PP'; Big(4) = 'PP PP'; Big(5) = 'PP PP'; Big(6) = 'PPPPPPPPPPPP'; Big(7) = 'PPPPPPPPPPP '; 1x elseif pBaseChar = '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 pBaseChar = 'R'; Big=%list( 'RRRRRRRRRRR ': 'RRRRRRRRRRRR': 'RR RR': 'RR RR': 'RR RR': 'RRRRRRRRRRRR': 'RRRRRRRRRRR ': 'RR RR ': 'RR RR ': 'RR RR ': 'RR RR ': 'RR RR'); 1x elseif pBaseChar = 'S'; Big=%list( ' SSSSSSSSSS ': 'SSSSSSSSSSSS': 'SS SS': 'SS ': 'SSS ': ' SSSSSSSSS ': ' SSSSSSSSS ': ' SSS': ' SS': 'SS SS': 'SSSSSSSSSSSS': ' SSSSSSSSSS '); 1x elseif pBaseChar = 'T'; Big(*) = ' TT '; Big(1) = 'TTTTTTTTTTTT'; Big(2) = 'TTTTTTTTTTTT'; 1x elseif pBaseChar = 'U'; Big(*) = 'UU UU'; Big(11)= 'UUUUUUUUUUUU'; Big(12)= ' UUUUUUUUUU '; 1x elseif pBaseChar = 'V'; Big(*) = 'VV VV'; Big(8) = ' VV VV '; Big(9) = ' VV VV '; Big(10)= ' VV VV '; Big(11)= ' VVVV '; Big(12)= ' VV '; 1x elseif pBaseChar = '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 pBaseChar = 'X'; Big=%list( 'XX XX': 'XX XX': ' XX XX ': ' XX XX ': ' XX XX ': ' XXXX ': ' XXXX ': ' XX XX ': ' XX XX ': ' XX XX ': 'XX XX': 'XX XX'); 1x elseif pBaseChar = '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 pBaseChar = 'Z'; Big=%list( 'ZZZZZZZZZZZZ': 'ZZZZZZZZZZZZ': ' ZZ ': ' ZZ ': ' ZZ ': ' ZZZZZZZ ': ' ZZZZZZZ ': ' ZZ ': ' ZZ ': ' ZZ ': 'ZZZZZZZZZZZZ': 'ZZZZZZZZZZZZ'); 1x elseif pBaseChar = '0'; Big=%list( ' 0000000000 ': ' 0000000000 ': '00 0000': '00 00 00': '00 00 00': '00 00 00': '00 00 00': '00 00 00': '0000 00': '000 00': ' 0000000000 ': ' 00000000 '); 1x elseif pBaseChar = '1'; Big(*) = ' 11 '; Big(2) = ' 111 '; Big(3) = ' 1111 '; Big(11)= '111111111111'; Big(12)= '111111111111'; 1x elseif pBaseChar = '2'; Big=%list( ' 22222222 ': '222 222 ': '22 22': ' 22': ' 22': ' 22 ': ' 22 ': ' 22 ': ' 22 ': ' 22 ': '222222222222': '222222222222'); 1x elseif pBaseChar = '3'; Big=%list( ' 3333333333 ': '333 333': '33 33': ' 33': ' 33': ' 3333 ': ' 3333 ': ' 33': ' 33': '33 33': '333333333333': ' 3333333333 '); 1x elseif pBaseChar = '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 pBaseChar = '5'; Big=%list( '55555555555 ': '55 ': '55 ': '55 ': '55 ': '555555555 ': '5555555555 ': ' 55 ': ' 55': ' 55 ': '5555555555 ': '555555555 '); 1x elseif pBaseChar = '6'; Big=%list( ' 66666666 ': ' 666 ': '66 ': '66 ': '66 ': '666666666 ': '6666666666 ': '66 66 ': '66 66': '66 66 ': '6666666666 ': ' 66666666 '); 1x elseif pBaseChar = '7'; Big(*) = ' 77 '; Big(1) = '777777777777'; Big(2) = '777777777777'; Big(3) = ' 77 '; Big(4) = ' 77 '; Big(5) = ' 77 '; 1x elseif pBaseChar = '8'; Big=%list( ' 88888888 ': ' 888 888 ': '88 88': '88 88': ' 88 88 ': ' 88888888 ': ' 88888888 ': ' 88 88 ': '88 88': '88 88': ' 888 888 ': ' 88888888 '); 1x elseif pBaseChar = '9'; Big=%list( ' 9999999999 ': '999 999': '99 99': '99 99': '99 99': '999 999': ' 99999999999': ' 99': ' 99': ' 99': '999999999999': ' 9999999999 '); 1x elseif pBaseChar = '@'; Big=%list( ' @@@@@@@@@@ ': '@@@@@@@@@@@@': '@@ @@': '@@ @@@@ @@': '@@ @@ @@': '@@ @@ @@': '@@ @@ @@': '@@ @@@@@@@ ': '@@ ': '@@ ': ' @@@@@@@@@@@': ' @@@@@@@@@@'); 1x elseif pBaseChar = '#'; Big(*) = ' ## ## '; Big(4) = ' ###########'; Big(5) = ' ###########'; Big(8) = ' ###########'; Big(9) = ' ###########'; 1x elseif pBaseChar = '$'; Big=%list( ' $$ ': ' $$$$$$$$$$ ': '$$$$$$$$$$$$': '$$ $$ ': '$$ $$ ': ' $$$$$$$$$$ ': '$$$$$$$$$$$$': ' $$ $$': ' $$ $$': '$$$$$$$$$$$$': ' $$$$$$$$$$ ': ' $$ '); 1x elseif pBaseChar = '*'; Big=%list( '** ** **': '** ** **': ' ** ** ** ': ' ** ** ** ': ' ****** ': '************': '************': ' ****** ': ' ** ** ** ': ' ** ** ** ': '** ** **': '** ** **'); 1x elseif pBaseChar = '!'; Big=%list( ' !! ': ' !!!! ': ' !!!!!! ': ' !!!!!! ': ' !!!!!! ': ' !!!! ': ' !!!! ': ' !!!! ': ' !! ': ' ': ' !! ': ' !! '); 1x elseif pBaseChar = qs; %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 pBaseChar = qd; %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 pBaseChar = ')'; Big(*) = ' )) '; Big(1) = ' )))) '; Big(2) = ' ))) '; Big(11)= ' ))) '; Big(12)= ' )))) '; 1x elseif pBaseChar = '('; Big(*) = ' (( '; Big(1) = ' (((( '; Big(2) = ' ((( '; Big(11)= ' ((( '; Big(12)= ' (((( '; 1x elseif pBaseChar = '%'; Big(1) = ' %%%% //'; Big(2) = ' % % // '; Big(3) = ' %%%% // '; Big(4) = ' // '; Big(5) = ' // '; Big(6) = ' // '; Big(7) = ' // %%%% '; Big(8) = ' // % % '; Big(9) = ' // %%%% '; 1x elseif pBaseChar = ':'; Big(1) = ' '; Big(2) = ' '; Big(3) = ' :: '; Big(4) = ' : : '; Big(5) = ' :: '; Big(6) = ' '; Big(7) = ' :: '; Big(8) = ' : : '; Big(9) = ' :: '; 1x elseif pBaseChar = '&'; Big=%list( ' &&&&& ': ' && && ': '&& ': '&& ': ' &&&&&& ': ' &&&& ': ' && && ': '&& && ': '&& && &': '&& && &&': ' && &&&& ': ' &&&&&&&& '); 1x elseif pBaseChar = '_'; Big(12)= ' __________ '; 1x elseif pBaseChar = '-'; Big(6)= *all'-'; Big(7)= Big(6); 1x elseif pBaseChar = '+'; Big(4) = ' +++ '; Big(5) = ' +++ '; Big(6) = ' ++ +++ +++ '; Big(7) = ' ++ +++ +++ '; Big(8) = ' +++ '; Big(9) = ' +++ '; 1x elseif pBaseChar = '='; Big(6) = ' ======== '; Big(7) = ' ======== '; 1x elseif pBaseChar = '^'; Big(1) = ' ^^ '; Big(2) = ' ^^ ^^ '; Big(3) = ' ^^ ^^ '; 1x elseif pBaseChar = '/'; Big=%list( ' ': ' //': ' // ': ' // ': ' // ': ' // ': ' // ': ' // ': ' // ': ' // ': ' // ': '// '); 1x elseif pBaseChar = '\'; Big=%list( ' ': '\\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\ ': ' \\'); 1x elseif pBaseChar = '.'; Big(11) = ' .... '; Big(12) = ' .... '; 1x elseif pBaseChar = ','; Big(10) = ' ,,,, '; Big(11) = ' ,,,, '; Big(12) = ' ,, '; 1x elseif pBaseChar = '>'; Big(3) = ' >> '; Big(4) = ' >> '; Big(5) = ' >> '; Big(6) = ' >> '; Big(7) = ' >> '; Big(8) = ' >> '; Big(9) = ' >> '; Big(10)= ' >> '; Big(11)= ' >> '; 1x elseif pBaseChar = '<'; Big(3) = ' << '; Big(4) = ' << '; Big(5) = ' << '; Big(6) = ' << '; Big(7) = ' << '; Big(8) = ' << '; Big(9) = ' << '; Big(10)= ' << '; Big(11)= ' << '; 1x elseif pBaseChar = '?'; Big=%list( ' ???????? ': ' ?????????? ': '?? ??': ' ??': ' ??? ': ' ?? ': ' ?? ': ' ?? ': ' ?? ': ' ?? ': ' ?? ': ' ?? '); 1e endif; return Big; end-proc; ]]> */ /*--------------------------------------------------------------------------*/ 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('Files') 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') ]]> .*-------------------------------------------------------------------- :P.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.: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.Enter multiple values for this parameter. If on entry display and 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. ]]> '); //--------------------------------------------------------- // JCRNETFFR - Send multiple network files to multiple users //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_Quscrtus /define Quslobj /define f_GetQual /define f_RunCmd // *ENTRY /define p_JCRNETFFR /COPY JCRCMDS,JCRCMDSCPY dcl-s BldSpace char(1); dcl-s BldToUsr varchar(100); dcl-s OffsetToNext int(5) based(DisplacePtr); dcl-s NumOfFiles uns(3); dcl-s xx uns(3); dcl-s p_UsrListPtr pointer; dcl-s filename char(10); // Get number of user/system IDs and build DS to move though command list dcl-ds InnerList based(InnerListPtr) qualified; ToUser char(8) pos(3); ToSys char(8) pos(11); end-ds; //--------------------------------------------------------- //* overlay entry parms with DS definitions p_UsrListPtr = %addr(p_UsrList); // Load users into single string (touser tosys) (touser tosys) DisplacePtr = p_UsrListPtr; 1b for ForCount = 1 to p_UsrList.Count; DisplacePtr += 2; InnerListPtr = p_UsrListPtr + OffsetToNext; BldToUsr = BldToUsr + BldSpace + '(' + %trimr(InnerList.ToUser) + ' ' + %trimr(InnerList.ToSys) + ')'; BldSpace = ' '; 1e endfor; // process files in list 1b for-each filename in %subarr(p_FileList.Arry:1:p_FileList.Count); 2b if %scan('*':filename) > 0; // Create user space/retrieve pointer to user space ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0200': filename + p_Lib: '*FILE': ApiErrDS); QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 3b for ForCount = 1 to ApiHead.ListEntryCount; 4b if QuslobjDS.ExtendedAttr = 'PF'; f_RunCmd('SNDNETF FILE(' + f_GetQual(QuslobjDS.ObjNam + QuslobjDS.ObjLib) + ') TOUSRID(' + BldToUsr + ')'); 4e endif; QuslobjPtr += ApiHead.ListEntrySize; 3e endfor; 2x else; f_RunCmd('SNDNETF FILE(' + f_GetQual(filename + p_Lib) + ') TOUSRID(' + BldToUsr + ')'); 2e endif; 1e endfor; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRNETFFV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_SndEscapeMsg // *ENTRY /define p_JCRNETFFR /COPY JCRCMDS,JCRCMDSCPY dcl-s xx uns(3); dcl-s filename char(10); 1b if not(p_Lib = '*LIBL'); f_CheckObj(p_Lib + '*LIBL': '*LIB'); 1e endif; 1b if p_UsrList.Count = 0; f_SndEscapeMsg('Must select at least one TOUSRID.'); 1e endif; 1b if p_FileList.Count = 0; f_SndEscapeMsg('Must select at least one FILE NAME.'); 1x else; 2b for-each filename in %subarr(p_FileList.Arry:1:p_FileList.Count); 3b if %scan('*':filename) = 0; // skip generics f_CheckMbr(filename + p_Lib: '*FIRST'); 3e endif; 2e endfor; 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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) MIN(1) MAX(5) + PROMPT('To User ID(s)') TOUSRID: ELEM TYPE(*CHAR) LEN(8) 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') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) SPCVAL((*ALL)) + CHOICE('*ALL,RPGLE,RPG,CLP,DSPF,etc.') + PROMPT(' Member Type') ]]> .*-------------------------------------------------------------------- :P.Send either *First, *All, Generic* or up to 10 named members of a selected file. Filter member selections by member type. Select up to 5 send-to users.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRNETFM/FILE'.File name - 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. Select *FIRST, *ALL, or any generic* name. Filter by specific member types.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // 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). //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Quslmbr /define f_BuildString /define f_GetQual /define f_Quscrtus /define f_RunCmd /define f_SndCompMsg // *ENTRY /define p_JCRNETFMR /COPY JCRCMDS,JCRCMDSCPY dcl-s BldToUsr varchar(100); dcl-s OffsetToNext int(5) based(DisplacePtr); dcl-s OffsetToNext2 int(5) based(DisplacePtr2); dcl-s NumofMbrs int(5) based(p_MbrListPtr); dcl-s NumOfSndTo int(5) based(p_UsrListPtr); dcl-s SendCount uns(10); // Get number of user/system IDs and build DS to move though command list dcl-ds InnerList based(InnerListPtr) qualified; ToUser char(8) pos(3); ToSys char(8) pos(11); end-ds; // DS to move through command list dcl-ds InnerList2 based(InnerListPtr2) qualified; MbrName char(10) pos(3); MbrType char(10) pos(13); end-ds; //--------------------------------------------------------- // overlay entry parms with DS definitions p_UsrListPtr = %addr(p_UsrList); p_MbrListPtr = %addr(p_MbrList); // Load users into single string // (touser tosys) (touser tosys) DisplacePtr = p_UsrListPtr + 2; 1b for ForCount2 = 1 to NumOfSndTo; InnerListPtr = p_UsrListPtr + OffsetToNext; BldToUsr += %trimr(f_BuildString(' (& &)': InnerList.ToUser: InnerList.ToSys)); DisplacePtr += 2; 1e endfor; //--------------------------------------------------------- // Spin though members, 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 + OffsetToNext2; 2b if %scan('*': InnerList2.MbrName) > 0 and InnerList2.MbrName <> '*FIRST'; ApiHeadPtr = 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 + OffsetToNext2; 2b if %scan('*': InnerList2.MbrName) = 0 or InnerList2.MbrName = '*FIRST'; SendCount += 1; f_RunCmd(f_BuildString('SNDNETF FILE(&) TOUSRID(&) MBR(&)': f_GetQual(p_FileQual): BldToUsr: InnerList2.MbrName)); //--------------------------------------------------------- // If generic, execute member list API //--------------------------------------------------------- 2x else; callp QUSLMBR( UserSpaceName: 'MBRL0200': p_FileQual: InnerList2.MbrName: '0': ApiErrDS); QuslmbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 3b for ForCount = 1 to ApiHead.ListEntryCount; // member type filter 4b if InnerList2.MbrType in %list('*ALL': QuslmbrDS.MbrType); SendCount += 1; f_RunCmd( f_BuildString('SNDNETF FILE(&) TOUSRID(&) MBR(&)': f_GetQual(p_FileQual): BldToUsr: QuslmbrDS.MbrName)); 4e endif; QuslmbrPtr += ApiHead.ListEntrySize; 3e endfor; 2e endif; DisplacePtr2 += 2; 1e endfor; f_SndCompMsg('JCRNETFMR sent ' + %char(SendCount) + ' members.'); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRNETFMV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_Qusrobjd /define f_RtvMsgAPI /define f_CheckMbr /define f_SndEscapeMsg // *ENTRY /define p_JCRNETFMR /COPY JCRCMDS,JCRCMDSCPY dcl-s NumofMbrs int(5) based(p_MbrListPtr); dcl-s NumOfUsrs int(5) based(p_UsrListPtr); //--------------------------------------------------------- // overlay entry parms with other definitions p_UsrListPtr = %addr(p_UsrList); p_MbrListPtr = %addr(p_MbrList); //---------------------------------------- QusrObjDS = f_QUSROBJD(p_FileQual: '*FILE'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; //---------------------------------------- 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; //---------------------------------------- 1b if NumOfUsrs = 0; f_SndEscapeMsg('Must select at least one TOUSRID.'); 1e endif; //---------------------------------------- 1b if NumofMbrs = 0; f_SndEscapeMsg('Must select at least one MBR NAME.'); 1e endif; //---------------------------------------- f_CheckMbr(p_FileQual: '*FIRST'); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Send Network Outq') PARM KWD(OUTQ) TYPE(OUTQ) MIN(1) 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(TOUSRID) TYPE(*CHAR) LEN(8) MIN(1) + PROMPT('User ID') PARM KWD(SYSTEM) TYPE(*CHAR) LEN(8) MIN(1) + PROMPT('Address') ]]> .*-------------------------------------------------------------------- :P.This JCR sends network file all spooled files in an 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. ]]> '); //--------------------------------------------------------- // JCRNETQR - Send network file entire outq //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Quslspl /define f_BuildString /define f_GetQual /define f_Quscrtus /define f_SndCompMsg /define f_SndStatMsg /define f_RunCmd /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_OutqQual char(20); p_ObjType char(10); p_ToUserid char(8); p_ToAddress char(8); end-pi; //--------------------------------------------------------- f_SndStatMsg(f_BuildString('Sending from outq & to & - in progress': f_GetQual(p_OutqQual): p_ToAddress)); // load user space with spooled file info ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QUSLSPL( UserSpaceName: 'SPLF0300': '*ALL': p_OutqQual: '*ALL': '*ALL': ApiErrDS); // Process list entries in user space splf0300Ptr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; f_RunCmd(f_BuildString('SNDNETSPLF FILE(&) TOUSRID((& &)) + JOB(&/&/&) SPLNBR(&)': splf0300DS.SplfName: p_ToUserid: p_ToAddress: splf0300DS.JobNo: splf0300DS.UserID: splf0300DS.JobName: %editc(%dec(splf0300DS.SplfNum:6:0):'X'))); splf0300Ptr += ApiHead.ListEntrySize; 1e endfor; f_SndCompMsg(f_BuildString('& files were sent from & to &.': %char(ApiHead.ListEntryCount): f_GetQual(p_OutqQual): p_ToAddress)); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Fields Not Populated') 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(MBR) TYPE(*NAME) LEN(10) DFT(*FIRST) + SPCVAL((*FIRST *FIRST)) PROMPT('Member') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT) PROMPT('Output') ]]> */ /*--------------------------------------------------------------------------*/ PGM CALL PGM(QTEMP/JCRNOTR) ENDPGM ]]> .*-------------------------------------------------------------------- :P.Lists field names from data file that are not populated in any record. :P.For data files with large number of records, it is recommended to 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 or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) A 2'JCRNOTPOP' A 20'Fields Not Populated' A SCDOW 9A O 60 A 70DATE EDTCDE(Y) A SCSYSTEM 8A 80 A 90'Page' A +1PAGNBR EDTCDE(4) A SPACEA(2) *--- A 3'File . :' A FILEACTUAL 10A O 14 A FILETEXT 42A O 26 A 72'Member:' A FILEMBR 10 80SPACEA(1) *--- A 3'Library:' A LIBACTUAL 10A O 14SPACEA(2) *--- A 3'Field Name' A 16'DATA TYPE' A 34'TEXT' A SPACEA(1) *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A FLDNAME 10A O 3 A FLDTYPE 16A 16 A FLDTEXT 42A O 34 ]]> '); //--------------------------------------------------------- // JCRNOTPOPR- List fields not populated // call API to retrieve file field descriptions. // use entries to generate rpgle code to read PF and print report. // // Added rename record format to generated source code if same name as file // and to read keyed if LF file type. // // Add monitor for deleted records in journal files //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Constants /define Qdbrtvfd /define BitMask /define Quslfld /define f_GetQual /define f_Quscrtus /define f_SndStatMsg /define f_RunCmd /define f_OvrPrtf /define f_SrcFileAddPfm /define f_DisplayLastSplf /define f_GetDayName /define f_GetDataTypeKeyWords /define f_CamelCase /define SourceOutDS /COPY JCRCMDS,JCRCMDSCPY dcl-f RPGSRC disk(112) usage(*output) extfile('QTEMP/JCRSRC') extmbr('JCRNOTR') usropn; dcl-s scDow char(9); dcl-s Alpha14 char(14); dcl-s FldTxt char(42); dcl-s RcdFmtRename char(30); dcl-s RecordAddressType char(5); dcl-s pFile char(10); dcl-s pLib char(10); dcl-s unsignedlength uns(10); dcl-s DecimalPos char(2); // Break Implicit Call Link dcl-pr p_JCRNOTPOPC extpgm('JCRNOTPOPC') end-pr; //--*ENTRY------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_Mbr char(10); p_Output char(8); end-pi; //--------------------------------------------------------- scDow = f_GetDayName(); // create source file/member for generated program f_RunCmd('DLTF FILE(QTEMP/JCRSRC)'); f_RunCmd('DLTPGM QTEMP/JCRNOTR'); f_RunCmd('CRTSRCPF FILE(QTEMP/JCRSRC) RCDLEN(112)'); f_SrcFileAddPfm('JCRSRC QTEMP': 'JCRNOTR': 'RPGLE': ' '); open RPGSRC; AllocatedSize = f_GetAllocatedSize(p_FileQual: '*FIRST'); Fild0100ptr = %alloc(AllocatedSize); callp QDBRTVFD( Fild0100ds: AllocatedSize: ReturnFileQual: 'FILD0100': p_FileQual: '*FIRST': '0': '*FILETYPE': '*EXT': ApiErrDS); // load actual library name %subst(p_FileQual: 11: 10) = %subst(ReturnFileQual: 11: 10); pFile = %subst(p_FileQual: 1: 10); pLib = %subst(p_FileQual: 11: 10); //------------------------------------------------------------------ // If LF, then must use keyed access. If PF, check record format name // same as file name (like created by SQl). Must rename this record format. RcdFmtRename = *blanks; RecordAddressType = *blanks; 1b if %bitand(bit2: Fild0100ds.TypeBits) = bit2; // is LF RecordAddressType = 'keyed'; 1x else; fscopePtr = Fild0100ptr + Fild0100ds.OffsFileScope; 2b if pFile = FileScopeArry.RcdFmt; RcdFmtRename = 'rename(' + %trimr(pFile) + ':jcrnotxxxr)'; 2e endif; 1e endif; //------------------------------------------------------------------ // Write file specs clear Outds; f_Write('dcl-f ' + %trimr(pFile) + ' ' + %trimr(RecordAddressType) + ' ' + %trimr(RcdFmtRename) + ' prefix(x);'); f_Write('dcl-f JCRNOTPOPP printer oflind(IsOverFlow);'); f_Write('dcl-s jxxxxxxcnt uns(5);'); f_Write('dcl-s jxxxxxxflg ind dim(6000);'); f_Write('dcl-s jxxxxxxnam char(10) dim(%elem(jxxxxxxflg));'); f_Write('dcl-s jxxxxxxtyp char(16) dim(%elem(jxxxxxxflg));'); f_Write('dcl-s jxxxxxxtxt char(42) dim(%elem(jxxxxxxflg));'); bb = 0; ApiHeadPtr = f_Quscrtus(UserSpaceName2); callp QUSLFLD( UserSpaceName2: 'FLDL0100': p_FileQual: '*FIRST': '0': ApiErrDS); QuslfldPTR = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if QuslfldDS.FieldType in %list('A':'S':'P':'U':'I':'B'); bb += 1; f_Write('jxxxxxxnam(' + %char(bb) + ')=' + qs + %trimr(QuslfldDS.FieldName) + qs + ';'); 3b if QuslfldDS.Digits > 0; // numeric unsignedlength = QuslfldDS.Digits; DecimalPos = %triml(%editc(QuslfldDS.DecimalPos:'3')); 3x else; unsignedlength = QuslfldDS.FieldLengthA; DecimalPos = *blanks; 3e endif; f_Write('jxxxxxxtyp(' + %char(bb) + ') =' + qs + %trimr(%scanrpl(';':' ': f_GetDataTypeKeyWords( QuslfldDS.FieldType: unsignedlength: DecimalPos))) + qs + ';'); // Remove Quotes before generation FldTxt = %xlate(qd+qs:' ': f_CamelCase(QuslfldDS.FieldText)); f_Write('jxxxxxxtxt(' + %char(bb) + ')='+qs+ %trimr(FldTxt) + qs + ';'); 2e endif; QuslfldPTR += ApiHead.ListEntrySize; 1e endfor; // start file read code f_Write('read ' + %trimr(pFile) + ';'); f_Write('dow not %eof;'); f_Write('monitor;'); // override print file for later f_OvrPrtf('JCRNOTPOPP': '*JOB': pFile); //--------------------------------------------------------- // generate calc specs bb = 0; QuslfldPTR = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if QuslfldDS.FieldType in %list('A':'S':'P':'U':'I':'B'); bb += 1; // put prefix on field name to avoid reserved word field names Alpha14 = 'X' + QuslfldDS.FieldName; //--------------------------------------------------------- 3b if QuslfldDS.FieldType = 'A'; f_Write('if ' +%trimr(Alpha14)+ ' > *blanks;'); 3x else; f_Write('if ' +%trimr(Alpha14)+ ' > *zeros;'); 3e endif; //--------------------------------------------------------- f_Write(' jxxxxxxflg(' + %char(bb) + ') = *on;'); f_Write('endif;'); 2e endif; QuslfldPTR += ApiHead.ListEntrySize; 1e endfor; f_Write('on-error;'); f_Write('endmon;'); // bottom file read f_Write('read ' + %trimr(pFile) + ';'); f_Write('enddo;'); //--------------------------------------------------------- // Load heading fields and heading print line //--------------------------------------------------------- f_Write('// Print report ----------------------------'); f_Write('FileActual =' + qs + %trimr(pFile) + qs + ';'); f_Write('LibActual =' + qs + %trimr(pLib) + qs + ';'); f_Write('FileMbr =' + qs + %trimr(p_Mbr) + qs + ';'); f_Write('scdow =' + qs + scdow + qs + ';'); f_Write('FileText ='); f_Write(qs + %subst(Fild0100ds.FileText: 1: 42) + qs + ';'); f_Write('write PrtHead;'); f_Write('for jxxxxxxcnt = 1 to ' + %char(bb) + ';'); f_Write('if jxxxxxxflg(jxxxxxxcnt) = *off;'); f_Write('FldName=jxxxxxxnam(jxxxxxxcnt);'); f_Write('FldType=jxxxxxxtyp(jxxxxxxcnt);'); f_Write('FldText=jxxxxxxtxt(jxxxxxxcnt);'); f_Write('write PrtDetail;'); f_Write('if IsOverFlow;'); f_Write('write PrtHead;'); f_Write('IsOverFlow = *off;'); f_Write('endif;'); f_Write('endif;'); f_Write('endfor;'); f_Write('*inlr = *on;'); f_Write('return;'); f_Write('// --------------------------'); //--------------------------------------------------------- close RPGSRC; f_RunCmd('OVRDBF FILE(' + pFile + ') TOFILE(' + f_GetQual(p_FileQual) + ') MBR(' + p_Mbr + ') OVRSCOPE(*JOB)'); f_RunCmd('CRTBNDRPG PGM(QTEMP/JCRNOTR) ' + 'SRCFILE(QTEMP/JCRSRC) SRCMBR(JCRNOTR) ' + 'DBGVIEW(*NONE) OUTPUT(*NONE) TGTRLS(*CURRENT)'); f_SndStatMsg('Reading data file ' + f_GetQual(p_FileQual) + ' - in progress'); callp p_JCRNOTPOPC(); f_RunCmd('DLTOVR FILE(JCRNOTPOPP) LVL(*JOB)'); f_RunCmd('DLTOVR FILE(' + pFile + ') LVL(*JOB)'); f_DisplayLastSplf('JCRNOTPOPR': p_Output); *inlr = *on; return; //--------------------------------------------------------- // Write generated code to outfile //--------------------------------------------------------- dcl-proc f_Write; dcl-pi *n; pSrcCod char(74) const; end-pi; OutDS.SrcCod = ' ' + pSrcCod; OutDS.SrcSeq += .01; write RPGSRC OutDS; return; end-proc; ]]> '); //--------------------------------------------------------- // JCRNOTPOPV - Validity checking program for lib/file/member //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_FileQual char(20); p_Mbr char(10); end-pi; //--------------------------------------------------------- f_CheckMbr(p_FileQual: p_Mbr); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Number Source - Reformat Free') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('RPG program') 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(HIGH_LITE) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*NO) 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 and /space') PARM KWD(CALLING) TYPE(*CHAR) LEN(10) CONSTANT('JCRNUMB') ]]> .*-------------------------------------------------------------------- :P.Updates RPGLE fixed column or free source code with structured programming operation numbering in left margin of the source. Options are provided for highlighting of comment lines and removal of /space and /eject lines. :P.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. This will remove hexadecimal values that are not valid in XML.:ENT. :P.The command removes source code type from fixed format comment lines. Makes it much easier to distinguish comments from executable lines. :P.After execution, 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/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 free code based on logic structures. This value has no effect on fixed column 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 fix format code. :PARML.:PT.:PK def.3:EPK.:PD.Indent 3 spaces for each logic structure.:EPARML.:EHELP. :HELP NAME='JCRNUMB/RMV_EJECTS'.Blank /eject and /space- Help :XH3.Blank /eject and /space (RMV_EJECTS) :P.Blank out /EJECT and /SPACE print listing directive lines. :PARML.:PT.:PK def.*YES:EPK.:PD.Blank out /eject and /space lines. :PT.*NO :PD.Do not blank.:EPARML.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRNUMBR - Number logic structures in RPGLE source // Updates RPGLE fixed or free source code with structured programming operation // statements in left margin of source. // generate end matching in same text case as end opcode. // free source code reformat based on logic structures. // strip comment line colors // skip continuation lines that begin with an opcode. // // Added indent V7 free DCL- codes. // Nested DCLs are indented one space, independent of mainline reformatting. //--------------------------------------------------------- /define ControlStatements /define Constants /define f_GetQual /define f_IsValidSrcType /define f_SndCompMsg /define f_IsIgnoreLine /define f_CheckSameLineEnd /define f_IsCompileTimeArray /define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY dcl-f RPGSRC disk(112) usage(*update) extfile(extIfile) extmbr(p_SrcMbr) usropn; dcl-ds SrcDS qualified inz; SeqNo char(4) pos(1); SeqDec char(2) pos(5); CompileArray char(3) pos(13); SpecType char(1) pos(18); Asterisk char(1) pos(19); SlashComment char(2) pos(19); SlashEject char(6) pos(19); OpCode char(10) pos(38); Src18 char(18) pos(1); Src94 char(94) pos(19); end-ds; dcl-s WrkA like(opcodeds); dcl-s WrkUP like(opcodeds); dcl-s FirstDigitOpc char(1); dcl-s p_SrcFil char(10); dcl-s p_SrcLib char(10); dcl-s op char(3) dim(100); dcl-s SecondDigitOpc char(1); dcl-s StructNumb char(4); dcl-s TypeOutput char(13); dcl-s WBlanks varchar(94); dcl-s WrkB char(188); dcl-s WrkB2 char(188); dcl-s ado int(5) dim(100); dcl-s dd int(5); dcl-s ee int(5); dcl-s EndOfCode uns(3); dcl-s pp uns(3); dcl-s q1 uns(3); dcl-s q2 uns(3); dcl-s StartOfComment uns(3); dcl-s ww uns(3); dcl-s IsCalcSpec ind; dcl-s IsCallp ind; dcl-s IsCasxx ind; dcl-s IsContinuation ind; dcl-s IsCSR ind; dcl-s IsEndCheat ind; dcl-s IsFree ind; dcl-s IsFunction ind; dcl-s IsInsideCalcs ind; dcl-s IsSqlExec ind; dcl-s string varchar(94); dcl-s SelectDepth ind dim(100); dcl-c WhiteHex const(x'22'); dcl-s IndentLvl uns(3) inz(0); dcl-s ApostropheCnt uns(10) inz(0); dcl-s aCheck varchar(74); dcl-s DoNotIndentMinus ind; dcl-s IsComment ind; dcl-s SubRoutine char(2); dcl-ds SrcUpdateDS len(112) end-ds; dcl-c up const('ABCDEFGHIJKLMNOPQRSTUVWXYZ'); dcl-ds OpCodeDS len(10) inz qualified; One char(1) pos(1); Two char(2) samepos(One); Three char(3) samepos(One); Four char(4) samepos(One); Six char(6) samepos(One); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_HighLight char(4); p_EndLabel char(4); p_Indentfree char(4); p_Indentspace packed(1); p_BlankEjects char(4); p_CallingCmd char(10); end-pi; //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_SrcFilQual: p_SrcMbr:'RPGLE':'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_SrcMbr) + ' is not type RPGLE or 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 SrcDS; 1b dow not %eof; // do not process compile time arrays 2b if f_IsCompileTimeArray(srcds.CompileArray); 1v leave; 2e endif; SubRoutine = srcds.SlashComment; OpCodeDS = srcds.Opcode; IsComment = *off; IsCalcSpec = *off; IsFree = *off; srcds.Src18 = f_RemoveHexColorCodes(srcds.Src18:18); srcds.Src94 = f_RemoveHexColorCodes(srcds.Src94:94); string = %trimr(%upper(srcds.Src94)); 2b if f_IsIgnoreLine(string); IsComment = *on; TypeOutput = 'COMMENT-'; 3b if srcds.SlashComment = '//' or srcds.Asterisk = '*'; exsr srFormatOutput; 3x elseif srcds.Asterisk <> '/'; exsr srIndentFree; exsr srFormatOutput; 3x elseif p_BlankEjects = '*YES' and srcds.Asterisk = '/' and %upper(srcds.SlashEject) in %list('/EJECT':'/SPACE'); TypeOutput = '/EJECT'; exsr srFormatOutput; 3e endif; //-------------------------------------------------------- // spin through until I get into C specs proper. // if C or c or /free, then inside C specs. //-------------------------------------------------------- 2x elseif %upper(srcds.SpecType) = 'C'; IsCalcSpec = *on; 2x elseif %upper(srcds.SpecType) in %list('O':'D':'F':'P':'I'); IsCalcSpec = *off; 2x else; //-------------------------------------------- // if a free statements ends in - and // is between quotes, do not indent! //-------------------------------------------- aCheck = %trimr(%subst(srcds.Src94:1:74)); 3b for aa = 1 to %len(aCheck); 4b if %subst(aCheck:aa:1) = qs; ApostropheCnt += 1; 4e endif; 3e endfor; 3b if %rem(ApostropheCnt: 2) <> 0 and %len(acheck) > 0 and %subst(acheck: %len(acheck): 1) = '-'; DoNotIndentMinus = *on; 3e endif; 3b if DoNotIndentMinus = *on; IsFree = *off; IsCalcSpec = *off; 3x else; IsFree = *on; IsCalcSpec = *on; 3e endif; 3b if %rem(ApostropheCnt: 2) = 0; DoNotIndentMinus = *off; 3e endif; 2e endif; //--------------------------------------------------------- 2b if IsCalcSpec and (not IsComment); IsCSR = *off; //SR remove IsInsideCalcs = *on; 3b if srcds.Asterisk = '/' //skip SQL stuff or srcds.Asterisk = '+'; TypeOutput = 'CLEAR'; exsr srFormatOutput; 3x else; //--------------------------------------------------------- // For /free code, extract opcode into OpcodeDS field. // Look for first ' ' and first ';' , then the one not // zero and lowest value is end of opcode. //--------------------------------------------------------- 4b if IsFree and srcds.Src94 > *blanks; WrkA = %triml(srcds.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; //--------------------------------------------------------- // 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; aa = %len(string); 5b if aa > 0; 6b if %subst(string: aa: 1) in %list('+':'-'); IsContinuation = *on; 6e endif; 5e endif; 4e endif; //--------------------------------------------------------- // save case of opcode for matching ends //--------------------------------------------------------- FirstDigitOpc = %subst(OpcodeDS: 1: 1); SecondDigitOpc = %subst(OpcodeDS: 2: 1); OpcodeDS = %upper(OpcodeDS); // bad person had field named END in their free code // ENDblank is valid in fixed column, but not in free 4b if IsFree and OpCodeDS = 'END'; OpCodeDS = *blanks; 4e endif; //--------------------------------------------------------- // do not format SQL statements // Ignore everything between EXEC and terminating; //--------------------------------------------------------- WrkUP = %upper(OpcodeDS); 4b if WrkUP = 'EXEC'; IsSqlExec = *on; 4e endif; 4b if not IsFree; SubRoutine = %upper(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 notation // 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(' or OpcodeDS = 'FOR-EACH'; 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' 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'; 6b if dd > 0; StructNumb = %char(ado(dd)) + 'i'; 6x else; StructNumb = '00'; 6e endif; 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'; 6b if dd > 0; StructNumb = %char(ado(dd)) + 'v'; 6x else; StructNumb = '00'; 6e endif; 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 error statement number. //--------------------------------------------------------- 6b if cc <= 0; close RPGSRC; f_SndCompMsg('WARNING: Unmatched ENDxx Opcode at ' + srcds.SeqNo + '.' + srcds.SeqDec + ' - 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 = %lower(OpcodeDS); 7x elseif %scan(SecondDigitOpc: up) > 0; OpcodeDS = %upper(OpcodeDS); 7x else; OpcodeDS = %lower(OpcodeDS); OpcodeDS.One = %upper(OpcodeDS.One); 7e endif; 7b if not IsFree; TypeOutput = 'ENDXX'; exsr srFormatOutput; 7x else; //--------------------------------------------------------- // determine size of existing end statement, then use %replace //--------------------------------------------------------- aa = %scan('END': string); bb = %scan(';': srcds.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 ' + srcds.SeqNo + '.' + srcds.SeqDec + ' - JCRNUMB canceled!'); *inlr = *on; return; 8e endif; srcds.Src94 = %replace(%trimr(OpcodeDS) + ';': srcds.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 // clears 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(';': srcds.Src94: 1) = 0); TypeOutput = 'CLEAR'; exsr srFormatOutput; 4e endif; 3e endif; 2e endif; read RPGSRC SrcDS; 1e enddo; close RPGSRC; // Completion message was overlaying JCR4MAX messages, // so only send completion message if JCRNUMB command is running 1b if p_CallingCmd = 'JCRNUMB '; // send message if unmatched ENDXX codes 2b if cc > 0; f_SndCompMsg('WARNING: ' + %triml(%editc(cc:'4')) + ' ENDxx opcodes are missing. - JCRNUMB canceled!'); 2x else; f_SndCompMsg('JCRNUMB for ' + %trimr(p_SrcMbr) + ' in ' + %trimr(extIfile) + ' - completed'); 2e endif; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Format output depending on line type; //--------------------------------------------------------- begsr srFormatOutput; SrcUpdateDS = srcds.Src18 + srcds.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-'; %subst(SrcUpdateDS: 13: 6) = *blanks; 2b if p_HighLight = '*YES'; %subst(SrcUpdateDS: 16: 1) = WhiteHex; 2x else; %subst(SrcUpdateDS: 16: 1) = ' '; 2e endif; //--------------------------------------------------------- 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; 1x elseif TypeOutput = '/EJECT'; %subst(SrcUpdateDS: 13) = *blanks; 1e endif; //-------------------------------------------- // Indent nested DCL-* by one position //----------------------------------------------- 1b if not (TypeOutput in %list('ENDXX':'COMMENT-':'/EJECT')); SrcUpdateDS = f_DclNestedIndent(OpCodeDS: SrcUpdateDS); 1e endif; update RPGSRC SrcUpdateDS; 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 srcds.Src94 > *blanks; 2b if IsEndCheat; //--------------------------------------------------------- // if ee = 0 then there are too many END opcodes. // Send message with error statement number. //--------------------------------------------------------- ee -= 1; 3b if ee < 0; close RPGSRC; f_SndCompMsg('WARNING: Unmatched ENDxx Opcode at ' + srcds.SeqNo + '.' + srcds.SeqDec + ' - JCRNUMB canceled!'); *inlr = *on; return; 3e endif; 2e endif; // parms under callp are synced to start of program name 2b if IsCallp or IsFunction; wrkb = *blanks; %subst(wrkb: pp) = %triml(srcds.Src94); 2x else; %len(wblanks) = p_Indentspace * ee; wrkb = ' ' + Wblanks + %triml(srcds.Src94); 2e endif; exsr srIndentOrNot; 2b if IsEndCheat; ee += 1; 2e endif; 2b if (not IsComment); //--------------------------------------------------------- // set CALLPARM flag if within callp // first ; outside comment resets to off //--------------------------------------------------------- 3b if OpcodeDS.Six = 'CALLP ' or OpcodeDS.Six = 'CALLP('; IsCallp = *on; // get program name start position // callp(e) pgm( I want to line up with pgm. pp = %scan('(': srcds.Src94); 4b if OpcodeDS.Six = 'CALLP('; pp = %scan('(': srcds.Src94: pp + 1); 4e endif; 4b for aa = pp downto 1; 5b if %subst(srcds.Src94: aa: 1) = ' '; 4v leave; 5e endif; 4e endfor; pp = aa + 1; 3e 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. //--------------------------------------------------------- 3b if not IsFunction; //already in function aa = %scan('f_': srcds.Src94); 4b if aa > 0 and %scan('(': srcds.Src94: aa) > 0; IsFunction = *on; pp = aa; 4e endif; 3e endif; // now to turn callp flag off. Trigger is first // ; that is not behind comment line. aa = %scan(';': srcds.Src94); 3b if aa > 0; bb = %scan('//': srcds.Src94); 4b if bb = 0 or bb > aa; IsCallp = *off; IsFunction = *off; 4e endif; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Two pieces distinct pieces of information on /free line // with different rules for code placement. // 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); srcds.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 // This could get tripped up if there are Quotes in comment and code. // Sure bet is not to put Quotes after //. // If no Quotes after //, then it is 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; //--------------------------------------------------------- // 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; srcds.Src94 = wrkb2; LV leavesr; 4e endif; %len(wblanks) = %len(wblanks) - 1; 3e enddo; 2e endif; 1e endif; endsr; //--------------------------------------------------------- // indent nested DCL-F over one position //--------------------------------------------------------- dcl-proc f_DclNestedIndent; dcl-pi *n char(112); pOpCode char(10); pSource char(112); end-pi; dcl-s string varchar(94); dcl-s xx uns(3); // some DCL- have END- on same line, ignore these lines string = %trimr(%subst(pSource:19)); string = %upper(string); pOpcode = f_CheckSameLineEnd(pOpcode: string); 1b if pOpcode in %list('END-DS':'END-PI':'END-PR':'END-PROC'); 2b if IndentLvl > 0; IndentLvl -= 1; 2e endif; 1e endif; 1b for xx = 1 to IndentLvl; pSource = %replace(' ':pSource: 19: 1); 1e endfor; 1b if pOpcode in %list('DCL-DS':'DCL-PI':'DCL-PR':'DCL-PROC'); IndentLvl += 1; 1e endif; return pSource; end-proc; //--------------------------------------------------------- //--------------------------------------------------------- dcl-proc f_RemoveHexColorCodes; dcl-pi *n char(94); string char(94) options(*varsize); parmlen uns(3) const; end-pi; dcl-c Hex21 const(x'21'); dcl-c Hex3F const(x'3F'); dcl-s xx uns(3); 1b for xx = 1 to ParmLen; 2b if %subst(string: xx: 1) >= Hex21 and %subst(string: xx: 1) <= Hex3F; %subst(string: xx: 1) = *blanks; 2e endif; 1e endfor; return string; end-proc; ]]> '); //--------------------------------------------------------- // JCRNUMBV - Validity checking program with allocate object //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define ApiErrDS /define f_GetQual /define f_SndEscapeMsg /define f_RunCmd /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_FileQual char(20); end-pi; //--------------------------------------------------------- //--------------------------------------------------------- f_CheckMbr(p_FileQual: p_Mbr); // see if source mbr can be allocated, if not send err msg f_RunCmd('ALCOBJ OBJ((' + f_GetQual(p_FileQual) + ' *FILE *EXCLRD ' + %trimr(p_Mbr) + ')) WAIT(1)'); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('Cannot allocate member ' + %trimr(p_Mbr) + ' in source file ' + f_GetQual(p_FileQual)); 1e endif; f_RunCmd('DLCOBJ OBJ((' + f_GetQual(p_FileQual) + ' *FILE *EXCLRD ' + %trimr(p_Mbr) + '))'); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Expanded Object Descriptions') PARM KWD(OBJ) TYPE(OBJ) MIN(1) PROMPT('Object') OBJ: QUAL TYPE(*GENERIC) LEN(10) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) SPCVAL((*ALL) + (*ALLUSR) (*LIBL)) PROMPT('Library') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) DFT(*ALL) + 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') + PROMPT('Created by User Profile') PARM KWD(ALLOWOPT) TYPE(*CHAR) LEN(4) RSTD(*YES) + DFT(*YES) VALUES(*YES *NO) PROMPT('Allow + Options Selection') ]]> A*---------------------------------------------------------------- A*%%EC A DSPSIZ(27 132 *DS4) A INDARA A PRINT A CA03 A CA05 A CA12 A CF13 A CA14 A CA15 A MOUBTN(*ULP CA14) A MOUBTN(*URP CA15) A*------------------------------------------- A R SBFDTA1 SFL A 11 SFLNXTCHG A HIDRISFL 1A H A HIDNDSFL 1A H A HIDSORTCRT 7A H A HIDSORTLST 7A H A AOPTIONSFL 1A P A ARISFL 1A P A ANDSFL 1A P A SBFOPTION 1Y 0B 6 2EDTCDE(4) A DSPATR(&AOPTIONSFL) A SFOBJ 10 O 6 6DSPATR(&ARISFL) A SFTYPE 10 O 6 18DSPATR(&ARISFL) A SFATTR 10A O 6 29DSPATR(&ARISFL) A SFLIB 10 O 6 41DSPATR(&ARISFL) A SFTEXT 30A O 6 52DSPATR(&ARISFL) A SFSIZE 9Y 0O 6 84EDTCDE(4) A DSPATR(&ARISFL) A SFCREATED 6Y 0O 6 94EDTCDE(Y) A DSPATR(&ARISFL) A SFLASTUSE 6Y 0O 6103EDTCDE(Y) A DSPATR(&ANDSFL) A SFDAYSUSED 4Y 0O 6112EDTCDE(3) A DSPATR(&ARISFL) A SFLOCKED 1A O 6118 A SFCREATEBY 10A O 6121DSPATR(&ARISFL) A*---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0418) A SFLPAG(0019) 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 ANOTUSED 1A P A 1 2'JCROBJD' A COLOR(BLU) A 1 23'Expanded Work With Objects' A DSPATR(HI) A SCDOW 9A O 1112COLOR(BLU) A 1122DATE A EDTCDE(Y) A COLOR(BLU) A 2 96'RI=No Last Used Date' A DSPATR(&ANOTUSED) A DSPATR(RI) A 2118'L' A DSPATR(HI) A 2122SYSNAME A COLOR(BLU) A 3 2'1=Wrkobj' A DSPATR(&AOPTIONS) A COLOR(BLU) A 3 12'3=Dspobjlck' A DSPATR(&AOPTIONS) A COLOR(BLU) A 3 25'5=Dspobjd' A DSPATR(&AOPTIONS) A COLOR(BLU) A DBUTILITY 8A O 3 36DSPATR(&AOPTIONS) A COLOR(BLU) A 3 46'8=*ALLUSR' A DSPATR(&AOPTIONS) A COLOR(BLU) A 3 57'9=WRKMBR' A DSPATR(&AOPTIONS) A COLOR(BLU) A 3 67'4=DELETE' A COLOR(RED) A 3 77'7=CLRPFM' A COLOR(RED) A 3 88'2=Dspusrspace' A COLOR(BLU) A 3118'o' A DSPATR(HI) A SCOBJ 10A B 4 6 A SCTYPE 10A B 4 18 A SCATTR 10A B 4 29 A SCLIB 10A B 4 41 A SCTEXT 30A B 4 52 A 4105'Last' A DSPATR(HI) A 4111'Times' A DSPATR(HI) A 4118'c' A DSPATR(HI) A SCCREATEBY 10A B 4121 A 5 2'Opt' A DSPATR(HI) A 5 6'Object' A DSPATR(HI) A 5 18'Type' A DSPATR(HI) A 5 29'Attr' A DSPATR(HI) A 5 41'Lib' A DSPATR(HI) A 5 52'Text' A DSPATR(HI) A 5 86'Size(K)' A DSPATR(HI) A 5 95'Created' A DSPATR(HI) A 5105'Used' A DSPATR(HI) A 5112'Used' A DSPATR(HI) A 5118'k' A DSPATR(HI) A 5121'Created By' A DSPATR(HI) A*---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A BLINK A 26 2'F3=Exit' A COLOR(BLU) A 26 11'F5=Refresh' A COLOR(BLU) A 26 25'F13=Repeat Option' A COLOR(BLU) A 26 49'F14=Sort Ascend' A COLOR(BLU) A 26 71'F15=Sort Descend' A COLOR(BLU) A 26 95'F12=Cancel' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) A*--------------------------------------------------- A R SBFDTA2 SFL A SFOBJ 10A O 6 6 A SFTYPE 10A O 6 18 A SFATTR 10A O 6 29 A SFLIB 10A O 6 41 A SFTEXT 30A O 6 52 A SFSIZE 9Y 0O 6 84EDTCDE(4) A SFCREATED 6Y 0O 6 94EDTCDE(Y) A SFLASTUSE 6Y 0O 6103EDTCDE(Y) A SFDAYSUSED 4Y 0O 6112EDTCDE(3) A SFLOCKED 1A O 6118 A SFCREATEBY 10A O 6121 A*------------------------------------------------- A R SBFCTL2 SFLCTL(SBFDTA2) A SFLSIZ(0209) A SFLPAG(0019) A 41 SFLDSP A 42 SFLDSPCTL A N42 SFLCLR A N44 SFLEND(*MORE) A OVERLAY A 1 2'JCROBJD' A COLOR(BLU) A 1 23'Expanded Work With Objects' A DSPATR(HI) A SCDOW 9A O 1112COLOR(BLU) A 1122DATE A EDTCDE(Y) A COLOR(BLU) A 2118'L' A DSPATR(HI) A 2122SYSNAME A COLOR(BLU) A 3 3'Press ENTER to Delete' A COLOR(RED) A 3118'o' A DSPATR(HI) A 4105'Last' A DSPATR(HI) A 4111'Times' A DSPATR(HI) A 4118'c' A DSPATR(HI) A 5 6'Object' A DSPATR(HI) A 5 18'Type' A DSPATR(HI) A 5 29'Attr' A DSPATR(HI) A 5 41'Lib' A DSPATR(HI) A 5 52'Text' A DSPATR(HI) A 5 86'Size(K)' A DSPATR(HI) A 5 95'Created' A DSPATR(HI) A 5105'Used' A DSPATR(HI) A 5112'Used' A DSPATR(HI) A 5118'k' A DSPATR(HI) A 5121'Created By' A DSPATR(HI) A*------------------------------------------------------ A R SFOOTER2 A 26 4'Press Enter to Delete' A COLOR(BLU) A 26 95'F12=Cancel' A COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Works with list of objects similar to WRKOBJ command. Sort any column either ascend or descend by placing cursor on 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.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, probably want this *YES, for a business user, *NO.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCROBJDR - Expanded work with object descriptions // 08/30/22 add are you sure delete subfile //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCROBJDD workstn sfile(sbfdta1: rrn1) sfile(sbfdta2: rrn2) infds(infds) indds(ind); /define Qwclobjl /define ApiErrDS /define f_DecodeApiTimeStamp /define Constants /define Infds /define Dspatr /define FunctionKeys /define Ind /define Quslobj /define psds /define f_BuildString /define f_GetQual /define f_Quscrtus /define f_RmvSflMsg /define f_SndCompMsg /define f_SndStatMsg /define f_GetFileUtil /define f_GetDayName /define f_SndEscapeMsg /define f_RtvMsgAPI /define f_RunCmd /define f_RunOptionFile /COPY JCRCMDS,JCRCMDSCPY dcl-s OptionSav like(sbfoption); dcl-s SaveOriginal like(QwcrtvcaDS); dcl-s KeyFld char(10) inz('SFSIZE'); dcl-s SequenceText char(10) inz('Descend'); dcl-s LengthOfBuffer int(10); dcl-s xx int(10); dcl-s DeleteCount uns(5); dcl-s NumberOfRecs uns(5); dcl-s rrn1 uns(5); dcl-s rrn1save like(rrn1); dcl-s rrn1x like(rrn1); dcl-s rrn2 like(rrn1); dcl-s IsFirstTime ind; dcl-s p_scantext char(30); //see if text search changed dcl-s membername char(10); // Retrieve Current Attributes dcl-pr Qwcrtvca extpgm('QWCRTVCA'); *n char(150); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n int(10) const; // number of keys *n char(12); // keys list *n like(ApiErrDS); end-pr; dcl-ds QwcrtvcaDS len(150) qualified; AttrReturnCnt int(10) inz; end-ds; // ds to extract retrieved attributes from API call dcl-ds rtvc0100DS qualified based(rtvc0100Ptr); Length int(10); Key int(10); DataType char(1); Reserved char(3); LenOfData int(10); Data char(30); end-ds; dcl-ds Alpha2NumDS qualified; Numeric int(10) inz; end-ds; // Change Job dcl-pr Qwtchgjb extpgm('QWTCHGJB'); *n char(26) const; // job name *=current *n char(16) const; // internal identifier *n char(8) const; // api format *n char(150); // receiver *n like(ApiErrDS); end-pr; dcl-ds BinaryKeysArry qualified; Purge1604 int(10) inz(1604); Runpty1802 int(10) inz(1802); TimeSlice2002 int(10) inz(2002); end-ds; // ScreenFieldDS - load screen fields into sort array dcl-ds SortArry likeds(ScreenFieldDS) dim(9999); dcl-ds ScreenFieldDS; sfLib; sfObj; sfType; sfAttr; sfText; sfSize; sfCreated; sfLastUse; sfDaysUsed; hidRIsfl; hidNDsfl; HidSortcrt; // C YY MM DD for sort HidSortlst; // C YY MM DD for sort sfCreateBy; sfLocked; end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_ObjType char(10); p_ObjAttr char(10); p_CreateBy char(10); p_AllowOption char(4); end-pi; //--------------------------------------------------------- IsFirstTime = *on; f_SndStatMsg(f_BuildString('Retrieving & type & - in progress': f_GetQual(p_ObjQual): p_ObjType)); aNotUsed = ND; scDow = f_GetDayName(); exsr srDiscreteBumpJobPriority; DbUtility = '6=' + f_GetFileUtil(); 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 ApiHeadPtr = f_Quscrtus(UserSpaceName); ApiHeadPtr2= f_Quscrtus(UserSpaceName2); exsr srRefreshScreen; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; Ind.sfldsp = (rrn1 > 0); Ind.sfldspctl = *on; 2b if (not Ind.sfldsp); f_RmvSflMsg(ProgId); snd-msg 'No objects matching selection were found'; 2e endif; write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); f_SndCompMsg(f_BuildString('JCROBJD for & type & - completed': f_GetQual(p_ObjQual): p_ObjType)); *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); // refresh 2b if InfdsFkey = f05; exsr srRefreshScreen; 1i iter; 2e endif; 2b if InfdsFkey = f13; readc sbfdta1; exsr srRepeat_Option; 1i iter; 2e endif; // user selected new library or object 2b if NOT(p_ObjQual = scObj + sclib and p_ObjType = scType and p_ObjAttr = scAttr and p_CreateBy = scCreateBy and p_ScanText = scText); p_ObjQual = %scanrpl(' ':'*ALL ':scObj) + %scanrpl(' ':'*ALLUSR ':sclib); p_ObjType = %scanrpl(' ':'*ALL':scType); p_ObjAttr = %scanrpl(' ':'*ALL':scAttr); p_CreateBy = %scanrpl(' ':'*ALL':scCreateBy); p_scantext = sctext; exsr srRefreshScreen; 1i iter; 2e endif; 2b if InfdsSflRcdNbr > 0; SflRcdNbr = InfdsSflRcdNbr; 2x else; SflRcdNbr = 1; 2e endif; // re-sort subfile 2b if InfdsFkey in %list(F14: F15); 3b if InfdsFkey = F14; SequenceText = 'Ascend'; 3e endif; 3b if InfdsFkey = F15; SequenceText = 'Descend'; 3e endif; KeyFld = curfld; exsr srSortAndReload; SflRcdNbr = 1; 1i iter; 2e endif; //----------------------------------------------- DeleteCount = 0; 2b if Ind.sfldsp; rrn2 = 0; ind.sfldsp2 = *off; ind.sfldspctl2 = *off; write sbfctl2; readc sbfdta1; 3b dow not %eof; 4b if sbfOption = 4; rrn2 += 1; write sbfdta2; 4x elseif sbfOption > 0; f_RunOptionObject( sbfOption: sfObj: sfLib: sfType: ProgId); 4e endif; //---------------------------------------- sbfOption = 0; aRIsfl = hidRIsfl; aNDsfl = hidNDsfl; SflRcdNbr = rrn1; update sbfdta1; readc sbfdta1; 3e enddo; 2e endif; 2b if rrn2 > 0; exsr srdelete; 2e endif; 1e enddo; //--------------------------------------------------------- //--------------------------------------------------------- begsr srdelete; ind.sfldsp2 = (rrn2>0); ind.sfldspctl2 = *on; write sfooter2; exfmt sbfctl2; 1b if *inkc or *inkl; snd-msg 'Delete Canceled'; LV leavesr; 1e endif; deletecount = rrn2; 1b for rrn2 = 1 to deletecount; chain rrn2 sbfdta2; sbfOption = 4; f_RunOptionObject( sbfOption: sfObj: sfLib: sfType: ProgId); 2b if ApiErrDS.BytesReturned > 0; //error occurred f_RmvSflMsg(ProgId); snd-msg ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); 2e endif; 1e endfor; snd-msg 'Delete Completed'; exsr srRefreshScreen; endsr; //--------------------------------------------------------- // load object name list //--------------------------------------------------------- begsr srRefreshScreen; Ind.sfldsp = *off; Ind.sfldspctl = *off; aRIsfl = Green; aNDsfl = Green; aNotUsed = ND; SFLRCDNBR = 1; write sbfctl1; rrn1 = 0; scObj = %subst(p_ObjQual: 1: 10); scLib = %subst(p_ObjQual: 11: 10); scType = p_ObjType; scAttr = p_ObjAttr; scCreateBy = p_CreateBy; scText = p_scantext; callp QUSLOBJ( UserSpaceName: 'OBJL0700': p_ObjQual: p_ObjType: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; // 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 xx = 0; QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; // v7r4 1b if ApiHead.ListEntryCount <= 9999; // %elem(sortarry) = ApiHead.ListEntryCount; 1x else; ApiHead.ListEntryCount = 9999; // %elem(sortarry) = 9999; 1e endif; 1b for ForCount = 1 to ApiHead.ListEntryCount; // only load objects that match attributes 2b if p_CreateBy in %list('*ALL':QuslobjDS.CreatedByUser); sfCreateBy = QuslobjDS.CreatedByUser; 3b if p_ObjAttr in %list('*ALL': QuslobjDS.ExtendedAttr); aRIsfl = Green; aNDsfl = Green; sfObj = QuslobjDS.ObjNam; sfLib = QuslobjDS.ObjLib; sfType = QuslobjDS.ObjTyp; sfAttr = QuslobjDS.ExtendedAttr; 4b if %subst(scLib: 1: 1) = '*'; sfText = QuslobjDS.ObjLib + ' ' + QuslobjDS.ObjText; 4x else; sfText = QuslobjDS.ObjText; 4e endif; 4b if sctext = *blanks or %scan(%trim(sctext):%upper(sfText))> 0; ApiStampDS = f_DecodeApiTimeStamp(QuslobjDS.CreateStamp); HidSortcrt = ApiStampDS.Century + ApiStampDS.YY + ApiStampDS.MMDD; sfCreated = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); 5b if QuslobjDS.NumDaysUsed > 9999; sfDaysUsed = 9999; 5x else; sfDaysUsed = QuslobjDS.NumDaysUsed; 5e endif; 5b if QuslobjDS.NumDaysUsed > 0; ApiStampDS = f_DecodeApiTimeStamp(QuslobjDS.LastUseStamp); HidSortlst = ApiStampDS.Century + ApiStampDS.YY + ApiStampDS.MMDD; sfLastUse = %dec(ApiStampDS.MMDD + ApiStampDS.YY: 6: 0); 5x else; aRIsfl = %bitor(Green: RI); aNotUsed = %bitor(Green: RI); aNDsfl = ND; sfLastUse = 0; HidSortlst = *blanks; 5e endif; sfSize = (QuslobjDS.ObjSize * QuslobjDS.MultiplySize)/1024; 5b if sfAttr = 'DDMF'; aRIsfl = Green; 5e endif; exsr srGetlockcount; hidRIsfl = aRIsfl; hidNDsfl = aNDsfl; rrn1 += 1; xx += 1; SortArry(xx) = ScreenFieldDS; 5b if xx = 9999; 1v leave; 5e endif; 4e endif; 3e endif; 2e endif; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; rrn1save = rrn1; // Allow user to make selection from subfile 1b if xx>0; exsr srLoadFromSorter; 1e endif; 1b if SflRcdNbr <= 0; SflRcdNbr = 1; 1e endif; endsr; //--------------------------------------------------------- // 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 = rrn1; OptionSav = sbfOption; 1b for rrn1x = SflRcdNbr to rrn1save; chain rrn1x sbfdta1; 2b if not %found; 1v leave; 2e endif; Ind.sflnxtchg = *on; sbfOption = OptionSav; update sbfdta1; 1e endfor; Ind.sflnxtchg = *off; endsr; //--------------------------------------------------------- // Read subfile and load records into sorting array //--------------------------------------------------------- begsr srSortAndReload; NumberOfRecs = rrn1save; 1b if DeleteCount > 0; rrn1save -= DeleteCount; 2b if rrn1save = 0; SflRcdNbr = 1; 2x elseif SflRcdNbr > rrn1save; SflRcdNbr = rrn1save; 2e endif; 1e endif; xx = 0; 1b if rrn1save >0; 2b for rrn1 = 1 to NumberOfRecs; chain rrn1 sbfdta1; 3b if not(sbfOption = 4); //DELETE OPTION xx += 1; SortArry(xx) = ScreenFieldDS; 3e endif; 2e endfor; exsr srLoadFromSorter; 1e endif; rrn1 = rrn1save; endsr; //--------------------------------------------------------- // Sort array and load back into subfile //--------------------------------------------------------- begsr srLoadFromSorter; Ind.sfldsp = *off; Ind.sfldspctl = *off; aRIsfl = Green; aNDsfl = Green; write sbfctl1; rrn1 = 0; 1b if KeyFld = 'SFSIZE'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfsize: sfObj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfsize: sfObj); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Size'; 1x elseif KeyFld = 'SFLIB'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfLib: sfObj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfLib); 2e endif; snd-msg 'Sort '+%trimr(SequenceText) +' by Library Name'; 1x elseif KeyFld = 'SFOBJ'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfObj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfObj); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Object Name'; 1x elseif KeyFld = 'SFTYPE'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfType: sfObj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfType); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Object Type'; 1x elseif KeyFld = 'SFATTR'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfAttr: sfObj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfAttr); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Attribute'; 1x elseif KeyFld = 'SFTEXT'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sftext); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sftext); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Text'; 1x elseif KeyFld = 'SFCREATED '; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(HidSortcrt: sfLib); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(HidSortcrt); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Created Date'; 1x elseif KeyFld = 'SFLASTUSE'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(HidSortlst:sfobj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(HidSortlst); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Last Used Date'; 1x elseif KeyFld = 'SFDAYSUSED'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfDaysUsed:sfobj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfDaysUsed); 2e endif; snd-msg 'Sort '+%trimr(SequenceText) +' by Number of Times Used'; 1x elseif KeyFld = 'SFCREATEBY'; 2b if SequenceText = 'Ascend'; sorta %subarr(sortarry:1:xx) %fields(sfCreateBy:sfobj); 2x else; sorta(d) %subarr(sortarry:1:xx) %fields(sfCreateBy); 2e endif; snd-msg 'Sort ' + %trimr(SequenceText) +' by Created by User'; 1e endif; 1b if xx >= 9999; f_RmvSflMsg(ProgId); snd-msg '9999+ objects returned. Narrow the search.'; xx = 9999; 1e endif; // v75 works as %subarr(sortarry:1:xx) is variable defined array // there are only as many elements as there are loaded elements 1b for-each ScreenFieldds in %subarr(sortarry:1:xx); aRIsfl = hidRIsfl; aNDsfl = hidNDsfl; sbfOption = 0; rrn1 += 1; write sbfdta1; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srDiscreteBumpJobPriority; // retrieve job values callp QWCRTVCA( QwcrtvcaDS: %len(QwcrtvcaDS): 'RTVC0100': 3: BinaryKeysArry: ApiErrDS); //--------------------------------------------------------- // Save original values then modify variable with new values // for passing 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; //----------------------------------------------------- begsr srGetlockcount; 1b if sftype = '*FILE'; membername = '*FIRST'; 1x else; membername ='*NONE'; 1e endif; callp QWCLOBJL( UserSpaceName2: 'OBJL0100': sfobj + sflib: sftype: membername: ApiErrDS); 1b if ApiHead2.ListEntryCount = 0; sflocked = ' '; 1x else; sflocked = '+'; 1e endif; endsr; //--------------------------------------------------------- // Execute selected command //--------------------------------------------------------- dcl-proc f_RunOptionObject; dcl-pi *n; p_Option packed(1); p_sfObj char(10); p_sfLib char(10); p_ObjType char(10); p_ProgId char(10); end-pi; dcl-s sfLibAndName char(21); dcl-s msg char(75); dcl-pr Qlidlto extpgm('QLIDLTO'); //delete object *n char(20) const; // name and lib *n char(10) const; // type *n char(10) const; // auxillary stg *n char(1) const; // remove message *n like(ApiErrDS); end-pr; sfLibAndName = f_GetQual(p_sfObj + p_sfLib); 1b if p_Option = 1; f_RunCmd(f_BuildString('WRKOBJ OBJ(&) OBJTYPE(&)': sfLibAndName: p_ObjType)); msg = 'Work Object ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 2; f_RunCmd('JCRUSPACE USERSPACE(' + sfLibAndName + ')'); msg = 'User Space Data Display ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 3; f_RunCmd(f_BuildString('WRKOBJLCK OBJ(&) OBJTYPE(&)': sfLibAndName: p_ObjType)); msg = 'Work Object Lock ' + %trimr(p_sfObj) + ' - completed'; // delete object APi 1x elseif p_Option = 4; callp Qlidlto( p_sfObj + p_sfLib: p_ObjType: '*': '0': ApiErrDS); msg = 'Delete Object ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 5; f_RunCmd(f_BuildString('DSPOBJD OBJ(&) OBJTYPE(&)': sfLibAndName: p_ObjType)); msg = 'Display Object Description ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 6; f_RunOptionFile(2: p_sfObj: p_sfLib: '*FIRST': '*FIRST': p_ProgId); 1x elseif p_Option = 7; f_RunCmd('CLRPFM ' + sfLibAndName); msg = 'Clear Physical File Member ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 8; f_RunCmd(f_BuildString('WRKOBJ OBJ(*ALLUSR/&) OBJTYPE(&)': p_sfObj: p_ObjType)); msg = 'Wrkobj *allusr/ ' + %trimr(p_sfObj) + ' - completed'; 1x elseif p_Option = 9; f_RunCmd('WRKMBRPDM ' + sfLibAndName); msg = 'Work with members ' + %trimr(p_sfObj) + ' - completed'; 1x else; msg = 'Option ' + %char(p_Option) + ' is not available'; 1e endif; snd-msg msg %TARGET('JCROBJDR'); return; end-proc; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Jobs With Object Locks') PARM KWD(OBJ) TYPE(OBJ) MIN(1) PROMPT('Object') OBJ: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') PARM KWD(OBJTYPE) TYPE(*CHAR) LEN(10) DFT(*FILE) + PROMPT('Object type') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA CA03 CA05 CA08 CA10 CA12 A R SBFDTA1 SFL A SCJOBNUMB 6A H A SBFOPTION 2Y 0B 7 2EDTCDE(4) A SCJOBNAME 10A O 7 5 A SCJOBUSER 10A O 7 16 A SCDS 48 O 7 27 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY BLINK A *DS3 SFLPAG(15) SFLSIZ(60) A *DS4 SFLPAG(15) SFLSIZ(60) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCROLCK' COLOR(BLU) A 1 23'Jobs With Object Locks' DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) COLOR(BLU) A 2 2'Object:' DSPATR(HI) A SCOBJHEAD 61A O 2 10 A 2 72SYSNAME COLOR(BLU) A 4 2'1=Sndbrkmsg' COLOR(BLU) A 4 15'2=Chgjob' COLOR(BLU) A 4 25'3=Strsrvjob' COLOR(BLU) A 4 38'4=Endjob' COLOR(BLU) A 4 48'5=Dspjob' COLOR(BLU) A 4 58'8=Wrksplf' COLOR(BLU) A 4 69'9=File I/O' COLOR(BLU) A 5 2'10=Strdbg' COLOR(BLU) A 5 24'15=Endsrvjob' COLOR(BLU) A 5 37'11=Dspusrprf' COLOR(BLU) A 5 57'20=Enddbg' COLOR(BLU) A 6 5'Job' DSPATR(HI) A 6 16'User' DSPATR(HI) A SCTOGGHEAD 48 O 6 27DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A 23 2'F3=Exit' COLOR(BLU) A 23 11'F5=Refresh' COLOR(BLU) A 23 23'F8=Toggle Lock/User Info' A COLOR(BLU) A 23 49'F10=Set Break Msg' COLOR(BLU) A 23 69'F12=Cancel' 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' COLOR(BLU) A 5 21'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Great for releasing object locks in a hurry. SNDBRKMSG and ENDJOB *IMMED to jobs with locks on an object. Call to API retrieves job names with a lock. 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. ]]> '); //--------------------------------------------------------- // JCROLCKR - Object lock list-sndbrkmsg or endjob(*immed) // Modify BreakMsgText to change default break message text. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCROLCKD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define Qwclobjl /define ApiErrDS /define Constants /define Infds /define FunctionKeys /define Ind /define psds /define f_BuildString /define f_RunOptionJob /define f_GetQual /define f_GetDayName /define f_Quscrtus /define f_Qusrobjd /define f_RmvSflMsg /define f_RunCmd /COPY JCRCMDS,JCRCMDSCPY dcl-s SflRcdNbrSav like(sflrcdnbr); dcl-s BreakMsgQueue char(20) dim(50); dcl-s BreakMsgText char(70); dcl-s JobNamePrev char(10); dcl-s JobNumbPrev char(6); dcl-s JobUserPrev char(10); dcl-s MbrName char(10); dcl-s IsToggleLock ind; dcl-s IsRefresh ind inz(*off); // Send Break Message dcl-pr Qmhsndbm extpgm('QMHSNDBM'); *n char(70); // text *n int(10) const; // length *n char(10) const; // type *n char(20) dim(50); // msgq array *n int(10) const; // msg length *n char(20) const; // msg reply queue *n like(ApiErrDS); end-pr; // toggle between lock information and user profile text dcl-ds LockInfoDS qualified; scLock char(10) pos(1); scStatus char(6) pos(12); scType char(19) pos(19); scMbr char(10) pos(39); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_ObjTyp char(10); end-pi; scDow = f_GetDayName(); //--------------------------------------------------------- QusrObjDS = f_QUSROBJD(p_ObjQual: p_ObjTyp); %subst(p_ObjQual: 11: 10) = QusrObjDS.ReturnLib; 1b if %subst(QusrObjDS.ExtendedAttr: 1: 2) in %list('PF':'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 ApiHeadPtr = f_Quscrtus(UserSpaceName); exsr srRefreshScreen; //--------------------------------------------------------- 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; f_RmvSflMsg(ProgId); SflRcdNbr = InfdsSflRcdNbr; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; // refresh 2x elseif InfdsFkey in %list(f05 :f08); IsRefresh = *on; SflRcdNbrSav = SflRcdNbr; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn = 0; 3b if InfdsFkey = f08; IsToggleLock = (not IsToggleLock); 3e endif; exsr srRefreshScreen; // override default break message 2x elseif InfdsFkey = f10; wbBrkMsg = BreakMsgText; exfmt WindowB; 3b if not(InfdsFkey = f12); BreakMsgText = wbBrkMsg; 3e endif; 2x elseif Ind.sfldsp; //------------------------------------------- readc sbfdta1; 3b dow not %eof; 4b if sbfOption > 0; // Load and send break message 5b if sbfOption = 1; BreakMsgQueue(1) = scJobName + '*LIBL'; snd-msg 'Break message sent'; callp QMHSNDBM( BreakMsgText: %size(BreakMsgText): '*INFO': BreakMsgQueue: 1: 'QSYSOPR *LIBL': ApiErrDS); 5x elseif sbfOption = 11; f_RunCmd(f_buildstring( 'DSPUSRPRF USRPRF(&)': scJobUser)); 5x else; f_RunOptionJob( sbfoption: scJobName: scJobUser: scJobNumb: ProgId); 5e endif; // update subfile to reflect selected change sbfOption = 0; update sbfdta1; SflRcdNbr = rrn; 4e endif; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- // load object lock jobs 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; JobNamePrev = *blanks; JobUserPrev = *blanks; JobNumbPrev = *blanks; callp QWCLOBJL( UserSpaceName: 'OBJL0100': p_ObjQual: p_ObjTyp: MbrName: ApiErrDS); // Process list entries in user space QwclobjlPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; // Some jobs can have multiple different type locks on same object. // For this screen, 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 += ApiHead.ListEntrySize; 1e endfor; //---------------------------------------- SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); snd-msg '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; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Retrieve Partition Info') ]]> .*-------------------------------------------------------------------- :P.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 current system/partition.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRPARTIR - Retrieve Partition Info for current system // *featured in 2010/01 iSeries News magazine //--------------------------------------------------------- ctl-opt bnddir('QUSAPIBD'); /define ControlStatements /define ApiErrDS /define f_Quscrtus /define Qmhsndpm /define Qwcrneta /COPY JCRCMDS,JCRCMDSCPY dcl-s OsVersion char(6); dcl-s EquivalentOS char(6); dcl-s MsgTxt varchar(78); dcl-s NonVary char(78); dcl-s LparFormat int(10) inz(1); dcl-s LparRcvLen int(10) inz(%len(lparinfods)); dcl-s xx uns(3); dcl-s IsFoundIP ind inz(*off); dcl-s FirstActiveIP like(nifc0100DS.IP); dcl-s jobuser char(10) inz(*user); // Get LPAR Numerical Partition dcl-pr dlpar_get_info int(10) extproc(*dclcase); // LPAR info *n like(LparInfoDS); // Receiver *n int(10) value; // Format *n int(10) value; // Receiver Length end-pr; dcl-ds LparInfoDS qualified inz; LparNumber int(10) pos(41); end-ds; // Retrieve System Values dcl-pr Qwcrsval extPgm('QWCRSVAL'); // Get System Value *n char(200); // Serial number *n int(10) const; // QwcrsvalDS length *n int(10) const; // Number of values *n char(20) const; // Sysval names *n like(ApiErrDS); end-pr; dcl-ds qwcrsvalDS len(200) qualified; EntryCount int(10) pos(1); OffsetToVal int(10) pos(5) dim(2); end-ds; dcl-s valoffset int(10); dcl-ds InfoTableDS len(50) qualified based(InfoTablePtr); ValueName char(10) pos(1); LenOfData int(10) pos(13); SystemValue char(10) pos(17); end-ds; // Check Target Release dcl-pr qszchktg extpgm('QSZCHKTG'); *n char(10) const; // OS version *n char(10) const; // OS list *n int(10) const; // Number of supported *n char(6); // Validated release *n char(6); // Equivalent release *n like(ApiErrDS); end-pr; //--------------------------------------------------------- // List Network Interfaces dcl-pr QtocLstNetIfc extproc(*dclcase); *n char(20); // user space *n char(8) const; // format *n like(ApiErrDS); end-pr; dcl-ds nifc0100DS qualified based(nifc0100Ptr); IP char(15) pos(1); NetworkAddr char(15) pos(21); NetworkName char(10) pos(41); LineDescript char(10) pos(51); InterfaceStatus int(10) pos(73); end-ds; //--------------------------------------------------------- // get system name callp QWCRNETA( QwcrnetaDS: %size(QwcrnetaDS): 1: 'LCLCPNAME': ApiErrDS); NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.TableOffset; MsgTxt = %trimr(NetworkInfoDS.LocalSysName); //--------------------------------------------------------- // get system serial number and model number callp QWCRSVAL( qwcrsvalDS: %size(qwcrsvalDS): 2: 'QMODEL QSRLNBR': ApiErrDs); 1b for-each valoffset in qwcrsvalDS.OffsetToVal; InfoTablePtr = %addr(qwcrsvalDS) + valoffset; 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); // load user profile MsgTxt += ' ' + %trimr(JobUser); //--------------------------------------------------------- // get IP address ApiHeadPtr = f_Quscrtus(UserSpaceName); // load network interface names into user space callp QtocLstNetIfc( UserSpaceName: 'NIFC0100': ApiErrDS); IsFoundIP = *off; nifc0100Ptr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if nifc0100DS.InterfaceStatus > 0; FirstActiveIP = nifc0100DS.IP; 3b if nifc0100DS.LineDescript = 'ETHERNET'; MsgTxt += ' ' + %trim(nifc0100DS.IP); IsFoundIP = *on; 1v leave; 3e endif; 2e endif; nifc0100Ptr += ApiHead.ListEntrySize; 1e endfor; // not everyone has their IP address labeled ETHERNET, if not found use first active 1b if not IsFoundIP; MsgTxt += ' ' + %trim(FirstActiveIP); 1e endif; //--------------------------------------------------------- NonVary = MsgTxt; callp QMHSNDPM( ' ': ' ': NonVary: 78: '*INFO': '*CTLBDY': 1: ' ': ApiErrDS); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Create from PRTF Attributes') PARM KWD(PRTFMBR) TYPE(*NAME) MIN(1) PROMPT('PRTF + source member') 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(CRTLIB) TYPE(*NAME) DFT(*SRCLIB) + SPCVAL((*SRCLIB)) 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') ]]> .*-------------------------------------------------------------------- :P.Compiles a print file using compile attributes from the existing print file object. For example, this print file was created with a different line count than default and needed to be recompiled. :P.The command replicates common attributes from existing print file and applies them to the compile command of new print file.: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 whose attributes are retrieved. :PARML.:PT.:PK def.*SRCMBR:EPK.:PD.Use same name as PRTF being created. Useful if working on print file and several recompiles are required. :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. ]]> '); //--------------------------------------------------------- // JCRPATTRR- Crtprtf with attributes from existing PRTF // Uses Retrieve Printer File Attributes (QDFRPRTA) API. Only most used or // requested fields are being pulled. // Most of this program is mapping from API returned values into compile values. //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Constants /define f_BuildString /define f_GetQual /define f_SndCompMsg // *ENTRY /define p_JCRPATTRR /COPY JCRCMDS,JCRCMDSCPY dcl-s string1 char(500); dcl-s PageRotation char(5); dcl-s IGCdata char(4); dcl-s IGCextension char(4); dcl-s Save char(4); dcl-s Hold char(4); dcl-s OverFlow packed(3); dcl-s pageLen packed(6: 3); dcl-s pageWidth packed(6: 3); dcl-s CPI packed(3: 1); dcl-s LPI packed(3: 1); dcl-s FMD packed(7: 4); dcl-s FMA packed(7: 4); dcl-s FrontMargin char(19); dcl-s FrontOverlay char(50); dcl-s BackOverlay char(50); dcl-s FrontOvlDown packed(5: 3); dcl-s FrontOvlAccros packed(5: 3); dcl-s BackOvlDown packed(5: 3); dcl-s BackOvlAccros packed(5: 3); dcl-s BackConstant char(11); dcl-s Chrid char(11); dcl-s MaxRecordsNum packed(8); dcl-s Copies packed(3); dcl-s MaxRecords char(8); dcl-s CharIdSet packed(5); dcl-s CharIdCodePage packed(5); dcl-s UsrRscLibl char(100); dcl-s Text char(100); dcl-s PrtTxt char(100); dcl-s UsrRscLiblEnt char(10) based(UsrRscLiblPtr); dcl-s UsrRscLiblPtr pointer; // Retrieve Printer File Attributes dcl-pr QDFRPRTA extpgm('QDFRPRTA'); *n char(4000); // receiver *n int(10) const; // receiver length *n char(8) const; // format *n char(20); // file name and lib *n like(ApiErrDS); end-pr; dcl-ds qdfrprtaDS len(4000) qualified; BytesReturned int(10) pos(1); BytesAvail int(10) pos(5); PrintFileName char(10) pos(9); Lib char(10) pos(19); Device char(10) pos(29); DeviceType char(10) pos(39); PageSizeLen packed(15: 5) pos(49); PageSizeWidth packed(15: 5) pos(57); LPI packed(15: 5) pos(77); CPI packed(15: 5) pos(85); OverFlow int(10) pos(93); Text char(50) pos(98); FMarginDown packed(15: 5) pos(149); FMarginAccros packed(15: 5) pos(157); PrintQuality char(10) pos(219); FontIdentifier char(10) pos(249); CharIdSet int(10) pos(269); CharIdCodePage int(10) pos(273); DecimalFormat char(10) pos(277); PageRotation int(10) pos(417); PrtTxt char(30) pos(435); PrintBothSides char(10) pos(469); FrontOvlFile char(8) pos(490); FrontOvlLib char(10) pos(498); FrontOvlDown packed(15: 5) pos(509); FrontOvlAccros packed(15: 5) pos(517); BackOvlFile char(10) pos(525); BackOvlLib char(10) pos(535); BackOvlDown packed(15: 5) pos(545); BackOvlAccros packed(15: 5) pos(553); BackOvlConstant char(1) pos(561); IPDSPASTHR char(10) pos(563); UsrRscLiblOff int(10) pos(573); UsrRscLiblCnt int(10) pos(577); UsrRscLiblLen int(10) pos(581); FormType char(10) pos(688); Copies int(10) pos(701); MaxRecords int(10) pos(725); Hold char(1) pos(743); Save char(1) pos(744); UsrDBCSdata char(1) pos(1066); DBCSextension char(1) pos(1067); end-ds; dcl-pr Qcmdexc extpgm('QCMDEXC'); *n char(125) options(*VarSize); *n packed(15: 5) const; end-pr; //--------------------------------------------------------- 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 aa = 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; Copies = qdfrprtaDS.Copies; 1b if qdfrprtaDS.FMARGINACCROS = -2; 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; //--------------------------------------------------------- // 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. //--------------------------------------------------------- Text = %scanrpl(qs: qs+qs: qdfrprtaDS.Text); PrtTxt = %scanrpl(qs: qs+qs: qdfrprtaDS.PrtTxt); //--------------------------------------------------------- // 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(&) COPIES(&) ': 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: %char(Copies)); //--------------------------------------------------------- 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; ]]> '); //--------------------------------------------------------- // JCRPATTRV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_Qusrobjd /define f_SndEscapeMsg // *ENTRY /define p_JCRPATTRR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckMbr(p_SrcFilQual: p_SrcMbr); //--------------------------------------------------------- 1b if p_CrtToLib = '*SRCLIB'; p_CrtToLib = %subst(p_SrcFilQual: 11: 10); 1e endif; f_CheckObj(p_CrtToLib + '*LIBL': '*LIB'); //--------------------------------------------------------- 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; f_CheckObj(p_LikePrtf: '*FILE'); QusrObjDS = f_Qusrobjd(p_LikePrtf: '*FILE'); 1b if QusrObjDS.ExtendedAttr <> 'PRTF'; f_SndEscapeMsg('Use File ' + %trimr(%subst(p_LikePrtf: 1: 10)) + ' is not type PRTF.'); 1e endif; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRPATTRV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj // *ENTRY /define p_JCRPATTRR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckMbr(p_SrcFilQual: p_SrcMbr); //--------------------------------------------------------- 1b if p_CrtToLib = '*SRCLIB'; p_CrtToLib = %subst(p_SrcFilQual: 11: 10); 1e endif; f_CheckObj(p_CrtToLib + '*LIBL': '*LIB'); //--------------------------------------------------------- 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; f_CheckObj(p_LikePrtf: '*FILE'); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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') ]]> .*-------------------------------------------------------------------- :P.Generates DCL-PR prototype definitions either into the selected source member or adds a new source member if member name does not exist. :P. Then enter the name of the program object to call and the name of the source member to call it from. :P.After execution, call prototype code will be at bottom of the source. Will need to move source to proper place in the source member. :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 location that compiled 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.Must prompt JCRPRGEN command for POP to work properly.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRPRGEN/INSERTINTO'.Insert Prototype into SrcMbr - Help :XH3.Insert Prototype into SrcMbr (INSERTINTO) :P.Member name to be updated or created with prototype source code.:EHELP. :HELP NAME='JCRPRGEN/INSERTSRCF'.Source file - Help :XH3.Source file (INSERTSRCF) :P.Source file containing RPG source member.:EHELP. :HELP NAME='JCRPRGEN/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='JCRPRGEN/SRCFIL'.Source file - Help :XH3.Source file (SRCFIL) :P.Source file containing source.:EHELP. :HELP NAME='JCRPRGEN/SRCLIB'.Source Library - Help :XH3.Source library (SRCLIB) :P.Library where source file is located.:EHELP. :HELP NAME='JCRPRGEN/SRCMBR'.Source Member - Help :XH3.Source Member (SRCMBR) :P.Source member.:EHELP. :HELP NAME='JCRPRGEN/PGMATR'.Program attribute - Help :XH3.Program Attribute (PGMATR) :P.Type of program object.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRPRGENO - prompt override program // return command prompt override string for program source lib/file/mbr //--------------------------------------------------------- /define ControlStatements /define f_PromptOverrideGetSource /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_CmdQual char(20); filler1 char(10); filler2 char(20); p_PgmQual char(20); p_RtnString char(5700); end-pi; //--------------------------------------------------------- p_RtnString = f_PromptOverrideGetSource(p_PgmQual); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRPRGENR - generate callp prototypes // Call programs to read compile listings and generate prototype. //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Constants /define f_GetQual /define f_Qusrmbrd /define f_SndCompMsg /define f_SndEscapeMsg /define FieldsArry /define FieldsAttrDS /define f_IsIgnoreLine /define f_IsCompileTimeArray /define f_GetProcedureEntryPoint /define f_GetParmFieldsArryIndex /define f_GetDataTypeKeyWords /define SourceOutDS /define p_JCRGETCLPR /define p_JCRGETFLDR // *ENTRY /define p_JCRPRGENR /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRGETFLDF disk(132) extfile('QTEMP/JCRGETFLDF') usropn; dcl-ds InputDS len(132) qualified inz; CompileArray char(3) pos(3); SpecType char(1) pos(8); Src94 char(94) pos(9); SourceListing char(27) pos(27); EndOfSource char(25) pos(20); end-ds; dcl-f PROTOSRC disk(112) usage(*output) extfile(extOFile) extmbr(p_InsertInMbr) usropn; //--------------------------------------------------------- dcl-s string varchar(94); dcl-s ProcedureEntryPoint char(6); dcl-s PepCnt packed(3); dcl-s DoParmCnt packed(3); //--------------------------------------------------------- extOFile = f_GetQual(p_InsertFileQual); open PROTOSRC; 1b if p_Pgmatr in %list('RPGLE':'SQLRPGLE'); exsr srRPG; 1b elseif p_Pgmatr in %list('CLLE':'CLP'); exsr srCL; 1e endif; close PROTOSRC; f_SndCompMsg('JCRPRGEN Protoype for ' + %trimr(p_SrcMbr) + ' in member ' + %trimr(p_InsertInMbr) + ' - completed.'); *inlr = *on; return; //--------------------------------------------------------- // if no parms, do a single line pr // dcl-pr p_TEST extpgm('TEST') end-pr; //--------------------------------------------------------- begsr srWriteDclPR; QusrmbrdDS = f_Qusrmbrd(p_SrcFil + p_SrcLib: p_SrcMbr: 'MBRD0100'); OutDS.SrcCod = ' //-----' + %trim(QusrmbrdDS.Text) + ' ------'; OutDS.SrcSeq += 10; write PROTOSRC OutDS; OutDS.SrcCod = ' dcl-pr p_' + %trimr(p_SrcMbr) + ' extpgm(' + qs + %trimr(p_SrcMbr) + qs + ')'; 1b if PepCnt = 0; OutDS.SrcCod = %trimr(OutDS.SrcCod) + ' end-pr;'; 1x else; OutDS.SrcCod = %trimr(OutDS.SrcCod) + ';'; 1e endif; OutDS.SrcSeq += 10; write PROTOSRC OutDS; endsr; //--------------------------------------------------------- begsr srWriteEndPR; OutDS.SrcCod = ' end-pr;'; OutDS.SrcSeq += 10; write PROTOSRC OutDS; endsr; //--------------------------------------------------------- // Get field attributes from JCRGETFLDR // Extract parm field names and get attributes from loaded arrays. // Generate Rpgle prototype source code in outfile. //--------------------------------------------------------- begsr srRPG; // load global clipboard with field attributes from JCRGETFLDR callp p_JCRGETFLDR( p_SrcFil + p_SrcLib: p_SrcMbr: DiagSeverity: PepCnt); 1b if DiagSeverity > '20'; *inlr = *on; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; exsr srWriteDclPR; 1b if PepCnt > 0; DoParmCnt = 0; //--------------- open JCRGETFLDF; ProcedureEntryPoint = *blanks; 2b dou InputDS.SourceListing = 'S o u r c e L i s t i n g'; read JCRGETFLDF InputDS; 2e enddo; read JCRGETFLDF InputDS; 2b dow not %eof; // do not process compile time arrays 3b if f_IsCompileTimeArray(InputDS.CompileArray) or InputDS.EndOfSource = 'E N D O F S O U R C E'; 2v leave; 3e endif; InputDS = %upper(InputDS); string = %trimr(InputDS.Src94); 3b if not f_IsIgnoreLine(string); // execute function that looks for PI or *entry; 4b if ProcedureEntryPoint = *blanks; ProcedureEntryPoint = f_GetProcedureEntryPoint(InputDS.SpecType: string); 5b if ProcedureEntryPoint = 'NO-PEP'; 2v leave; 5e endif; 4x else; //------------------------------------------------------------- // I let the rpggetfldr program count the number of parms // then read until I load that many field names. //------------------------------------------------------------- aa = f_GetParmFieldsArryIndex(InputDS.SpecType: string); 5b if aa > 0; FieldsAttrDS = FieldsArry(aa).Attr; exsr srWriteDclParm; DoParmCnt += 1; 6b If DoParmCnt = PepCnt; 2v leave; 6e endif; 5e endif; 4e endif; 3e endif; read JCRGETFLDF InputDS; 2e enddo; close JCRGETFLDF; exsr srWriteEndPR; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srWriteDclParm; OutDS.SrcCod = ' *n ' + f_GetDataTypeKeyWords( FieldsAttrDS.DataType: FieldsAttrDS.Length: FieldsAttrDS.DecimalPos); //------------------------------------- // if dim found, get rid of ; add dim statement; 1b if %subst(FieldsAttrDS.Text:1:4) = 'DIM('; bb = %len(%trimr(OutDS.SrcCod)); 2b if bb > 1; %subst(OutDS.SrcCod:bb) = *blanks; OutDS.SrcCod = %trimr(OutDS.SrcCod) + ' ' + %lower( %trimr(FieldsAttrDS.Text)) + ';'; 2e endif; 1e endif; //------------------------------------- OutDS.SrcCod = %trimr( OutDS.SrcCod ) + ' // ' + %lower(FieldsArry(aa).Name); OutDS.SrcSeq += 10; write PROTOSRC OutDS; endsr; //--------------------------------------------------------- // Generate callp prototype from CL. //--------------------------------------------------------- begsr srCL; // return CL entry parms and field attributes 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; PepCnt = FieldsArryCnt; exsr srWriteDclPR; 1b if PepCnt > 0; //--------------------------------------------------------- // Unload imported array mapping differences // between CL definitions and RPG data types // before executing subroutine to write lines. //--------------------------------------------------------- 2b for aa = 1 to FieldsArryCnt; FieldsAttrDS = FieldsArry(aa).Attr; 3b if FieldsAttrDS.DataType = 'C'; FieldsAttrDS.DataType = 'A'; 3x elseif FieldsAttrDS.DataType = 'D'; FieldsAttrDS.DataType = 'P'; 3x elseif FieldsAttrDS.DataType = 'L'; FieldsAttrDS.DataType = 'N'; 3e endif; exsr srWriteDclParm; 2e endfor; exsr srWriteEndPR; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRPRGENV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_IsValidMbr /define f_SrcFileAddPfm /define ApiErrDS /define f_GetQual /define f_SndEscapeMsg /define f_RunCmd // *ENTRY /define p_JCRPRGENR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckObj(p_PgmQual: '*PGM'); f_CheckObj(p_InsertFileQual: '*FILE'); f_CheckMbr(p_SrcFil + p_SrcLib: p_SrcMbr); 1b if f_IsValidMbr(p_InsertFileQual: p_InsertInMbr); // see if source mbr can be allocated, if not send err msg f_RunCmd('ALCOBJ OBJ((' + f_GetQual(p_InsertFileQual) + ' *FILE *EXCLRD ' + %trimr(p_InsertInMbr) + ')) WAIT(1)'); 2b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg('Cannot allocate member ' + %trimr(p_InsertInMbr) + ' in source file ' + f_GetQual(p_InsertFileQual)); 2e endif; f_RunCmd('DLCOBJ OBJ((' + f_GetQual(p_InsertFileQual) + ' *FILE *EXCLRD ' + %trimr(p_InsertInMbr) + '))'); 1x else; f_SrcFileAddPfm(p_InsertFileQual: p_InsertInMbr: ' ': ' ': p_SrcFil + p_SrcLib: p_SrcMbr); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate Prototyped RPGLE') PARM KWD(RPG4MBR) TYPE(*NAME) MIN(1) + PROMPT('Input 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') ]]> .*-------------------------------------------------------------------- :P.Reads RPGLE source and generates new source member with *entry and calls converted to main free format procedure interface and CALLP prototypes. All call opcodes are replaced with CALLP, all parm opcodes are replaced with free prototype syntax. :P.If called program objects are in the library list, this utility will auto-document prototypes with object text. :P.After conversion, 1) may need to change some of prototype definitions due to DSPF files returning Zoned. 2) if fields used as parms are defined in calc specs, then 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='JCRPROTO/RPG4MBR'.Input source mbr - Help :XH3.Input source mbr(RPG4MBR) :P.Member whose source is to be used as input.:EHELP. :HELP NAME='JCRPROTO/RPG4SFL'.Source file - Help :XH3.Source file (RPG4SFL) :P.Source file containing source program.:EHELP. :HELP NAME='JCRPROTO/PROTMBR'.New source member to generate - Help :XH3.New source member to generate (PROTMBR) :P.Member name to be generated by utility. Utility will not replace existing member!:EHELP. :HELP NAME='JCRPROTO/PROTSFL'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRPROTOR - Convert *entry/call parms to prototypes // // read input source to load call and parm information into arrays, // then spins back through the arrays to generate prototype structures and callp. // Source lines with (columns 6 and 7 = blanks and columns 8 to 80 > *blanks) // are free format. Any columns 6 or 7 > *blanks are fixed column. //--------------------------------------------------------- /define ControlStatements /define f_IsIgnoreLine /define ApiErrDS /define FieldsArry /define Constants /define FieldsAttrDS /define f_GetQual /define f_Qusrobjd /define f_SndCompMsg /define f_IsCompileTimeArray /define f_SndEscapeMsg /define f_GetDataTypeKeyWords /define p_JCRGETFLDR // *ENTRY /define p_JCRPROTOR /COPY JCRCMDS,JCRCMDSCPY //------------------------------------------------ // rpgle source member input file //------------------------------------------------ dcl-f InputSrc disk(112) extfile(extIfile) extmbr(p_InMbr) usropn; dcl-ds InputDS len(112) qualified; CompileArry char(3) pos(13); SrcDat zoned(6: 0) pos(7); Src112 char(100) pos(13); Src94 char(94) pos(19); SpecType char(1) pos(18); n01 char(3) pos(21); Factor1 char(14) pos(24); Opcode char(10) pos(38); Opcode5 char(5) pos(38); Factor2 char(14) pos(48); ResFld char(14) Pos(62); end-ds; //------------------------------------------------ // new source member written out with prototyped calls //------------------------------------------------ dcl-f NewSrc disk(112) usage(*output) extfile(extOfile) extmbr(p_OutMbr) usropn; dcl-ds OutDS len(112) inz qualified; SrcSeq zoned(6: 2) pos(1); SrcDat zoned(6: 0) pos(7); SrcOut char(100) pos(13); end-ds; //------------------------------------------------ dcl-s hyphens char(50) inz(*all'-'); dcl-s string varchar(94); dcl-s Factor1 char(14); dcl-s Opcode5 char(5); dcl-s CalledPgmName char(14); dcl-s Pgm10 char(10); dcl-s PepCnt packed(3); dcl-s LoadIndex uns(5); dcl-s s8 char(8); dcl-s xx uns(5); dcl-s ii uns(5); dcl-s ParmCnt uns(5); dcl-s ResultField char(14); dcl-s SaveRrn like(rrn); dcl-s IsCompileArray ind; dcl-s IsWrite ind; dcl-s CallExtender char(3); dcl-s n01 char(3); dcl-s BaseLen uns(3) inz(74); dcl-s IsStackParms ind; dcl-s IsFitOnOneLine ind; dcl-s vstring varchar(112); //------------------------------------------------ // capture the parm information for each call // as it is encoutered in the CALLP write out process. //------------------------------------------------ dcl-ds ThisCall qualified; Type char(5); // PLIST or PGM Name char(14); Plist char(14); Factor1 char(14) dim(255); Factor2 char(14) dim(255); ResFld char(14) dim(255); end-ds; //------------------------------------------------ // Spin through the source first to load up each unique plist and called program // so the *entry procedure interface and call prototypes can be generated //------------------------------------------------ dcl-ds protoDS likeds(ThisCall) dim(1000); //--------------------------------------------------------- // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_InFileQual: p_InMbr: DiagSeverity: PepCnt); 1b if DiagSeverity > '20'; f_SndEscapeMsg('*ERROR* Diagnostic severity ' + DiagSeverity + '. Please check listing for errors.'); 1e endif; extIfile = f_GetQual(p_InFileQual); extOfile = f_GetQual(p_OutFileQual); open InputSrc; open NewSrc; exsr srLoadParmArrays; exsr srWriteCtlOpt; exsr srWritePrototypes; exsr srReplaceCalls; close InputSrc; close NewSrc; f_SndCompMsg('Prototype mbr ' + %trimr(p_OutMbr) + ' generated.'); *inlr = *on; return; //--------------------------------------------- // Write the original source member code to the outfile. // When a CALL is hit, load up ThisCall structure // then generate a CALLP statement replacing the CALL. // Use IsWrite to control not writting PLISTS, PARMS, AND CALLS to new source //--------------------------------------------- begsr srReplaceCalls; IsCompileArray = *off; IsWrite = *on; setll 1 InputSrc; read InputSrc InputDS; 1b dow not %eof; SaveRrn += 1; 2b if not IsCompileArray; 3b if f_IsCompileTimeArray(InputDS.CompileArry); IsCompileArray = *on; 3x else; IsWrite = *on; string = %trimr(InputDS.Src94); 4b if not f_IsIgnoreLine(string) and %upper(InputDS.SpecType) ='C'; Opcode5 = %upper(InputDS.Opcode5); 5b if Opcode5 in %list('CALL(':'CALL'); exsr srLoadUpThisCall; IsWrite = *off; setgt SaveRrn InputSrc; 5x elseif OpCode5 in %list('PLIST':'PARM'); IsWrite = *off; 5e endif; 4e endif; 3e endif; 2e endif; //--------------------------------------------- 2b if IsCompileArray or IsWrite; 3b monitor; OutDS.SrcDat = InputDS.SrcDat; 3x on-error; OutDS.SrcDat = 0; 3e endmon; OutDS.SrcSeq += .01; OutDS.SrcOut = InputDS.Src112; write NewSrc OutDS; 2e endif; read InputSrc InputDS; 1e enddo; endsr; //--------------------------------------------- // load up ThisCall structure then generate a CALLP statement replacing the CALL. // Cannot easily know a structure has ended until // EOF, Another call or plist, a compile time array. O or P specs // The call could have a PLIST. in that case use same array logic // as the dcl-pr code to get the parameter fields. //--------------------------------------------- begsr srLoadUpThisCall; clear ThisCall; // if is a call(e) CallExtender = *blanks; xx = %scan('(':InputDS.OpCode); 1b if xx > 0; CallExtender = %scanrpl(' ':'':(%subst(InputDS.OpCode:xx))); 1e endif; n01 = InputDS.n01; Pgm10 = %scanrpl(qs:'': InputDS.Factor2); Pgm10 = %upper(Pgm10); // plists are easy! Already loaded them to create the dcl-pi 1b if InputDS.ResFld > *blanks; ResultField = %upper(InputDS.ResFld); ii = f_GetProtoDSIndex(aa: ResultField: 'PLIST'); ThisCall = protoDS(ii); exsr srWriteCallp; LV leavesr; 1e endif; //----------------------------------------- // spin through and load up the parms for this call //----------------------------------------- bb = 0; read InputSrc InputDS; 1b dow not %eof; string = %trimr(InputDS.Src94); 2b if not f_IsIgnoreLine(string) and %upper(InputDS.SpecType) ='C'; Opcode5 = %upper(InputDS.Opcode5); 3b if f_IsCompileTimeArray(InputDS.CompileArry) or Opcode5 in %list('CALL ':'CALL(':'PLIST'); exsr srWriteCallp; LV leavesr; 3x elseif Opcode5 = 'PARM'; bb += 1; ThisCall.Factor1(bb) = InputDS.Factor1; ThisCall.Factor2(bb) = InputDS.Factor2; ThisCall.ResFld(bb) = InputDS.ResFld; 3e endif; 2e endif; read InputSrc InputDS; 1e enddo; // if loop terminates without a stop point being found // ie call is last lines in program exsr srWriteCallp; endsr; //--------------------------------------------- // 1. Before CALLP, load factor2 into parms. // 2. Generate CALLP and parm value statements // 3. After CALLP, load parm fields into Factor1 //--------------------------------------------- begsr srWriteCallp; // ThisCall.Factor1 // ThisCall.Factor2 // ThisCall.ResFld ParmCnt = 0; //----------------------------------------- // if call has a conditioning indicator, write wrapper code //----------------------------------------- 1b if n01 > *blanks; 2b if %upper(%subst(n01:1:1)) = 'N'; OutDS.SrcOut = s8 + 'if (not *in' + %subst(n01:2:2) + ');'; 2x else; OutDS.SrcOut = s8 + 'if *in' + %subst(n01:2:2) + ';'; 2e endif; OutDS.SrcSeq += .01; write NewSrc OutDS; 1e endif; //----------------------------------------- // write out calc specs for setting parm = factor 2 //----------------------------------------- 1b for bb = 1 to 255; 2b if ThisCall.ResFld(bb) = *blanks; 1v leave; 2e endif; ParmCnt += 1; 2b if ThisCall.Factor2(bb) > *blanks; OutDS.SrcOut = s8 + %trimr(ThisCall.ResFld(bb)) + ' = ' + %trimr(ThisCall.Factor2(bb)) +';'; OutDS.SrcSeq += .01; write NewSrc OutDS; 2e endif; 1e endfor; //----------------------------------------- // write out callp and parms here //----------------------------------------- OutDS.SrcOut = s8 + 'callp' + %trimr(CallExtender) + ' ' + 'p_' + %trimr(Pgm10) + '('; //----------------------------------------- // Normally parameters are stacked, one to a line for readability. // However, if there are only one or two parameters and the names will fit // on the same line as the callp then I will put those on the same line. // callp p(a: b); //----------------------------------------- IsStackParms = *on; IsFitOnOneLine = *on; 1b if ParmCnt = 0; OutDS.SrcOut = %trimr(OutDS.SrcOut) + ');'; IsStackParms = *off; 1x elseif ParmCnt <= 2; vString = %trimr(ThisCall.ResFld(1)); 2b If ParmCnt = 2; vString += ': ' + %trimr(ThisCall.ResFld(2)); 2e endif; vstring += ');'; 2b if %len(%trimr(OutDS.SrcOut)) + %len(vstring) > 80; IsFitOnOneLine = *off; 2x else; OutDS.SrcOut = %trimr(OutDS.SrcOut) + vstring; IsStackParms = *off; IsFitOnOneLine = *on; 2e endif; 1e endif; 1b if IsFitOnOneLine; OutDS.SrcSeq += .01; write NewSrc OutDS; 1e endif; 1b if IsStackParms; 2b for bb = 1 to ParmCnt; OutDS.SrcOut = s8 + s8 + ' ' + ThisCall.ResFld(bb); 3b if bb = ParmCnt; OutDS.SrcOut = %trimr(OutDS.SrcOut) + ');'; 3x else; OutDS.SrcOut = %trimr(OutDS.SrcOut) + ':'; 3e endif; OutDS.SrcSeq += .01; write NewSrc OutDS; 2e endfor; 1e endif; //----------------------------------------- // write out calc specs for setting factor 1 = parm; //----------------------------------------- 1b for bb = 1 to ParmCnt; 2b if ThisCall.Factor1(bb) > *blanks; OutDS.SrcOut = s8 + %trimr(ThisCall.Factor1(bb)) + ' = ' + %trimr(ThisCall.ResFld(bb)) +';'; OutDS.SrcSeq += .01; write NewSrc OutDS; 2e endif; 1e endfor; //----------------------------------------- // if indicator wrapper, close the logic structure //----------------------------------------- 1b if n01 > *blanks; OutDS.SrcOut = s8 + 'endif;'; OutDS.SrcSeq += .01; write NewSrc OutDS; 1e endif; endsr; //--------------------------------------------- // procedure interface requires default activation group *no. // write some benign control options the user can delete if they wish //--------------------------------------------- begsr srWriteCtlOpt; OutDS.SrcOut = s8 + 'ctl-opt expropts(*resdecpos) option(*nodebugio: *nounref)'; OutDS.SrcSeq += .01; write NewSrc OutDS; OutDS.SrcOut = s8 + 'dftactgrp(*no) actgrp(*caller) datfmt(*iso) timfmt(*iso);'; OutDS.SrcSeq += .01; write NewSrc OutDS; OutDS.SrcOut = *blanks; OutDS.SrcSeq += .01; write NewSrc OutDS; endsr; //--------------------------------------------- // process call arrays into prototypes and any *ENTRY plist //--------------------------------------------- begsr srWritePrototypes; 1b for cc = 1 to aa; 2b if protods(cc).Name = '*ENTRY'; exsr srWriteDclPI; ii = cc; exsr srWriteDclParm; OutDS.SrcOut = s8 + 'end-pi;'; OutDS.SrcSeq += .01; write NewSrc OutDS; //----------------------------------- 2x elseif protods(cc).Type = 'CALL'; exsr srWriteDclPR; ii = cc; exsr srWriteDclParm; OutDS.SrcOut = s8 + 'end-pr;'; OutDS.SrcSeq += .01; write NewSrc OutDS; // OutDS.SrcOut = *blanks; // OutDS.SrcSeq += .01; // write NewSrc OutDS; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- begsr srWriteDclPI; OutDS.SrcOut = s8 + '//-*ENTRY-----------------------------'; OutDS.SrcSeq += .01; write NewSrc OutDS; OutDS.SrcOut = s8 + 'dcl-pi *n; '; OutDS.SrcSeq += .01; write NewSrc OutDS; endsr; //--------------------------------------------------------- // Generate prototype specs for called programs //--------------------------------------------------------- begsr srWriteDclPR; //little work here to extract program name Pgm10 = *blanks; xx = %scan(qs: protods(cc).Name); 1b if xx = 0; //variable program name Pgm10 = 'v_' + protods(cc).Name; OutDS.SrcOut = s8 + '//---variable name--------------------------------------'; 1x else; Pgm10 = %scanrpl(qs:'': protods(cc).Name); Pgm10 = %upper(Pgm10); QusrObjDS = f_QUSROBJD(Pgm10 + '*LIBL':'*PGM'); 2b if ApiErrDS.BytesReturned = 0; QusrObjDS.Text = %trimr(QusrObjDS.Text) + hyphens; 2x else; QusrObjDS.Text = *all'-'; 2e endif; OutDS.SrcOut = s8+ '//---' + QusrObjDS.Text + '-'; 1e endif; OutDS.SrcSeq += .01; write NewSrc OutDS; OutDS.SrcOut = s8 + 'dcl-pr p_' + %trimr(%lower(Pgm10)) + ' extpgm(' + qs + %trimr(Pgm10) + qs + ');'; OutDS.SrcSeq += .01; write NewSrc OutDS; endsr; //--------------------------------------------------------- // if result field plist is used, // get LoadIndex to find PLIST and continue on from there //--------------------------------------------------------- begsr srWriteDclParm; // if call has a plist entry, substitute // start of plist elements 1b if protoDS(ii).Plist > *blanks; ii = f_GetProtoDSIndex(aa: protoDS(cc).Plist: 'PLIST'); 1e endif; 1b for bb = 1 to 255; 2b if protoDS(ii).ResFld(bb) = *blanks; 1v leave; 2e endif; ResultField = %upper( f_RemoveIndex(protoDS(ii).ResFld(bb))); // get field attributes xx = %lookup(ResultField: FieldsArry(*).Name: 1: FieldsArryCnt); 2b if xx = 0; f_SndEscapeMsg('*ERROR* Field definition for ' + %trimr(ResultField) + ' not found.'); 2e endif; FieldsAttrDS = FieldsArry(xx).Attr; 2b if not(protods(ii).Name = '*ENTRY'); OutDS.SrcOut = s8 + ' *n ' + f_GetDataTypeKeyWords( FieldsAttrDS.DataType: FieldsAttrDS.Length: FieldsAttrDS.DecimalPos) + '// ' + %lower(ResultField); 2x else; OutDS.SrcOut = s8 + ' ' + %lower((%trimr(protoDS(ii).ResFld(bb)))) + ' ' + f_GetDataTypeKeyWords( FieldsAttrDS.DataType: FieldsAttrDS.Length: FieldsAttrDS.DecimalPos); 2e endif; OutDS.SrcSeq += .01; write NewSrc OutDS; 1e endfor; endsr; //--------------------------------------------- //--------------------------------------------- begsr srLoadParmArrays; read InputSrc InputDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(InputDS.CompileArry); 1v leave; 2e endif; string = %trimr(InputDS.Src94); 2b if not f_IsIgnoreLine(string) and %upper(InputDS.SpecType) ='C'; // leave original case formatting to be written out Opcode5 = %upper(InputDS.Opcode5); Factor1 = %upper(InputDS.Factor1); 3b if OpCode5 = 'PLIST'; aa += 1; bb = 0; protoDS(aa).Name = Factor1; protoDS(aa).Type = 'PLIST'; protoDS(aa).Plist = *blanks; LoadIndex = 0; 3x elseif Opcode5 in %list('CALL ':'CALL('); CalledPgmName = %upper(InputDS.Factor2); LoadIndex = f_GetProtoDSIndex(aa:CalledPgmName: 'CALL'); 4b if LoadIndex = 0; aa += 1; bb = 0; protoDS(aa).Name = CalledPgmName; protoDS(aa).Plist = %upper(InputDS.ResFld); protoDS(aa).Type = 'CALL'; 4e endif; 3x elseif Opcode5 = 'PARM' and LoadIndex = 0; bb += 1; protoDS(aa).Factor1(bb) = InputDS.Factor1; protoDS(aa).Factor2(bb) = InputDS.Factor2; protoDS(aa).ResFld(bb) = InputDS.ResFld; 3e endif; 2e endif; read InputSrc InputDS; 1e enddo; endsr; //--------------------------------------------- //--------------------------------------------- dcl-proc f_GetProtoDSIndex; dcl-pi *n uns(5); xx uns(5) const; Name char(14) const; Type char(5) const; end-pi; dcl-s yy uns(5); 1b for yy = 1 to xx; 2b if protoDS(yy).Name = Name and protoDS(yy).Type = Type; return yy; 2e endif; 1e endfor; return 0; end-proc; //--------------------------------------------- //--------------------------------------------- dcl-proc f_RemoveIndex; dcl-pi *n char(14); string char(14); end-pi; dcl-s xx uns(3); xx = %scan('(': string); 1b if xx > 0; %subst(string: xx) = *blanks; 1e endif; return string; end-proc; ]]> '); //--------------------------------------------------------- // JCRPROTOV - Validity checking program // note do not allow replacement of existing member //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_IsSameMbr /define f_SndEscapeMsg /define f_SrcFileAddPfm /define f_IsValidMbr /define f_GetQual // *ENTRY /define p_JCRPROTOR /COPY JCRCMDS,JCRCMDSCPY dcl-s InLib char(10); //--------------------------------------------------------- f_CheckMbr(p_InFileQual: p_InMbr); f_CheckObj(p_OutFileQual: '*FILE'); 1b if f_IsSameMbr(p_InFileQual: p_InMbr: p_OutFileQual: p_OutMbr); f_SndEscapeMsg('Input file.lib.mbr cannot + be same as New file.lib.mbr name.'); 1e endif; 1b if f_IsValidMbr(p_OutFileQual: p_OutMbr); f_SndEscapeMsg('Cannot replace existing member ' + %trimr(p_OutMbr) + ' in source file ' + f_GetQual(p_OutFileQual)); 1e endif; f_SrcFileAddPfm(p_OutFileQual: p_OutMbr: ' ': ' ': p_InFileQual: p_InMbr); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate External Print File') PARM KWD(RPGMBR) TYPE(*NAME) MIN(1) PROMPT('RPGLE4 + 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') ]]> .*-------------------------------------------------------------------- :P.Generates DDS external print file source member from RPGLE or SQLRPGLE program's O specs. :P.Please be aware of following special circumstances: :UL COMPACT.:LI.Multiple internal spooled files are consolidated into single member :LI.Array elements are converted but must be modified as these are not allowed in PRTF. :LI.If entire array name (not indexed) is used, it is converted, but will require conversion to non-array name. :LI.Control indicators L0-L9 are converted but will must 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 to put the generated DDS print file member, and whether or not REFFLDs are used in external print file. :NT.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 is 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 are 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. ]]> '); //--------------------------------------------------------- // JCRPRTFR - Generate external print file from RPGLE Ospecs //--------------------------------------------------------- /define ControlStatements /define FieldsArry /define Constants /define FieldsAttrDS /define f_BuildString /define f_BuildEditWord /define f_GetQual /define f_SndCompMsg /define f_SndEscapeMsg /define f_IsCompileTimeArray /define SrcDS /define p_JCRGETFLDR // *ENTRY /define p_JCRPRTFR /COPY JCRCMDS,JCRCMDSCPY dcl-f RPGSRC disk(112) extfile(extifile) extmbr(p_rpgmbr) usropn; dcl-f DDSSRC disk(92) usage(*output) extfile(extofile) extmbr(p_ddsmbr) usropn; dcl-ds OutDS qualified inz; SrcSeq zoned(6:2) pos(1) inz(0); SrcDate zoned(6) pos(7) inz(0); SrcType char(1) pos(18); oAndOr char(1) pos(19); CommentLine char(73) pos(20); Indicator char(9) pos(20); FormatR char(1) pos(29); FormatName char(10) pos(31); Referenced char(1) pos(41); Length char(4) pos(43); DataType char(1) pos(47); DecimalPos char(1) pos(49); LinePosition char(3) pos(54); Keyword char(36) pos(57); end-ds; //--------------------------------------------------------- dcl-s KeywordSkipa like(OutDS.Keyword); dcl-s KeywordSkipb like(OutDS.Keyword); dcl-s KeywordSpacea like(OutDS.Keyword); dcl-s KeywordSpaceb like(OutDS.Keyword); dcl-s LinePosSav like(OutDS.LinePosition); dcl-s oooFMT like(SrcDS.oConstant); dcl-s Commas char(1); dcl-s DDsSrcFile char(10); dcl-s DDsSrcLib char(10); dcl-s tabEditCode char(1) dim(16) ctdata perrcd(1); dcl-s tabEditData char(2) dim(16) alt(tabEditCode); dcl-s Field char(15); dcl-s FloatDollar char(3) inz('''$'''); dcl-s HaveFields char(27); dcl-s JustDidFmt char(27); dcl-s LastExceptName char(15); dcl-s LookupName char(15); dcl-s NegativeType char(1); dcl-s RpgSrcFile char(10); dcl-s RpgSrcLib char(10); dcl-s DimSizeA char(5); dcl-s WriteLine char(1); dcl-s vspos int(5); dcl-s vswork int(5); dcl-s DecimalPos zoned(1); dcl-s CommaRemainder uns(5); dcl-s CommaResult uns(5); dcl-s DetailLineCnt uns(5); dcl-s ExceptLineCnt uns(5); dcl-s HeaderLineCnt uns(5); dcl-s jj uns(5); dcl-s kk uns(5); dcl-s LenActual uns(5); dcl-s NewEndingPos uns(5); dcl-s pe uns(5); dcl-s ps uns(5); dcl-s pStart uns(5); dcl-s TotalLineCnt uns(5); dcl-s xd uns(5); dcl-s xx uns(5); dcl-s yy uns(5); dcl-s IsWrite ind; dcl-s PepCnt packed(3); dcl-s LineCount packed(6: 2) inz(0); //--------------------------------------------------------- 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: PepCnt); 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 SrcDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(SrcDS.CompileArray) or %upper(SrcDS.SpecType) = 'P'; //procedure 1v leave; 2e endif; 2b if SrcDS.Asterisk <> '/' // Eject and %upper(SrcDS.SpecType) = 'O'; // If comment lines, then translate over as is 3b if SrcDS.Asterisk = '*'; //COMMENT LINE OutDS.oAndOr = SrcDS.Asterisk; //LOAD DS OutDS.CommentLine = SrcDS.Commentln; //LOAD DS exsr srWriteSrcCode; 3x else; SrcDS.UpperCase = %upper(SrcDS.UpperCase); 4b if SrcDS.oLineType > *blanks and //IPO LINES D,E,H SrcDS.oAndOr <> 'OR' and //IPO LINES D,E,H SrcDS.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 SrcDS; 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 SrcDS.oLineType = 'E'; //EXCPT 2b if SrcDS.oEname > *blanks and SrcDS.oEname = LastExceptName; //SAME NAMED LINE IsWrite = *off; 2x else; 3b if SrcDS.oEname = *blanks; ExceptLineCnt += 1; SrcDS.oEname = %trimr('EXP') + %triml(%editc(ExceptLineCnt:'3')); 3e endif; OutDS.FormatName = SrcDS.oEname; LastExceptName = SrcDS.oEname; 2e endif; 1x elseif SrcDS.oLineType = 'H'; //HEADER LINE HeaderLineCnt += 1; //HEADER LINE CNT OutDS.FormatName = %trimr('HDR') + %triml(%editc(HeaderLineCnt:'3')); LastExceptName = *blanks; 1x elseif SrcDS.oLineType = 'D'; //DETAIL DetailLineCnt += 1; OutDS.FormatName = %trimr('DTL') + %triml(%editc(DetailLineCnt:'3')); LastExceptName = *blanks; 1x elseif SrcDS.oLineType = 'T'; //TOTAL TotalLineCnt += 1; OutDS.FormatName = %trimr('TOT') + %triml(%editc(TotalLineCnt:'3')); LastExceptName = *blanks; 1e endif; 1b if IsWrite; OutDS.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 SrcDS.oSpaceB > ' '; //SPACE BEFORE KeywordSpaceb = %trimr('SPACEB(') + SrcDS.oSpaceB+')'; 1e endif; 1b if SrcDS.oSkipB > ' '; //SKIP BEFORE KeywordSkipb = %trimr('SKIPB(') + SrcDS.oSkipB + ')'; 1e endif; //--------------------------------------------------------- // Space or Skip after must go at end of each group. // Checked at beginning of each record format. //--------------------------------------------------------- 1b if SrcDS.oSpaceA > ' '; //SPACE AFTER KeywordSpacea = %trimr('SPACEA(') + SrcDS.oSpaceA+')'; 1e endif; 1b if SrcDS.oSkipA > ' '; //SKIP AFTER KeywordSkipa = %trimr('SKIPA(') + SrcDS.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 OutDS.Keyword = KeywordSpaceb; exsr srWriteSrcCode; 1e endif; 1b if KeywordSkipb > *blanks; //SKIP BEFORE OutDS.Keyword = KeywordSkipb; exsr srWriteSrcCode; 1e endif; KeywordSpaceb = *blanks; KeywordSkipb = *blanks; endsr; //--------------------------------------------------------- // Generate Skip or Space after DDs code //--------------------------------------------------------- begsr srSpaceAfter; 1b if KeywordSpacea > *blanks; //SPACE AFTER OutDS.Keyword = KeywordSpacea; exsr srWriteSrcCode; 1e endif; 1b if KeywordSkipa > *blanks; //SKIP AFTER OutDS.Keyword = KeywordSkipa; exsr srWriteSrcCode; 1e endif; KeywordSpacea = *blanks; KeywordSkipa = *blanks; endsr; //--------------------------------------------------------- // Determine whether field name or constant is to be loaded //--------------------------------------------------------- begsr srFieldLine; //IPP SPECS LenActual = 0; HaveFields = 'Record Format has fields'; 1b if SrcDS.oEname > *blanks; //FIELD NAMES WriteLine = 'N'; //SET TO NO Field = SrcDS.oEname; // There could be indexed array name as output field. // Do lookup with array name to get attributes LookupName = SrcDS.oEname; aa = %scan('(': LookupName: 1); 2b if aa <> 0; LookupName = %subst(LookupName: 1: aa - 1); 2e endif; aa = %lookup(LookupName: FieldsArry(*).Name: 1: FieldsArryCnt); 2b if aa > 0; FieldsAttrDS = FieldsArry(aa).Attr; 3b if FieldsAttrDS.DecimalPos = *blanks; DecimalPos = 0; 3x else; DecimalPos = FieldsAttrDS.DecimalPosN; 3e endif; OutDS.FormatName = SrcDS.oEname; //--------------------------------------------------------- // Back to array fun! It could be that // that un-indexed array name was on a O spec. // 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 = SrcDS.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; OutDS.Indicator = SrcDS.oIndicator; //--------------------------------------------------------- // If field was defined via external file definition and // user specified that field references are to be used, // use REFFLD keyword, otherwise hardcode actual field attributes. //--------------------------------------------------------- 3b if FieldsAttrDS.FromFile <> ' ' and //INTERNALLY DESC p_RefFields = '*YES'; //USE REFERENCES OutDS.Referenced = 'R'; OutDS.Keyword = 'REFFLD(' + %trimr(OutDS.FormatName) + ' *LIBL/' + %trimr(FieldsAttrDS.FromFile) + ')'; 3x else; // Hard code fields that are not referenced 4b if FieldsAttrDS.DataType = 'A'; evalr OutDS.Length = %editc(FieldsAttrDS.Length:'4'); clear OutDS.DataType; clear OutDS.DecimalPos; 4x elseif FieldsAttrDS.DataType in %list('D':'T':'Z'); clear OutDS.Length; 5b if FieldsAttrDS.DataType = 'D'; OutDS.DataType = 'L'; 5x else; OutDS.DataType = FieldsAttrDS.DataType; 5e endif; clear OutDS.DecimalPos; 4x else; evalr OutDS.Length = %editc(FieldsAttrDS.Length:'4'); clear OutDS.DataType; OutDS.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 SrcDS.oEditCode > ' '; exsr srAllowForEditCode; 2x elseif SrcDS.oConstant > *blanks; //GET CONST LENGT 3b if FieldsAttrDS.DataType in %list('D':'T':'Z'); exsr srMakeLikeAnEditWord; 3e endif; kk = %checkr(' ': SrcDS.oConstant); LenActual = kk - 2; //CALC LENGTH 2e endif; exsr srBlankOrPlusSign; vswork = vswork - LenActual; vswork += 1; evalr OutDS.LinePosition = %editc(vswork:'4'); // Handle exception of UDATE. Entire line is cleared and // starting Position and new DATE keyword are written. 2b if OutDS.FormatName = 'UDATE'; LinePosSav = OutDS.LinePosition; WriteLine = 'N'; clear OutDS; OutDS.LinePosition = LinePosSav; OutDS.Keyword = 'DATE'; 2e endif; 2b if WriteLine <> 'Y'; exsr srWriteSrcCode; 2e endif; // If floating dollar sign, include in EDTCDE keyword) 2b if SrcDS.oEditCode > ' '; OutDS.Keyword = 'EDTCDE(' + SrcDS.oEditCode + ')'; 3b if SrcDS.oConstant = FloatDollar; OutDS.Keyword = 'EDTCDE(' + SrcDS.oEditCode + ' $)'; 3e endif; exsr srWriteSrcCode; clear WriteLine; 2x elseif SrcDS.oConstant > *blanks; //EDTWRD SPECIFID 3b if FieldsAttrDS.DataType in %list('D':'T':'Z'); OutDS.Keyword = oooFMT; 3x else; OutDS.Keyword = 'EDTWRD(' + %trimr(SrcDS.oConstant) + ')'; 3e endif; exsr srWriteSrcCode; clear WriteLine; 2e endif; 2b if WriteLine = 'Y'; exsr srWriteSrcCode; 2e endif; 1x elseif SrcDS.oConstant > *blanks; //CONSTANTS jj = %checkr(' ': SrcDS.oConstant); OutDS.Indicator = SrcDS.oIndicator; exsr srBlankOrPlusSign; vswork -= jj; vswork += 3; evalr OutDS.LinePosition = %editc(vswork:'4'); //LOAD FLD LENGTH OutDS.Keyword = SrcDS.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 SrcDS.oEndPos = *blanks; SrcDS.oEndPos = ' +0'; 1e endif; bb = %scan('+': SrcDS.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(SrcDS.oEndPos: yy: 1) = ' '; %subst(SrcDS.oEndPos: yy: 1) = '0'; 3e endif; 2e endfor; // Calculate ending positions yy = 2; xx = 0; 2b if SrcDS.oEname <> ' ' and %subst(SrcDS.oConstant: 1: 1) <> ' ' and SrcDS.oConstant <> FloatDollar; 3b dow %subst(SrcDS.oConstant: yy: 1) <> ''''; xx += 1; yy += 1; 3e enddo; 2x elseif SrcDS.oEname = ' ' and %subst(SrcDS.oConstant: 1: 1) <> ' '; 3b dow yy < 29 and %subst(SrcDS.oConstant: yy: 1) <> ''''; xx += 1; yy += 1; 3e enddo; 2e endif; NewEndingPos = vspos + %uns(%subst(SrcDS.oEndPos: bb + 1)) + xx; 2b if xx = 0; //no edit word NewEndingPos += LenActual; 2e endif; SrcDS.oEndPosN = NewEndingPos; 1e endif; vspos = SrcDS.oEndPosN; vswork = vspos; endsr; //--------------------------------------------------------- // New to O specs is ability to format date, time and and timestamp fields. // Build an edit word based on type field and formatting settings. //--------------------------------------------------------- begsr srMakeLikeAnEditWord; clear oooFMT; 1b if FieldsAttrDS.DataType = 'Z'; 1x else; SrcDS.oConstant = %upper(SrcDS.oConstant); 2b if FieldsAttrDS.DataType = 'T'; oooFMT = 'TIMFMT(' + %trimr(SrcDS.oConstant) + ')'; 2x elseif FieldsAttrDS.DataType = 'D'; oooFMT = 'DATFMT(' + %trimr(SrcDS.oConstant) + ')'; 2e endif; 1e endif; SrcDS.oConstant = f_BuildEditWord(SrcDS.oConstant: FieldsAttrDS.DataType); endsr; //--------------------------------------------------------- // Allow for effects of edit codes on overall field length //--------------------------------------------------------- begsr srAllowForEditCode; 1b if SrcDS.oEditCode = 'Y'; 2b if FieldsAttrDS.Length = 3 or FieldsAttrDS.Length = 4; LenActual += 1; 2x elseif FieldsAttrDS.Length in %range(5:9); LenActual += 2; 2e endif; 1x else; 1b if %tlookup(SrcDS.oEditCode: tabEditCode: tabEditData); Commas = %subst(tabEditData: 1: 1); //USE COMMAS? NegativeType = %subst(tabEditData: 2: 1); //WHAT TYPE NEG 3b if SrcDS.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; OutDS.SrcType = 'A'; linecount += .01; OutDS.SrcSeq = linecount; write ddssrc OutDS; clear OutDS; endsr; *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 ]]> '); //--------------------------------------------------------- // JCRPRTFV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_IsValidSrcType /define f_IsSameMbr /define f_SrcFileAddPfm /define f_SndEscapeMsg // *ENTRY /define p_JCRPRTFR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_RpgFileQual: p_RpgMbr:'RPGLE':'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_RpgMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; f_CheckObj(p_DDsFileQual: '*FILE'); 1b if f_IsSameMbr(p_RpgFileQual: p_RpgMbr: p_DDsFileQual: p_DDsMbr); f_SndEscapeMsg('RPGLE file/lib/mbr cannot + be same as DDS file/lib/mbr name.'); 1e endif; f_SrcFileAddPfm(p_DDsFileQual: p_DDsMbr: 'PRTF': 'PRTF for ' + p_RpgMbr); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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) LEN(10) CONSTANT('*CMD') ]]> .*-------------------------------------------------------------------- :P.Easy re-compile a command. The original creation parameters are retrieved and loaded into the CRTCMD (Create Command) prompt for you.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRRECRT/CMD'.CMD - Help :XH3.CMD (CMD) :P.Name and library of command to be selected.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRRECRTR - Recreate *CMD using existing values // Execute function to return command creation string // Prompt CRTCMD command using QCAPCMD command processor API. //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_CrtCmdString /define f_RtvMsgAPI /define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY dcl-s string char(500); dcl-s CompMsg char(73); dcl-s ChangedSrc char(500); dcl-s ChangedLen int(10); dcl-s Replacement char(112); dcl-s ReplaceLib char(10); dcl-s xx uns(3); dcl-s yy uns(3); //Process Commands dcl-pr QCAPCMD extpgm('QCAPCMD'); *n char(500); // source command *n int(10) const; // length of source *n like(cpop0100DS); // options block *n int(10) const; // options block len *n char(8) const; // options format *n char(500); // changed command *n int(10) const; // length available *n int(10); // length of changed *n like(ApiErrDS); end-pr; dcl-ds cpop0100DS qualified; *n int(10) pos(1) inz(0); // command running *n char(1) pos(5) inz('0'); // DBCS handling *n char(1) pos(6) inz('2'); // prompt if ? *n char(1) pos(7) inz('0'); // use system syntax *n char(4) pos(8) inz(x'00000000'); // message key *n int(10) pos(12) inz(0); // xcsid *n char(5) pos(16) inz(x'0000000000'); // reserved end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_CmdQual char(20); p_ObjType char(10); end-pi; //--------------------------------------------------------- // 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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('File Record Format Xref') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('RPG program') 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(CALLING) TYPE(*CHAR) LEN(10) CONSTANT('JCRRFIL') ]]> A*---------------------------------------------------------------- A*%%EC A DSPSIZ(27 132 *DS4) A INDARA A PRINT A CA03 A CA05 A CA07 A CA09 A CA12 A R SBFDTA1 SFL A HIDRCDFMT 10A H A HIDLIBNAM 10A H A HIDFILEEXT 10A H A SBFOPTION 1Y 0B 5 5EDTCDE(4) A SCRFILENAM 10A O 5 7 A SCRLIB 10A O 5 18 A SCRRCDFMT 10A O 5 29 A SCRBASEDPF 10A O 5 40 A SCRRENAMED 10A O 5 51 A SCRUSAGE 1A O 5 63 A SCRAADD 1 O 5 67 A SCRRECTEXT 50A O 5 70 A*---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A*%%TS SD 20220902 144858 DP_RUTLEDG REL-V7R3M0 5770-WDS A SFLSIZ(0060) A SFLPAG(0020) 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'JCRRFIL' A COLOR(BLU) A 1 23'File Record Format Xref' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 64A O 2 7 A 2 72SYSNAME A COLOR(BLU) A SCHEADOPT 65A O 3 5COLOR(BLU) A 3 73'9=CLRPFM' A COLOR(RED) A 4 7'File' A DSPATR(HI) A 4 18'Lib' A DSPATR(HI) A 4 29'RcdFmt' A DSPATR(HI) A 4 40'PF' A DSPATR(HI) A 4 51'Renamed' A DSPATR(HI) A 4 62'Use' A DSPATR(HI) A 4 66'Add' A DSPATR(HI) A 4 70'Text' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A 26 2'F3=Exit' A COLOR(BLU) * 26 15'F5=Refresh' COLOR(BLU) A FOOTMSG07 16A O 26 13COLOR(BLU) A FOOTMSG09 26A O 26 36COLOR(BLU) A 26 69'F12=Cancel' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Displays subfile listing of included Record format names, Renames, Libraries where file is located, and Based-on physicals of all Files used in RPG program.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRRFIL/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Program whose 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. ]]> '); //--------------------------------------------------------- // JCRRFILR - File Record Format xref for RPG source (F spec or dcl-f) // call common file get program JCRGETFILR to extract file names from source // add f9 toggle to show distinct PFs only //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRRFILD workstn sfile(sbfdta1:rrn) infds(infds) indds(ind); /define Infds /define FunctionKeys /define Ind /define psds /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 Constants /define p_JCRGETFILR // *ENTRY /define p_JCRRFILR /COPY JCRCMDS,JCRCMDSCPY dcl-s runfile char(10); dcl-s IsToggle07 ind inz(*off); dcl-s IsToggle09 ind inz(*off); dcl-s IsOk ind inz(*off); dcl-s dbUtility char(8); dcl-s uniquePf char(10) dim(256); dcl-s uu uns(5); //--------------------------------------------------------- scDow = f_GetDayName(); FootMsg07 = 'F7=Sort By Rcdmt'; FootMsg09 = 'F9=Show Unique PFs Only'; 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); // program to load F and dcl-f into element per file record format callp p_JCRGETFILR( p_SrcMbr: p_SrcFilQual: FileCount: OnePerRcdFmt: FspecArry: CommentArry: PrNameArry: DeleteArry); // prep indexes to unload arrays returned from jcrgetfilr bb = 0; aa = 1; 1b dou OnePerRcdFmt(aa).File = *blanks; aa += 1; bb += 1; 1e enddo; //--------------------------------------------------------- f_RmvSflMsg(ProgId); exsr srSort; DbUtility = '2=' + f_GetFileUtil(); scHeadOpt = '1=Field Descriptions ' + %trimr(DbUtility) + ' 3=Record Formats 7=Wrkobj *all'; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; f_RmvSflMsg(ProgId); 2b if (not Ind.sfldsp) or InfdsFkey in %list(f03 :f12); f_SndCompMsg(f_BuildString('JCRRFIL for & in & - completed.': p_SrcMbr: f_GetQual(p_SrcFilQual))); *inlr = *on; return; 2x elseif InfdsFkey = f07; IsToggle07 = (not IsToggle07); 3b if IsToggle07; FootMsg07 = 'F7=Sort By File'; 3x else; FootMsg07 = 'F7=Sort By Rcdmt'; 3e endif; exsr srSort; 2x elseif InfdsFkey = f09; IsToggle09 = (not IsToggle09); 3b if IsToggle09; FootMsg09 = 'F9=Show All'; uniquePf(*) = *blanks; uu = 0; 3x else; FootMsg09 = 'F9=Show Unique PFs Only'; 3e endif; exsr srSort; //--------------------------------------------------------- // Process selected record in subfile. // as a precaution; only process on screen selection options //--------------------------------------------------------- 2x else; readc sbfdta1; 3b dow not %eof; 4b if sbfOption in %list(1:2:3:7:9); 5b if HidFileExt > *blanks; runfile = hidFileExt; 5x else; runfile = ScrFileNam; 5e endif; f_RunOptionFile( sbfOption: runfile: HidLibNam: HidRcdFmt: '*FIRST': ProgId); 4x else; snd-msg 'Option ' + %char(sbfOption) + ' is not available'; 4e endif; sbfOption = 0; update sbfdta1; SflRcdNbr = rrn; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- // load subfile fields from sorted array //--------------------------------------------------------- begsr srSort; SflRcdNbr = 1; rrn = 0; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; 1b if bb > 1; 2b if FootMsg07 = 'F7=Sort By Rcdmt'; sorta %subarr(OnePerRcdFmt(*).File: 1: bb); 2x else; sorta %subarr(OnePerRcdFmt(*).Format: 1: bb); 2e endif; 1e endif; 1b for aa = 1 to bb; 2b if OnePerRcdFmt(aa).File > *blanks; ScrFileNam = OnePerRcdFmt(aa).File; HidLibNam = OnePerRcdFmt(aa).Lib; HidFileExt = OnePerRcdFmt(aa).FileExt; ScrLib = OnePerRcdFmt(aa).Lib; ScrRcdFmt = OnePerRcdFmt(aa).Format; 3b if OnePerRcdFmt(aa).FormatReName = *blanks; ScrRenamed = '.'; 3x else; ScrRenamed = OnePerRcdFmt(aa).FormatReName; 3e endif; 3b if OnePerRcdFmt(aa).BasedOnPF = *blanks; ScrBasedPF = '.'; 3x else; ScrBasedPF = OnePerRcdFmt(aa).BasedOnPF; 3e endif; ScrUsage = OnePerRcdFmt(aa).Usage; ScrAAdd = OnePerRcdFmt(aa).FileAddition; ScrRecText = OnePerRcdFmt(aa).Text; // note: footmsg09 is a toggle switch that is opposite // of current action being taken //----------------------------------------------------- 3b if FootMsg09 = 'F9=Show Unique PFs Only'; IsOk = *on; 3x else; IsOk = *off; 4b if ScrBasedPF <> '.'; ScrFileNam = ScrBasedPF; 4e endif; 4b if uu = 0 or %lookup(ScrFileNam: uniquePf: 1: uu) =0; uu += 1; uniquePf(uu) = ScrFileNam; isOk = *on; 4e endif; 3e endif; 3b if IsOk; rrn += 1; write sbfdta1; 3e endif; 2e endif; 1e endfor; Ind.sfldspctl = *on; Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); snd-msg 'Program uses no external data files.'; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRRFILV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_IsValidSrcType /define f_SndEscapeMsg // *ENTRY /define p_JCRRFILR /COPY JCRCMDS,JCRCMDSCPY //----------------------------------------------------- 1b if not f_IsValidSrcType(p_SrcFilQual: p_SrcMbr: 'RPGLE':'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_SrcMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Fields in RPG Source') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) PROMPT('RPG program') 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 *OUTFILE) + PROMPT('Output') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) + PROMPT('Outfile') OUTFILE: QUAL TYPE(*NAME) LEN(10) 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') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA A CA03 A CA06 A CA12 A R SBFDTA1 SFL A JFLDNAM 27A O 5 5 A JDTATYP 16A O 5 33 A JFLDTXT 24A O 5 50 A JFLDSRC 10A O 5 75 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0170) A SFLPAG(0020) A OVERLAY A BLINK A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR *TOP) A 1 2'JCRRFLD' A COLOR(BLU) A 1 23'Fields in RPG Source' A DSPATR(HI) A SCDOW 9A O 1 64COLOR(BLU) A 1 77DATE A EDTCDE(Y) A COLOR(BLU) A 2 2'Mbr:' A SCOBJHEAD 64A O 2 7 A 2 77SYSNAME A COLOR(BLU) A SCPOSITION 14A I 3 5DSPATR(PC) A 3 20'Position to' A COLOR(BLU) A 4 5'Field Name' A DSPATR(HI) A 4 33'Data Type ' A DSPATR(HI) A 4 50'Text/Qualified/Dim' A DSPATR(HI) A 4 75'File' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY A 26 2'F3=Exit' COLOR(BLU) A 26 17'Enter=Position To' A COLOR(BLU) A 26 50'F6=Print' COLOR(BLU) A 26 75'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRRFLDF; CREATE TABLE JCRRFLDF ( JPGM CHAR(10) NOT NULL DEFAULT '' , JSRCLIB CHAR(10) NOT NULL DEFAULT '' , JSRCFIL CHAR(10) NOT NULL DEFAULT '' , JFLDNAM CHAR(27) NOT NULL DEFAULT '' , JDTATYP CHAR(16) NOT NULL DEFAULT '' , JFLDTXT CHAR(24) NOT NULL DEFAULT '' , JFLDSRC CHAR(10) NOT NULL DEFAULT '' , JDIAGSEV CHAR(2) NOT NULL DEFAULT '' ) RCDFMT JCRRFLDFR ; LABEL ON TABLE JCRRFLDF IS 'Fields in RPG source - outfile jcr' ; LABEL ON COLUMN JCRRFLDF ( JPGM TEXT IS 'Pgm Name' , JSRCLIB TEXT IS 'Source Lib' , JSRCFIL TEXT IS 'Source File' , JFLDNAM TEXT IS 'Field Name' , JDTATYP TEXT IS 'Data Type' , JFLDTXT TEXT IS 'Text' , JFLDSRC TEXT IS 'Defined' , JDIAGSEV TEXT IS 'Severity' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRRFLDF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Displays list of length, attributes, and where-from for all fields in RPGLE program.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRRFLD/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Program whose field lengths to be displayed.:EHELP. :HELP NAME='JCRRFLD/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP NAME='JCRRFLD/OUTPUT'.Output - Help :XH3.OutPut (OUTPUT) :P.Print results, load into outfile or * display.:EHELP. :HELP NAME='JCRRFLD/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRRFLD/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD A SKIPB(1) A SPACEA(1) A 2'JCRRFLD' A 20'Field Attributes in RPG Source' A SCDOW 9A O 70 A 80DATE EDTCDE(Y) A SCSYSTEM 8A 90 A 100'Page' A +1PAGNBR A EDTCDE(4) A SPACEA(1) *--- A 2'Source Member:' A SCOBJHEAD 64A 17 A SPACEA(2) *--- A 3'Text' A 30'Field' A 58'Data Type' A 76'File' *---------------------------------------------------------------- A R PRTDETAIL A SPACEA(1) A JFLDTXT 24A 3 A JFLDNAM 27A 30 A JDTATYP 16A 58 A JFLDSRC 10A 76 ]]> '); //--------------------------------------------------------- // JCRRFLDR - Fields in RPG source // call program to load field names and attributes into imported array //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRRFLDD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind) usropn; dcl-f JCRRFLDP printer oflind(IsOverFlow) usropn; dcl-f JCRRFLDF usage(*output) extfile(extOfile) extmbr(ExtOmbr) usropn; /define Constants /define Infds /define Ind /define psds /define FieldsArry /define FieldsAttrDS /define FunctionKeys /define f_Qusrmbrd /define f_BuildString /define f_DisplayLastSplf /define f_qmhrcvpm /define f_GetQual /define f_GetDataTypeKeyWords /define f_GetDayName /define f_RmvSflMsg /define f_SndCompMsg /define f_OvrPrtf /define f_Dltovr /define p_JCRGETFLDR // *ENTRY /define p_JCRRFLDR /COPY JCRCMDS,JCRCMDSCPY dcl-s vsetll char(15); dcl-s NumberOfRecs uns(5); dcl-s PepCnt packed(3); dcl-s extOmbr char(10); dcl-s unsignedlength uns(10); //--------------------------------------------------------- QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100'); %subst(p_SrcFilQual: 11: 10) = QusrmbrdDS.Lib; scObjHead = f_BuildString('& & & &': p_SrcMbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); //--------------------------------------------------------- // depending on output selection //--------------------------------------------------------- 1b if p_Output = '*'; open JCRRFLDD; 1x elseif p_Output = '*PRINT'; f_OvrPrtf('JCRRFLDP': '*JOB': p_SrcMbr); open JCRRFLDP; write PrtHead; IsOverFlow = *off; 1x elseif p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRRFLDF; jPgm = p_SrcMbr; jSrcFil = QusrmbrdDS.File; jSrcLib = QusrmbrdDS.Lib; 1e endif; //--------------------------------------------------------- // Load JCRCMDSSRV clipboard array with field names and attributes callp p_JCRGETFLDR( p_SrcFilQual: p_SrcMbr: DiagSeverity: PepCnt); //--------------------------------------------------------- f_RmvSflMsg(ProgId); scDow = f_GetDayName(); 1b if p_Output = '*'; // if compile error, show severity as not all fields may have been defined 2b if DiagSeverity > '20'; snd-msg 'Diagnostic severity ' + DiagSeverity + '. Not all fields may be defined. See listing.'; 2e endif; 1e endif; jDiagSev = DiagSeverity; // show in outfile //--------------------------------------------------------- // Pull all entries from imported array to screen fields //--------------------------------------------------------- 1b for NumberOfRecs = 1 to FieldsArryCnt; FieldsAttrDS = FieldsArry(NumberOfRecs).Attr; 2b if not(FieldsAttrDS.Text = '*NOT REFERENCED'); jFldNam = FieldsArry(NumberOfRecs).Name; jFldTxt = FieldsAttrDS.Text; jFldSrc = FieldsAttrDS.FromFile; 3b if jFldTxt = 'CONST'; jDtaTyp = 'const'; jFldTxt = *blanks; 3x else; unsignedlength = %int(FieldsAttrDS.Length); jDtaTyp = %scanrpl(';':' ': f_GetDataTypeKeyWords( FieldsAttrDS.DataType: unsignedlength: FieldsAttrDS.DecimalPos)); 3e endif; //---------------------------- 3b if p_Output = '*'; rrn += 1; write sbfdta1; 3x elseif p_Output = '*PRINT'; write PrtDetail; 4b if IsOverFlow; write PrtHead; IsOverFlow = *off; 4e endif; 3x elseif p_Output = '*OUTFILE'; write JCRRFLDFR; 3e endif; //---------------------------- 2e endif; 1e endfor; //---------------------------- // send printed completion message 1b if p_Output = '*PRINT'; close JCRRFLDP; f_Dltovr('JCRRFLDP'); f_DisplayLastSplf(ProgId: '*PRINT'); *inlr = *on; return; 1x elseif p_Output = '*OUTFILE'; close JCRRFLDF; f_SndCompMsg('File ' +%trimr(extOfile) + ' member ' + %trimr(ExtOmbr) + ' generated by JCRRFLD.'); *inlr = *on; return; 1e endif; //--------------------------------------------------------- // display subfile to user //--------------------------------------------------------- NumberOfRecs = rrn; SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); snd-msg 'No Fields defined in program'; 1e endif; Ind.sfldspctl = *on; 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; 2b if (not Ind.sfldsp) or InfdsFkey in %list(f03 :f12); f_SndCompMsg(f_BuildString('JCRRFLD for & in & - completed.': p_SrcMbr: f_GetQual(p_SrcFilQual))); *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); // print subfile 2b if InfdsFkey = f06; f_OvrPrtf('JCRRFLDP': '*JOB': p_SrcMbr); open JCRRFLDP; write PrtHead; IsOverFlow = *off; 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'); // send printed completion message to message subfile f_DisplayLastSplf(ProgId: '*PRINT'); snd-msg 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(jFldNam: 1: aa); 4b if scPosition <= vsetll or NumberOfRecs = rrn; SflRcdNbr = rrn; 3v leave; 4e endif; 3e endfor; 2e endif; 1e enddo; ]]> '); //--------------------------------------------------------- // JCRRFLDV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_OutFileCrtDupObj // *ENTRY /define p_JCRRFLDR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckMbr(p_SrcFilQual: p_SrcMbr); 1b if p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRRFLDF'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate PRTF DDS from SPLF') PARM KWD(INSERTINTO) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Insert DDS into SrcMbr') PARM KWD(INSERTSRCF) TYPE(SRCFILE) PROMPT('Insert + 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(CPYSPLFPF) TYPE(FTAG) MIN(1) + PROMPT('Cpysplf PF File') FTAG: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') ]]> .*-------------------------------------------------------------------- :P.Generates DDS print file from a CPYSPLF outfile. (JCRSPLF option 9). :NT.Be aware the output is text only (no field names) and is intended only as an aid to help position things in the new PRTF.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRROUGH/INSERTINTO'.Insert DDS into SrcMbr - Help :XH3.Insert Prototype into SrcMbr (INSERTINTO) :P.Member name to be updated with the DDS source code. :P.If the source member does not exists, it is added to source file.:EHELP. :HELP NAME='JCRROUGH/INSERTSRCF'.Source file - Help :XH3.Source file (INSERTSRCF) :P.Source file containing DDS source member to be updated.:EHELP. :HELP NAME='JCRROUGH/CPYSPLFPF'.Cpysplf PF File name - Help :XH3.Cpysplf PF File name (CPYSPLFPF) :P.PF name the spooled file was copied to.:EHELP. :EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRROUGHR- Generate external print file from splf cpy to pf //--------------------------------------------------------- /define ControlStatements /define Constants /define f_GetQual /define f_SndCompMsg /COPY JCRCMDS,JCRCMDSCPY dcl-f CPYSPLF disk(132) extfile(extifile) usropn; dcl-ds inputDS; input char(132); end-ds; dcl-f DDSSRC disk(92) usage(*output) extfile(extofile) extmbr(p_DdsMbr) usropn; dcl-ds OutDS qualified inz; SrcSeq zoned(6:2) pos(1) inz(0); SrcDate zoned(6) pos(7) inz(0); SrcType char(1) pos(18); oAndOr char(1) pos(19); CommentLine char(73) pos(20); Indicator char(9) pos(20); FormatR char(1) pos(29); FormatName char(10) pos(31); Referenced char(1) pos(41); Length char(4) pos(43); DataType char(1) pos(47); DecimalPos char(1) pos(49); LinePosition char(3) pos(54); Keyword char(36) pos(57); end-ds; dcl-s LineCount packed(6: 2) inz(0); dcl-s ExceptLineCnt uns(5); //--*ENTRY------------------------------------------------- dcl-pi *n; p_DdsMbr char(10); p_DdsFileQual char(20); p_CpySplfPFQual char(20); end-pi; //--------------------------------------------------------- extIfile = f_GetQual(p_CpySplfPFQual); extOfile = f_GetQual(p_DdsFileQual); // open input file and output open CPYSPLF; open DDSSRC; read CPYSPLF inputDS; 1b dow not %eof; exsr srFormatLine; exsr srFieldLine; exsr srSpaceAfter; read CPYSPLF inputDS; 1e enddo; // all processed close CPYSPLF; close DDSSRC; f_SndCompMsg('JCRROUGH 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; ExceptLineCnt += 1; OutDS.FormatName = 'LINE' + %triml(%editc(ExceptLineCnt:'3')); OutDS.FormatR = 'R'; exsr srWriteSrcCode; endsr; //--------------------------------------------------------- // use check to find start of string and scan to find end //--------------------------------------------------------- begsr srFieldLine; 1b for aa = 1 to 132; 2b if %subst(Input:aa:1) > *blanks; bb = %scan(' ':Input: aa); 3b if bb = 0; bb = 133; 3e endif; evalr OutDS.LinePosition = %char(aa); OutDS.Keyword = qs + %subst(Input:aa: (bb - aa)) + qs; exsr srWriteSrcCode; aa = bb; 2e endif; 1e endfor; endsr; //--------------------------------------------------------- // Generate Skip or Space after DDS code //--------------------------------------------------------- begsr srSpaceAfter; OutDS.Keyword = 'SPACEA(1)'; exsr srWriteSrcCode; endsr; //--------------------------------------------------------- // Write records to DDS member //--------------------------------------------------------- begsr srWriteSrcCode; OutDS.SrcType = 'A'; linecount += .01; OutDS.SrcSeq = linecount; write ddssrc OutDS; clear OutDS; endsr; ]]> '); //--------------------------------------------------------- // JCRROUGHV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_IsValidMbr /define f_SrcFileAddPfm /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_DdsMbr char(10); p_DdsFileQual char(20); p_CpySplfPFQual char(20); end-pi; //--------------------------------------------------------- f_CheckObj(p_CpySplfPFQual: '*FILE'); f_CheckObj(p_DdsFileQual: '*FILE'); 1b if not f_IsValidMbr(p_DdsFileQual: p_DdsMbr); f_SrcFileAddPfm(p_DdsFileQual: p_DdsMbr: 'PRTF': 'jcrrough'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Retrieve RPGLE Source') PARM KWD(RPGOBJECT) TYPE(RPGOBJECT) MIN(1) + PROMPT('Object compiled *LIST or *ALL') RPGOBJECT: QUAL TYPE(*NAME) LEN(10) 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') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&OBJQUAL &SMBR &SFILEQUAL) DCL VAR(&OBJQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&SMBR) TYPE(*CHAR) LEN(10) DCL VAR(&OBJ) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&OBJQUAL 1) DCL VAR(&OLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&OBJQUAL 11) DCL VAR(&SFILEQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&SFIL) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&SFILEQUAL 1) DCL VAR(&SLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&SFILEQUAL 11) CLRLIB LIB(QTEMP) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('Dump + system object - in progress') + TOPGMQ(*EXT) MSGTYPE(*STATUS) OVRPRTF FILE(QPSRVDMP) PRTTXT(*BLANK) 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/&SFIL) MBR(&SMBR) + 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 &SMBR + *TCAT ' in ' *CAT &SLIB *TCAT '/' *CAT + &SFIL *TCAT ' - completed') ENDPGM ]]> .*-------------------------------------------------------------------- :P.Retrieves the source member for RPGLE object compiled with DBGVIEW *LIST or *ALL. :P.One weird circumstance: If retrieving fixed column program (not free) and program has F specs, utility will not retrieve first C spec and may 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 for programs compiled since v5r1 to v7r2.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRRTVRPG/RPGOBJECT'.Object compiled *LIST or *ALL - Help :XH3.Object compiled *LIST or *ALL (RPGOBJECT) :P.RPGLE program object 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 is overlaid.:EHELP. :HELP NAME='JCRRTVRPG/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Name of source file will contains RPGLE member.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRRTVRPGR - Retrieve RPGLE source from compiled object // The DMPOBJ command only works for programs compiled *LIST or *ALL!! // Weird: if retrieving fixed format program (not free) and program has F specs. // The DMPOBJ will not retrieve first C spec and may have to delete last line in // generated code. // Due to this utility using object dump file, it is OS version // sensitive. Meaning IBM has been known to change format of dumps on different release // levels. This version works for programs compiled v5r1 to v7r2. //--------------------------------------------------------- /define ControlStatements /define f_Quscrtus /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRRTVRPG disk(132); dcl-ds inputDS len(132); Asterisk char(1) pos(87); DumpText char(32) pos(88); end-ds; dcl-f RPGSRC disk(112) usage(*output); dcl-ds OutDS; SrcSeq zoned(6:2) pos(1) inz(0); SrcChgdat zoned(6:0) pos(7) inz(0); OutData char(95) pos(18); end-ds; //--------------------------------------------------------- dcl-s BasedField like(dumptext) based(xPtr); dcl-s BasedFieldv6 like(StartTextv6) based(xPtr); dcl-s BasedFieldV7 like(StartTextV7) based(xPtr); dcl-s BasedSrc char(95) based(xPtr); dcl-s Check1st6 char(6) based(Ptr1); dcl-s Check2nd5 char(5) based(Ptr2); dcl-s Check3rd6 char(6) based(Ptr3); dcl-s StartTextv6 char(5) INZ('DBGV-'); dcl-s StartTextV7 char(13) INZ('*MODULE ENTRY'); dcl-s ScanCount uns(10); dcl-s SizeOfSpace uns(10); dcl-s xCount uns(3); dcl-s StartOfUserSpacePtr pointer inz(*null); dcl-s IsFound ind; //--------------------------------------------------------- // Create user space StartOfUserSpacePtr = f_Quscrtus(UserSpaceName); // Load blocks of dump data into user space so entire dump is in single long string xPtr = StartOfUserSpacePtr; read JCRRTVRPG inputDS; 1b dow not %eof; 2b if Asterisk = '*'; BasedField = DumpText; xPtr += %len(DumpText); SizeOfSpace += %len(DumpText); 2e endif; read JCRRTVRPG inputDS; 1e enddo; //--------------------------------------------------------- // Find source start //--------------------------------------------------------- ScanCount = 1; IsFound = *off; xPtr = StartOfUserSpacePtr; 1b dou ScanCount > SizeOfSpace; 2b if BasedFieldV7 = StartTextV7 or BasedFieldV6 = StartTextV6; IsFound = *on; 1v leave; 2e endif; xPtr += 1; ScanCount += 1; 1e enddo; 1b if BasedFieldV7 = StartTextV7; xPtr += 3; 1e endif; // Start writing records to source member 1b if IsFound; xPtr += 47; ScanCount += 47; 2b dou ScanCount > SizeOfSpace; OutData = BasedSrc; //--------------------------------------------------------- // For inexplicable reasons, 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) = *blanks; 4e endif; 4b if %subst(OutData: 68: 2) = '--'; %subst(OutData: 68: 2) = *blanks; 4e endif; 4b if %subst(OutData: 70: 2) = '--'; %subst(OutData: 70: 2) = *blanks; 4e endif; 3e endif; 3b if not(%subst(OutData: 1: 19) = 'MAIN PROCEDURE EXIT'); SrcSeq += .01; SrcChgdat = 0; write RPGSRC outDS; 3e endif; xPtr += 30; ScanCount += 30; //--------------------------------------------------------- // After 1st source record, everything is random // located. Only true indication of source record // beginning is location of date and sequence numbers. // Spin until finding 6 digits, 5 spaces, then 6 more digits. // At this point it is 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; ]]> '); //--------------------------------------------------------- // JCRRTVRPGV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_CheckObj /define f_SrcFileAddPfm /define f_RtvMsgAPI /define f_SndEscapeMsg /define f_Qusrobjd /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_SrcMbr char(10); p_SrcQual char(20); end-pi; //--------------------------------------------------------- f_CheckObj(p_ObjQual: '*PGM'); f_CheckObj(p_SrcQual: '*FILE'); QusrObjDS = f_QUSROBJD(p_ObjQual: '*PGM'); 1b if not (QusrObjDS.ExtendedAttr in %list('RPGLE':'SQLRPGLE')); f_SndEscapeMsg('Program type ' + %trimr(QusrObjDS.ExtendedAttr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; //--------------------------------------------------------- f_SrcFileAddPfm(p_SrcQual: p_SrcMbr: 'RPGLE': 'Source recovered by JCRRTVRPG - ' +%trimr(%subst(p_ObjQual:1:10))); 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; ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD A 1'JCRSBSDR' A SKIPB( 1) A 20'List Subsystem Pool ID:' A SYSTEMNAME 8 44 A SCDOW 9 70 A 80DATE A EDTCDE(Y) A SCSYSTEM 8A 90 A 100'Page' A PAGE1 4 0 +1 A SPACEA(1) A 132'.' A SPACEA(1) A 1'Subsystem' A 24'Routing Entry PoolID' A 54'Pools' A SPACEA(1) A R PRTDETAIL A A21 21 1 A PRTROUTING 30 23 A PRTPOOLS 75 54 A SPACEA(1) ]]> '); //--------------------------------------------------------- // JCRSBSDR - List subsystem pools and routing ids //--------------------------------------------------------- /define ControlStatements /define psds /define Constants /define ApiErrDS /define f_DisplayLastSplf /define f_Quscrtus /define f_GetDayName /define Qwcrneta /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRSBSDP printer oflind(IsOverFlow) usropn; dcl-s SBSArry char(20) dim(250); dcl-s a21 char(21); dcl-s PrtPools char(75); dcl-s PrtRouting char(30); dcl-s QualSbsName char(20); dcl-s RoutingExtract char(3); dcl-s SystemName char(8); dcl-s RoutingArry int(10) dim(50) ascend; dcl-s scDow char(9); dcl-s zz uns(10); // List Active Subsystems dcl-pr Qwclasbs extpgm('QWCLASBS'); *n char(20); // Space Name and Lib *n char(8) const; // Api Format *n like(ApiErrDS); end-pr; dcl-ds QwclasbsDS qualified based(QwclasbsPtr); QualSbsName char(20) pos(1); end-ds; // Retrieve Subsystem Information dcl-pr Qwdrsbsd extpgm('QWDRSBSD'); *n char(500); // Receiver *n int(10) const; // Length *n char(8) const; // Api Format *n char(20); // Subsystem Name *n like(ApiErrDS); end-pr; dcl-ds QwdrsbsdDS len(500) qualified; NumberOfPools int(10) pos(77); end-ds; dcl-ds PoolExtractDS qualified based(PoolExtractPtr); PoolNumber int(10); PoolName char(10); end-ds; // List Subsystem Entries dcl-pr Qwdlsbse extpgm('QWDLSBSE'); *n char(20); // User Space and Lib *n char(8) const; // Api Format *n char(20); // Qualified Sbs Name *n like(ApiErrDS); end-pr; // routing entries dcl-ds QwdlsbseDS qualified based(QwdlsbsePtr); RoutingEntry int(10) pos(49); end-ds; // load print string dcl-ds PoolPrintDS len(15) qualified; PoolNumber char(2) pos(1); PoolName char(11) pos(4); end-ds; //--------------------------------------------------------- open JCRSBSDP; scDow = f_GetDayName(); // retrieve Network attributes to get sys name callp QWCRNETA( QwcrnetaDS: %size(QwcrnetaDS): 1: 'SYSNAME': ApiErrDS); NetWorkInfoPtr = %addr(QwcrnetaDS) + QwcrnetaDS.TableOffset; SystemName = NetworkInfoDS.LocalSysName; write PrtHead; IsOverFlow = *off; //load active subsystem names to user space then to array ApiHeadPtr = f_QUSCRTUS(UserSpaceName); callp QWCLASBS(UserSpaceName: 'SBSL0100': ApiErrDS); QwclasbsPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; SBSArry(ForCount) = QwclasbsDS.QualSbsName; QwclasbsPtr += ApiHead.ListEntrySize; 1e endfor; sorta %subarr(SBSArry: 1: ApiHead.ListEntryCount); //--------------------------------------------------------- // Spin though subsystems and load pools and routing entries //--------------------------------------------------------- 1b for-each QualSbsName in %subarr(SBSArry:1:ApiHead.ListEntryCount); // Get POOL id number and names. Load up to 5 entries callp QWDRSBSD( QwdrsbsdDS: %len(QwdrsbsdDS): 'SBSI0100': QualSbsName: ApiErrDS); PoolExtractPtr = %addr(QwdrsbsdDS) + 80; PrtPools = *blanks; aa = 1; 2b for zz = 1 to QwdrsbsdDS.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. Only want to show one. // Use array to lookup and see if entry is used yet. //--------------------------------------------------------- aa = 0; RoutingArry(*) = 0; PrtRouting = *all'- '; QwdlsbsePtr = ApiHeadPtr + ApiHead.OffSetToList; 2b for ForCount2 = 1 to ApiHead.ListEntryCount; 3b if aa = 0 or %lookup(QwdlsbseDS.RoutingEntry: RoutingArry: 1: aa) = 0; aa += 1; RoutingArry(aa) = QwdlsbseDS.RoutingEntry; 3e endif; QwdlsbsePtr += ApiHead.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); write PrtDetail; 1e endfor; close JCRSBSDP; f_DisplayLastSplf('JCRSBSDR': '*'); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Search/Copy Job Schedule Entry') PARM KWD(JOB) TYPE(*CHAR) LEN(10) SPCVAL((*ALL)) + CHOICE('Preceding * = Contains') + PROMPT('Job Name') PARM KWD(CMD) TYPE(*CHAR) LEN(20) SPCVAL((*ALL)) + CHOICE(CONTAINS) PROMPT('Cmd Contains:') PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) + DFT(*) VALUES(* *PRINT *OUTFILE) + PROMPT('Output') PARM KWD(OUTQ) TYPE(OUTQ) PMTCTL(PMTCTL2) + PROMPT('Outq') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(*JOB) SPCVAL((*JOB + *JOB)) QUAL TYPE(*NAME) LEN(10) SPCVAL((*LIBL)) + PROMPT('Library') /*------------------------------------------------------*/ PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) + PROMPT('Outfile') OUTFILE: QUAL TYPE(*NAME) LEN(10) 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) PMTCTL2: PMTCTL CTL(OUTPUT) COND((*EQ '*PRINT')) NBRTRUE(*EQ 1) ]]> A*---------------------------------------------------------------- A*%%EC A DSPSIZ(27 132 *DS4) A CA03 A CA05 A CA06 A CA07 A CA10 A CA12 A INDARA A PRINT *---------------------------------------------------------------- * save command parms if user selects to copy A R SBFDTA1 SFL A SENTRYNBR 10A H A SCMD 512A H A SFRQ 10A H A SSCDDATE 10A H A SSCDDAY 70A H A SSCDTIME 8A H A SOMITDATE 200A H A SRCYACN 10A H A SJOBD 21A H A SJOBQ 21A H A SMSGQ 21A H A STEXT 50A H *--------------------------------------------- A AOPTIONS1 1A P A SBFOPTION 1A B 6 2DSPATR(&AOPTIONS1) A SBJOB 10A O 6 5 A SBSTAT 3A O 6 16 A SBSDATE 10A O 6 20 A SBSTIME 8A O 6 31 A SBFREQ 10A O 6 40 A SBUSER 10A O 6 51 A SBJOBDL 10 O 6 62 A SBCMD 58A O 6 73 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0361) A SFLPAG(0019) A CHANGE(23) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 3'JCRSCDE' A COLOR(BLU) A 1 19'Search Job Schedule Entries with C- A opy option' A DSPATR(HI) A DSPATR(UL) A SCDOW 9A O 1110COLOR(BLU) A 1120DATE A EDTCDE(Y) A COLOR(BLU) A 2 16'HLD SCD SAV' A COLOR(BLU) A 2 51'*DISABLED' A COLOR(BLU) A 2 63'Search values' A COLOR(BLU) A 2110SYSNAME A COLOR(BLU) A 3 2'C=Copy Prompt' A COLOR(BLU) A 3 18'5=Work with Job Schedule Entry' A COLOR(BLU) A 3 51'*NOT FOUND' A COLOR(BLU) A 3 63'(leading space = contains)' A SCJOB 10A B 4 5CHANGE(12) A SCSTAT 3A B 4 16CHANGE(12) A 4 20'Schedule' A DSPATR(HI) A SCUSER 10A B 4 51CHANGE(12) A SCJOBDL 10 B 4 62CHANGE(12) A SCCMD 58A B 4 73CHANGE(12) A 5 1'Opt' A DSPATR(HI) A 5 5'Job' A DSPATR(HI) A 5 15'Stat' A DSPATR(HI) A 5 20'Date' A DSPATR(HI) A 5 31'Time' A DSPATR(HI) A 5 40'Frequency' A DSPATR(HI) A 5 51'User' A DSPATR(HI) A 5 62'Jobd Lib' A DSPATR(HI) A 5 73'Command' A DSPATR(HI) A*---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A BLINK A 26 2'F3=Exit' A COLOR(BLU) A 26 20'F5=Refresh' A COLOR(BLU) A 26 40'F6=Dspjoblog' A COLOR(BLU) A 26 58'F7=Sort By Time' A COLOR(BLU) A 26 80'F12=Cancel' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRSCDEF; CREATE TABLE JCRSCDEF ( SBJOB CHAR(10), SBSTAT CHAR(3), SBSDATE CHAR(10), SBSTIME CHAR(8), SBFREQ CHAR(10), SBUSER CHAR(10), SENTRYNBR CHAR(10), SCMD CHAR(512), SSCDDATE CHAR(10), SSCDDAY CHAR(70), SSCDTIME CHAR(8), SOMITDATE CHAR(200), SRCYACN CHAR(10), SJOBD CHAR(21), SJOBQ CHAR(21), SMSGQ CHAR(21), STEXT CHAR(50) ) RCDFMT JCRSCDEFR ; LABEL ON TABLE JCRSCDEF IS 'Search Job Schedule Entries jcr' ; LABEL ON COLUMN JCRSCDEF ( SBJOB TEXT IS 'Job Name', SBSTAT TEXT IS 'Status' , SBSDATE TEXT IS 'Date' , SBSTIME TEXT IS 'Time' , SBFREQ TEXT IS 'Frequency', SBUSER TEXT IS 'User' , SENTRYNBR TEXT IS 'EntryNum' , SCMD TEXT IS 'Command' , SSCDDATE TEXT IS 'Sched Date', SSCDDAY TEXT IS 'Sched Day', SSCDTIME TEXT IS 'Sched Time', SOMITDATE TEXT IS 'Omit Date', SRCYACN TEXT IS 'Recovery' , SJOBD TEXT IS 'Jodb' , SJOBQ TEXT IS 'Jobq' , SMSGQ TEXT IS 'Msgq' , STEXT TEXT IS 'Text' ); GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRSCDEF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Much needed CPYJOBSCDE utility. Will search through executed commands for selected string.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRSCDE/JOB'. Job - Help :XH3.Job (JOB) :P.Specifies Job name filter to pull list of job schedule entries. An asterisk * before the job name, filters names containing your selection. :PARML. :PT.:PK def.*ALL:EPK. :PD.Retrieves all job schedule entries. :EPARML. :EHELP. :HELP NAME='JCRSCDE/OUTPUT'.Output - Help :XH3.Output (OUTPUT) :P.Output to print file or data file. :PARML.:PT.:PK def.*:EPK.:PD.Show interactive selection screen. :PT.*OUTFILE :PD.Output is redirected to selected data file. (see OUTFILE help). :PT.*PRINT:PD.Generate report listing of screen.:EPARML.:EHELP. :HELP NAME='JCRSCDE/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRSCDE/OUTMBR'.Output - Help :XH3.Output (OUTMBR) :P.File member to receive command output. note: outfile is SQL DDL and does not allow multiple members.:EHELP. :HELP NAME='JCRSCDE/OUTQ'.Outq name - Help :XH3.Outq name (OUTQ) :P.Name and library of output queue to place the spooled file.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- A R PRTHEAD1 SKIPB(1) A 3'JCRSCDE' A 19'Search Job Schedule Entries' A SCSYSTEM 8A 100 A SCDOW 9A 110 A 120DATE A EDTCDE(Y) A SPACEA(2) A 16'HLD SCD SAV' A 63'Search values' A SPACEA(2) A SCSTAT 3A 16 A 20'Schedule' A SCUSER 10A 51 A SCCMD 58A 63 A SPACEA(2) A 5'Job' A 15'Stat' A 20'Date' A 31'Time' A 40'Frequency' A 51'User' A 63'Command' A SPACEA(1) *---------------------------------- A R PRTDETAIL SPACEA(1) A SBJOB 10A 5 A SBSTAT 3A 16 A SBSDATE 10A 20 A SBSTIME 8A 31 A SBFREQ 10A 40 A SBUSER 10A 51 A SBCMD 58A 63 *---------------------------------- A R PRTEOR A 2'End Of Report' ]]> '); //--------------------------------------------------------- // JCRSCDER - Search/Copy Job Schedule Entries // call qwclscde API to load list of job schedule entries // allow search through the list and then provide a copy options // Note: the qwclscde api returns all job schedule entries // but can require multiple calls with a continuation handle. (strange api) // said all that to say my normal method of searching through the user space // will not work in this circumstance. I have to call the API multiple // times and filter the entries as records are written to the subfile. // added user profile and show if user profile *NOT FOUND or *DISABLED // added print and outfile selections // // 08/15/22 add f7 sort by time //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRSCDED workstn sfile(sbfdta1: rrn1) usropn infds(infds) indds(ind); dcl-f JCRSCDEF usage(*output) extfile(extofile) extmbr(extombr) usropn; dcl-f JCRSCDEP printer oflind(IsOverFlow) usropn; /define FunctionKeys /define Ind /define Infds /define ApiErrDS /define Constants /define Dspatr /define psds /define f_BuildString /define f_GetQual /define f_Quscrtus /define f_RunCmd /define f_RmvSflMsg /define f_GetDayName /define ListAuthorizedUsers /define f_OvrPrtf /define f_Dltovr // *ENTRY /define p_JCRSCDER /COPY JCRCMDS,JCRCMDSCPY dcl-s extOmbr char(10); dcl-s ContinuationHandle char(16); dcl-s p_Entry char(10) inz('*ALL'); dcl-s rrn1 uns(5); dcl-s IsOk1 ind; dcl-s IsOk2 ind; dcl-s IsOk3 ind; dcl-s IsOk4 ind; dcl-s IsOk5 ind; dcl-s IsSelected ind; dcl-s lenscan uns(3); dcl-s string1 char(1024); dcl-s cvtdate char(16); dcl-s yymmdd char(16); // command field has a length parameter. I do not not want to search // past the end of the field, so substring commandstring into this field dcl-s upcase varchar(512); dcl-pr QWCLSCDE extpgm('QWCLSCDE'); // list job schedule entries *n char(20); // user space *n char(8) const; // api format *n char(10); // entry *n char(16); // continuation handle *n like(apierrds); end-pr; dcl-pr Qwccvtdt extpgm('QWCCVTDT'); // api date converter *n char(10) const; // from format *n char(8); // api date stamp *n char(10) const; // to format *n char(16); // to date *n like(apierrds); end-pr; dcl-ds qwclscdeDS qualified based(qwclscdeptr); InformationStatus char(1); Job char(10) pos(2); EntryNumber char(10) pos(12); ScheduledDate char(10) pos(22); ScheduledDays char(10) dim(7) pos(32); ScheduledTime char(6) pos(102); Frequency char(10) pos(108); RelativeDayOfTheMonth char(10) dim(5) pos(118); RecoveryAction char(10) pos(168); NextSubmissionDate char(10) pos(178); Status char(10) pos(188); Jobq char(10) pos(198); JobqLib char(10) pos(208); UserProfileOfEntryAdder char(10) pos(218); LastSubmissionDate char(10) pos(228); LastSubmissionTime char(6) pos(238); Text char(50) pos(244); Reserved1 char(23) pos(294); JobqStatus char(10) pos(317); DatesOmitted char(10) dim(20) pos(327); Jobd char(10) pos(527); JobdLib char(10) pos(537); UserProfileForSubmittedJob char(10) pos(547); Msgq char(10) pos(557); MsgqLib char(10) pos(567); SaveEntry char(10) pos(577); LastSubmissionJob char(10) pos(587); LastSubmissionUser char(10) pos(597); LastSubmissionJobNumber char(6) pos(607); LastAttemptedSubmissionDate char(10) pos(613); LastAttemptedSubmissionTime char(6) pos(623); StatusLastAttemptedSubmission char(10) pos(629); Reserved2 char(2) pos(639); LengthOfCommand int(10) pos(641); Command char(512) pos(645); end-ds; // ScreenFieldDS - load screen fields into sort array dcl-ds SortArry likeds(ScreenFieldDS) dim(9999); dcl-ds ScreenFieldDS; SENTRYNBR; SCMD ; SFRQ ; SSCDDATE ; SSCDDAY ; SSCDTIME ; SOMITDATE; SRCYACN ; SJOBD ; SJOBQ ; SMSGQ ; STEXT ; //-------------------------------------------- AOPTIONS1; SBFOPTION; SBJOB ; SBSTAT ; SBSDATE ; SBSTIME ; SBFREQ ; SBUSER ; SBJOBDL ; SBCMD ; end-ds; //--------------------------------------------------------- 1b if p_Output = '*PRINT'; f_OvrPrtf('JCRSCDEP': p_OutqQual: 'JCRSCDER'); open JCRSCDEP; write PrtHead1; isOverFlow = *off; 2b if p_jobname = *blanks; p_jobname = '$'; // load all 2e endif; 1x elseif p_Output = '*OUTFILE'; extOmbr = %subst(p_OutMbrOpt: 3: 10); extOfile = f_GetQual(p_OutFileQual); open JCRSCDEF; 2b if p_jobname = *blanks; p_jobname = '$'; // load all 2e endif; 1x elseif p_Output = '* '; open JCRSCDED; 1e endif; // prep parm for space instead of * wildcards 1b if p_jobname > *blanks and p_jobname <> '*ALL'; p_jobname = %xlate('*':' ':p_jobname); 1e endif; scJob = p_jobname; scCmd = ' ' + p_cmd; scDow = f_GetDayname(); ApiHeadPtr = f_Quscrtus(UserSpaceName); exsr srRefreshScreen; sflrcdnbr = 1; 1b if p_Output = '*PRINT'; write PrtEor; // end of report close JCRSCDEP; f_dltovr('JCRSCDEP'); *inlr = *on; return; 1x elseif p_Output = '*OUTFILE'; close JCRSCDEF; *inlr = *on; return; 1e endif; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; Ind.sfldspctl = *on; Ind.sfldsp = (rrn1 > 0); write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); close JCRSCDED; return; 2e endif; f_RmvSflMsg(ProgId); // refresh SflRcdNbr = InfdsSflRcdNbr; 2b if InfdsFkey = f05; scJob = *blanks; scstat = *blanks; scCmd = *blanks; scUser = *blanks; scJobdL = *blanks; exsr srRefreshScreen; 2x elseif InfdsFkey = f06; f_RunCmd('DSPJOBLOG'); //----------------------------------------- // sort by time before loading subfile 2x elseif infdsFkey =f07 and rrn1>0; aa=rrn1; 3b for bb=1 to aa; chain bb sbfdta1; SortArry(bb) = ScreenFieldDS ; 3e endfor; sorta %subarr(sortarry:1:aa) %fields(SBSTIME); Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn1 = 0; sflrcdnbr = 1; 3b for bb=1 to aa; rrn1+=1; ScreenFieldDS = SortArry(rrn1); write sbfdta1; 3e endfor; //----------------------------------------- 2x elseif ind.IsChange; exsr srRefreshScreen; 2x elseif Ind.sfldsp; // process user requests readc sbfdta1; 3b dow not %eof; 4b if sbfOption > ' '; 5b if sbfOption = 'C'; // copy entry string1= f_BuildString(' + ?ADDJOBSCDE + JOB(&) + FRQ(&) + SCDDATE(&) + SCDDAY(&) + SCDTIME(&) + RCYACN(&) + JOBD(&) + JOBQ(&) + USER(&) + MSGQ(&) + TEXT(&)': sbjob: sFRQ: sSCDDATE: sSCDDAY: sSCDTIME: sRCYACN: sJOBD: sJOBQ: sBUSER: sMSGQ: sTEXT); //----------------------------------------------------- // command and omit dates are too long for build string // if happens again, change build string //----------------------------------------------------- string1 = %trimr(string1) + ' CMD(' + %trimr(scmd) + ') OMITDATE('+ %trim(SOMITDATE) + ')'; f_RunCmd(string1); 6b if ApiErrDS.BytesReturned > 0; snd-msg 'Job Schedule Entry not copied - check joblog'; 6e endif; 5x elseif sbfOption = '5'; f_RunCmd('WRKJOBSCDE JOB('+ sbjob + ')'); 5e endif; // update subfile to reflect change aoptions1 = %bitor(Green:UL); clear sbfOption; update sbfdta1; SflRcdNbr = rrn1; 4e endif; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- begsr srRefreshScreen; 1b if p_Output = '* '; Ind.sfldsp = *off; Ind.sfldspctl = *off; write sbfctl1; rrn1 = 0; sflrcdnbr = 1; 1e endif; ContinuationHandle = *blanks; // subroutine allows for partial continuation exsr srListEntries; 1b if ApiHead.InformationStatus = 'P'; ContinuationHandle = ApiHead.ContinuationHandle; exsr srListEntries; 1e endif; endsr; //----------------------- // if first character is blank, then filter is a wild card // if first character <> blank, then trailing is wild card // scJob is position to. // scstat is only show these. // sctest is only show these. //----------------------- begsr srApplyFilters; IsSelected = *off; IsOk1 = *off; 1b if scJob = '*ALL'; // *entry special value IsOk1 = *on; 1x elseif scJob > *blanks; 2b if %subst(scJob:1:1)>*blanks; lenscan = %len(%trimr(scJob)); 3b if %subst(qwclscdeDS.Job:1:lenscan) >= scJob; IsOk1 = *on; 3e endif; 2x else; 3b if %scan(%trim(scJob): qwclscdeDS.Job: 1) > 0; IsOk1 = *on; 3e endif; 2e endif; 1x else; IsOk1 = *on; 1e endif; //-------------------------------------------------- IsOk2 = *off; 1b if scStat > *blanks; 2b if scStat = qwclscdeDS.Status; IsOk2 = *on; 2e endif; 1x else; IsOk2 = *on; 1e endif; //-------------------------------------------------- IsOk3 = *off; 1b if scUSer > *blanks; exsr srGetUserProfile; 2b if scUser = sbUser; IsOk3 = *on; 2e endif; 1x else; IsOk3 = *on; 1e endif; //-------------------------------------------------- IsOk4 = *off; 1b if scJobdL > *blanks; 2b if scJobdL = qwclscdeDS.JobdLib; IsOk4 = *on; 2e endif; 1x else; IsOk4 = *on; 1e endif; //-------------------------------------------------- IsOk5 = *off; 1b if scCmd > *blanks; upcase = %subst(qwclscdeDS.Command:1:qwclscdeDS.LengthOfCommand); upcase = %upper(upcase); 2b if %subst(scCmd:1:1)>*blanks; lenscan = %len(%trimr(scCmd)); 3b if %len(upcase) >= lenscan; 4b if %subst(upcase:1:lenscan) = scCmd; IsOk5 = *on; 4e endif; 3e endif; 2x else; 3b if %scan(%trim(scCmd): upcase: 1) > 0; IsOk5 = *on; 3e endif; 2e endif; 1x else; IsOk5 = *on; 1e endif; 1b if IsOk1 and IsOk2 and IsOk3 and IsOk4 and IsOk5; IsSelected = *on; 1e endif; endsr; //----------------------------------------- //----------------------------------------- begsr srListEntries; callp QWCLSCDE( UserSpaceName: 'SCDL0200': p_Entry: ContinuationHandle: ApiErrDS); // Process data from user space by moving qwclscdePtr pointer. qwclscdePtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; 2b if scJob > *blanks or scstat > *blanks or scUser > *blanks or scJobdl> *blanks or scCmd > *blanks; exsr srApplyFilters; 2e endif; 2b if IsSelected; 3b if qwclscdeDS.InformationStatus = 'L'; SBCMD = 'The Entry is Locked'; 3x elseif qwclscdeDS.InformationStatus = 'A'; SBCMD = 'You Have Insufficient Authority'; 3x else; SBCMD = %subst(qwclscdeDS.Command:1:qwclscdeDS.LengthOfCommand); 3e endif; //-------------------------------------------------- // load hidden fields for copy or change selections //-------------------------------------------------- SENTRYNBR = qwclscdeDS.EntryNumber; SCMD = %subst(qwclscdeDS.Command:1:qwclscdeDS.LengthOfCommand); SFRQ = qwclscdeDS.Frequency; 3b if %subst(qwclscdeDS.ScheduledDate:1:1) = '*'; SSCDDATE = qwclscdeDS.ScheduledDate; 3x else; yymmdd = qwclscdeDS.ScheduledDate + '000001000'; callp QWCCVTDT( '*YMD ': yymmdd : '*JOB ': cvtdate: ApiErrDS); SSCDDATE = %subst(cvtdate:2:6); 3e endif; SSCDDAY = %trimr(qwclscdeDS.ScheduledDays(1))+ ' ' + %trimr(qwclscdeDS.ScheduledDays(2))+ ' ' + %trimr(qwclscdeDS.ScheduledDays(3))+ ' ' + %trimr(qwclscdeDS.ScheduledDays(4))+ ' ' + %trimr(qwclscdeDS.ScheduledDays(5))+ ' ' + %trimr(qwclscdeDS.ScheduledDays(6))+ ' ' + qwclscdeDS.ScheduledDays(7); // if %subst(qwclscdeDS.ScheduledTime:1:1) = '*'; SSCDTIME = qwclscdeDS.ScheduledTime; // else; // SSCDTIME = qs + %trimr(qwclscdeDS.ScheduledTime) + qs; // endif; 3b if %subst(qwclscdeDS.DatesOmitted(01):1:1) = x'00'; SOMITDATE = '*NONE'; 3x else; SOMITDATE = %trimr(qwclscdeDS.DatesOmitted(01))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(02))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(03))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(04))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(05))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(06))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(07))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(08))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(09))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(10))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(11))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(12))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(13))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(14))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(15))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(16))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(17))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(18))+ ' ' + %trimr(qwclscdeDS.DatesOmitted(19))+ ' ' + qwclscdeDS.DatesOmitted(20); 3e endif; SRCYACN = qwclscdeDS.RecoveryAction; 3b if qwclscdeDS.JobdLib = *blanks; SJOBD = qwclscdeDS.Jobd; 3x else; SJOBD = f_GetQual(qwclscdeDS.Jobd + qwclscdeDS.JobdLib); 3e endif; 3b if qwclscdeDS.JobqLib = *blanks; SJOBQ = qwclscdeDS.Jobq; 3x else; SJOBQ = f_GetQual(qwclscdeDS.Jobq + qwclscdeDS.JobqLib); 3e endif; exsr srGetUserProfile; 3b if qwclscdeDS.MsgqLib = *blanks; SMSGQ = qwclscdeDS.Msgq; 3x else; SMSGQ = f_GetQual(qwclscdeDS.Msgq + qwclscdeDS.MsgqLib); 3e endif; STEXT = qs + %trimr(qwclscdeDS.Text) + qs; SBJOB = qwclscdeDS.Job; SBSTAT = qwclscdeDS.Status; SBFREQ = qwclscdeDS.Frequency; SBJOBDL= qwclscdeDS.JobdLib; SBSTIME = %subst(qwclscdeDS.ScheduledTime:1:2) + ':' + %subst(qwclscdeDS.ScheduledTime:3:2) + ':' + %subst(qwclscdeDS.ScheduledTime:5:2); //--------------------------------------------------------- // the scheduled date display is interesting. // the IBM command shows either the schedule date (if <> *NONE) // or the first entry in the DAYS arraye, unless two // or more days are scheduled, then it shows 'USER DEF' // I do not necessarily want to replicate that, // but I want to show maximum amount of command string so I will //--------------------------------------------------------- 3b if qwclscdeDS.ScheduledDate <> '*NONE '; SBSDATE = %subst(qwclscdeDS.ScheduledDate:4:2) + '/' + %subst(qwclscdeDS.ScheduledDate:6:2) + '/' + %subst(qwclscdeDS.ScheduledDate:2:2); 3x else; 4b if qwclscdeDS.ScheduledDays(2) > *blanks; SBSDATE = 'USER DEF'; 4x else; SBSDATE = qwclscdeDS.ScheduledDays(1); 4e endif; 3e endif; 3b if p_Output = '*PRINT'; write PRTDETAIL; 4b if IsOverFlow; write PRTHEAD1; IsOverFLow = *off; 4e endif; 3x elseif p_Output = '*OUTFILE'; write JCRSCDEFR; 3x elseif p_Output = '* '; rrn1 += 1; write sbfdta1; 3e endif; 2e endif; qwclscdePtr += ApiHead.ListEntrySize; 1e endfor; endsr; //---------------------------------------------- // retrieve status from the user profile. begsr srGetUserProfile; callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0100': qwclscdeDS.UserProfileForSubmittedJob: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0 and ApiErrDS.ErrMsgId = 'CPF9801'; SBUSER = '*NOT FOUND'; 1x elseif usri0300DS.status = '*DISABLED'; SBUSER = '*DISABLED '; 1x else; SBUSER = qwclscdeDS.UserProfileForSubmittedJob; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRSCDEV - Validity checking program output parm //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_SndEscapeMsg /define f_OutFileCrtDupObj // *ENTRY /define p_JCRSCDER /COPY JCRCMDS,JCRCMDSCPY // Check OUTFILE parameter 1b if p_Output = '*OUTFILE'; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRSCDEF'); 1x elseif p_Output = '*PRINT'; 2b if not(%subst(p_OutqQual:1:1) = '*'); 3b if %subst(p_OutqQual:11) = *blanks; %subst(p_OutqQual:11) = '*LIBL'; 3e endif; f_CheckObj(p_OutqQual: '*OUTQ'); 2e endif; 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Print Indented Source Listing') PARM KWD(SRCMBR) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('Source member') 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(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.Shows CL or RPGLE source listing with structured programming operations indented for improved readability. Print option available. :P.RPGLE View similar to RDI indented source view.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRSDENT/SRCMBR'.Source Member Name - Help :XH3.Source Member Name (SRCMBR) :P.Source member whose 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 or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRSDENT' A 20'Show Source Indentation' A SCDOW 9A O 70 A 80DATE EDTCDE(Y) A SCSYSTEM 8A 90SPACEA(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 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 PART1SRC 25A O 9 A LINEOFCODE 114A O 34 ]]> '); //--------------------------------------------------------- // JCRSDENTR - Show Source Indentation for RPG or CL // make CL indentation be previous continuation line sensitive //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f SRCMBR disk(112) extfile(extIfile) extmbr(p_SrcMbr) infds(Infds) usropn; dcl-ds InputDS len(112) qualified; CompileArry char(3) pos(13); SrcSeq zoned(6: 2) pos(1); SrcDat zoned(6: 0) pos(7); SpecType char(1) pos(18); Asterisk char(1) pos(19); Opcode char(10) pos(38); Part1src char(25) pos(13); Part2Src char(75) pos(38); Src100 char(100) pos(13); Src94 char(94) pos(19); end-ds; dcl-f JCRSDENTP printer oflind(IsOverFlow) usropn; /define Constants /define psds /define Infds /define f_BuildString /define f_DisplayLastSplf /define f_GetQual /define f_Qusrmbrd /define f_GetDayName /define f_RunCmd /define f_BlankCommentsCL /define f_Dltovr /define f_SndCompMsg /define f_IsCompileTimeArray /define f_CheckSameLineEnd /define f_IsIgnoreLine /COPY JCRCMDS,JCRCMDSCPY dcl-s IsContinuation ind; dcl-s WrkA like(opcodeds); dcl-s Upper like(srcall); dcl-s LevelsDeep uns(3); dcl-s LevelsDown uns(3); dcl-s LevelsUp uns(3); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s IsArrowIn ind; dcl-s IsCalcSpec ind; dcl-s IsCasxx ind; dcl-s IsCompileTime ind; dcl-s IsFree ind; dcl-s IsSqlExec ind; dcl-s IsDo ind; dcl-s IsDoEnd ind; dcl-s string varchar(94); dcl-s src100 char(100); dcl-s qq uns(3); dcl-s qcnt uns(10); dcl-s quotepos uns(3) dim(100) ascend; dcl-ds OpCodeDS len(10) inz qualified; Two char(2) pos(1); Three char(3) pos(1); Four char(4) pos(1); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_Output char(8); end-pi; //--------------------------------------------------------- f_RunCmd(f_BuildString( 'OVRPRTF FILE(JCRSDENTP) PRTTXT(*BLANK) 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'); scObjHead = f_BuildString('& & & &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: QusrmbrdDS.Text); scDow = f_GetDayName(); write PrtHead; IsOverFlow = *off; extIfile = f_GetQual(QusrmbrdDS.File + QusrmbrdDS.Lib); open SRCMBR; read SRCMBR inputds; 1b dow not %eof; Seqno = inputds.SrcSeq; OpCodeDs = inputds.Opcode; Part1Src = inputds.Part1Src; Src100 = inputds.Src100; // If 92 record length, blank out any garbage from 93 to 112 2b if InfdsRecLen = 92; %subst(Src100:81) = *all' '; 2e endif; 2b if QusrmbrdDS.MbrType in %list('CLP':'CLLE'); exsr srClSrc; 2x else; exsr srRPGSrc; 2e endif; read SRCMBR inputds; 1e enddo; exsr srClose; //--------------------------------------------------------- begsr srClose; close JCRSDENTP; close SRCMBR; f_Dltovr('JCRSDENTP'); f_DisplayLastSplf('JCRSDENTR': p_Output); *inlr = *on; return; endsr; //--------------------------------------------------------- begsr srRPGSrc; IsFree = *off; IsCalcSpec = *off; // do not process compile time arrays 1b if f_IsCompileTimeArray(inputds.CompileArry); IsCompileTime = *on; 1x else; string = %trimr(inputds.Src94); string = %upper(string); 2b if inputds.Asterisk in %list('*':'/'); // do not worry about indenting till get to C specs. // if C or c or /free, inside the C specs. 2x elseif %upper(inputds.SpecType) = 'C'; IsCalcSpec = *on; IsFree = *off; 2x elseif inputds.SpecType = ' '; IsCalcSpec = *on; IsFree = *on; 2e endif; 1e endif; exsr srIndent; endsr; //---------------------------------------------------------------- //---------------------------------------------------------------- begsr srIndent; 1b if IsCompileTime = *off and IsCalcSpec = *on; LevelsDown = 0; LevelsUp = 0; 2b if not (inputds.Asterisk in %list('*':'+':'/')); //--------------------------------------------------------- // For /free code, extract opcode into OpCodeDS field. // Look for first ';' and first ';' , the one not // zero and lowest value is end of opcode //--------------------------------------------------------- 3b if IsFree and %len(string) > 0; WrkA = %triml(string); clear OpCodeDS; 4b if not IsContinuation; aa = %scan(' ': WrkA: 1); bb = %scan(';': WrkA: 1); 5b if aa > 0 and (aa < bb or bb = 0); OpCodeDS = %subst(WrkA: 1: aa - 1); 5x elseif bb > 0 and (bb < aa or aa = 0); OpCodeDS = %subst(WrkA: 1: bb - 1); 5e endif; opcodeDS = f_CheckSameLineEnd(opcodeDS: string); 4e endif; exsr srContinuationCheck; 3e endif; OpCodeDS = %upper(OpCodeDS); // bad person had field named END in their free code // ENDblank is valid in fixed column format, but not in free 3b if IsFree and OpCodeDS = 'END'; OpCodeDS = *blanks; 3e endif; //--------------------------------------------------------- // do not format SQL statements // Ignore everything between EXEC and terminating; //--------------------------------------------------------- 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 (IsFree and (OpCodeDS = 'DOU' or OpCodeDS.Four = 'DOU(' or OpCodeDS = 'DOW' or OpCodeDS.Four = 'DOW(' or OpCodeDS = 'IF' or OpCodeDS.Three = 'IF(' or OpCodeDS = 'DCL-DS' or OpCodeDS = 'DCL-PR' or OpCodeDS = 'DCL-PI' or OpCodeDS = 'DCL-PROC')) or OpCodeDS = 'FOR' or OpCodeDS = 'MONITOR' or OpcodeDS.Four = 'FOR(' 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 // note ds name cannot be in %list //--------------------------------------------------------- 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.Four = 'END-' 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(';': inputds.Src94: 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; 2x elseif LevelsDeep = 38; f_SndCompMsg('WARNING: Nesting Over 38 Levels 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 inputds.Asterisk = '*' or inputds.Asterisk = '+' or inputds.Asterisk = '/'; %subst(LineOfCode: xx) = %triml(inputds.Src94); %subst(Part1Src: 7) = *all' '; 2x else; %subst(LineOfCode: xx) = inputds.Part2Src; 2e endif; write PrtCspec; LevelsDeep += LevelsDown; // step back down level for stuff under WHEN/OTHER 2b if not(inputds.Asterisk = '*' or inputds.Asterisk = '+' or inputds.Asterisk = '/'); 3b if (OpCodeDS.Two = 'WH' and IsFree = *off) or OpCodeDS = 'WHEN' or OpCodeDS = 'OTHER'; LevelsDeep += 1; 3e endif; 2e endif; 1x else; SrcAll = Src100; write PrtXspec; 1e endif; endsr; //--------------------------------------------------------- // 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! //--------------------------------------------------------- begsr srContinuationCheck ; IsContinuation = *off; 1b if not f_IsIgnoreLine(string); // skip comments and such aa = %len(string); 2b if aa > 0; 3b if %subst(string: aa: 1) = '+' or %subst(string: aa: 1) = '-'; IsContinuation = *on; 3e endif; 2e endif; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srCLSrc; // slam everything to left for indentation then upper case Src100 = ' ' + %triml(Src100); // It is easier to blank out all comments before scanning Upper = f_BlankCommentsCL(%upper(Src100)); IsDo = *off; IsDoEnd = *off; 1b if Upper > *blanks; // get number of quotes in this line quotepos(*) = 0; qq = 0; bb = 1; 2b dou aa = 0; aa = %scan(qs: upper: bb); 3b if aa > 0; qq += 1; quotepos(qq) = aa; bb = aa+1; // position next scan 4b if bb > %len(upper); 2v leave; 4e endif; 3e endif; 2e enddo; // Check for indent start and end commands xx = %scan(' DO ': Upper); 2b if xx = 0; xx = %scan('(DO)': Upper); 3b if xx = 0; xx = %scan('DOUNTIL': Upper); 4b if xx = 0; xx = %scan('DOWHILE': Upper); 5b if xx = 0; xx = %scan('DOFOR': Upper); 6b if xx = 0; xx = %scan(' SELECT ': Upper); 7b if xx = 0; xx = %scan('(SELECT ': Upper); 7e endif; 6e endif; 5e endif; 4e endif; 3e endif; 2e endif; // set indent flag in relation to number of quotes 2b if xx > 0; IsDo = f_checkquotes(); 2x else; xx = %scan('ENDDO ': Upper); 3b if xx = 0; xx = %scan('ENDSELECT': Upper); 3e endif; 3b if xx > 0; IsDoEnd = f_checkquotes(); 3e endif; 2e endif; qcnt += qq; 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; 2b if LevelsDeep > 0; LevelsDeep -= 1; 2e endif; 1e endif; clear LineOfCode; 1b for cc = 1 to LevelsDeep; LineOfCode = %trimr(LineOfCode) + ' |'; 1e endfor; LineOfCode = %trimr(LineOfCode) + Src100; 1b if IsDo; LevelsDeep += 1; 1e endif; write PrtCLspec; endsr; //-------------------------------- // I am saying if the number of quotes over to xx is even, // then this is a valid command, else it is between quotes //-------------------------------- dcl-proc f_checkquotes; dcl-pi *n ind end-pi; bb = 0; // if current line has quotes, see where xx is in relationship. 1b if qq > 0; bb = %lookuplt(xx:quotepos:1:qq); 1e endif; return (%rem(qcnt+bb: 2) = 0); end-proc; ]]> */ /*--------------------------------------------------------------------------*/ 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(*CHAR) LEN(10) CHOICE(*PGM) + CHOICEPGM(*LIBL/JCRSMLTRC) PROMPT('File') 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(QUICKSCAN) TYPE(*CHAR) LEN(1) RSTD(*YES) + DFT(N) VALUES(Y N) CHOICE('Exit First + Occurrence Found') PROMPT('Exit First + Occurrence Found') PARM KWD(LISTLEVEL) TYPE(*CHAR) LEN(6) RSTD(*YES) + DFT(*FIRST) VALUES(*FIRST *ALL) SPCVAL((* + *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(OUTQ) TYPE(OUTQ) PMTCTL(PMTCTL2) + PROMPT('Outq') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(*JOB) SPCVAL((*JOB + *JOB)) QUAL TYPE(*NAME) LEN(10) SPCVAL((*LIBL)) + PROMPT('Library') PARM KWD(OUTFILE) TYPE(OUTFILE) PMTCTL(PMTCTL1) + PROMPT('Outfile') OUTFILE: QUAL TYPE(*NAME) LEN(10) 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) PMTCTL2: PMTCTL CTL(OUTPUT) COND((*EQ '*PRINT')) NBRTRUE(*EQ 1) ]]> * * Enter the CHOICEKEY in the File Name prompt to search * unrestricted number of source files. * The choice program in the command definition reads this file to * present a list of predefined choices. * * CHOICE KEY MUST HAVE * AS FIRST CHARACTER!! *---------------------------------------------------------------- A R JCRSMLTCHR TEXT('Source Lists') A CHOICEKEY 10A COLHDG('File Name Prompt*') A CHOICETXT 20A COLHDG('Choice Text') A CHOICELIB 10A COLHDG('Source Lib') A CHOICEFIL 10A COLHDG('Source File') A CHOICEMBR 10A COLHDG('Source Mbr') A CHOICETYP 10A COLHDG('Mbr Type') A K CHOICEKEY A K CHOICELIB A K CHOICEFIL ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRSMLTF; CREATE TABLE JCRSMLTF ( RDATE DATE NOT NULL DEFAULT CURRENT_DATE , RTIME TIME NOT NULL DEFAULT CURRENT_TIME , SCANSET CHAR(7) NOT NULL DEFAULT '' , SRCLIB CHAR(10) NOT NULL DEFAULT '' , SRCFIL CHAR(10) NOT NULL DEFAULT '' , RTVMBR CHAR(10) NOT NULL DEFAULT '' , MBRTYPE CHAR(10) NOT NULL DEFAULT '' , SRCSEQ NUMERIC(6, 2) NOT NULL DEFAULT 0 , SRCDTA CHAR(100) NOT NULL DEFAULT '' , SRCCHGDAT NUMERIC(6, 0) NOT NULL DEFAULT 0 , SRCTXT CHAR(50) NOT NULL DEFAULT '' , SCANSTR1 CHAR(25) NOT NULL DEFAULT '' , SCANSTR2 CHAR(25) NOT NULL DEFAULT '' , SCANSTR3 CHAR(25) NOT NULL DEFAULT '' , SCANSTR4 CHAR(25) NOT NULL DEFAULT '' , SCANSTR5 CHAR(25) NOT NULL DEFAULT '' , SCANSTR6 CHAR(25) NOT NULL DEFAULT '' , SCANSTR7 CHAR(25) NOT NULL DEFAULT '' , SCANSTR8 CHAR(25) NOT NULL DEFAULT '' , SCANSTR9 CHAR(25) NOT NULL DEFAULT '' , SCANSTR10 CHAR(25) NOT NULL DEFAULT '' ) RCDFMT JCRSMLTFR ; LABEL ON TABLE JCRSMLTF IS 'Scan mult source file/mbrs - outfile jcr' ; LABEL ON COLUMN JCRSMLTF ( RDATE TEXT IS 'Run Date' , RTIME TEXT IS 'Run Time' , SCANSET TEXT IS 'Scan set' , SRCLIB TEXT IS 'Source Lib' , SRCFIL TEXT IS 'Source File' , RTVMBR TEXT IS 'Source Mbr' , MBRTYPE TEXT IS 'Mbr Type' , SRCSEQ TEXT IS 'Line Number' , SRCDTA TEXT IS 'Source' , SRCCHGDAT TEXT IS 'Change Date' , SRCTXT TEXT IS 'Text' , SCANSTR1 TEXT IS 'Scan Strings' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRSMLTF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Searches one to ten character strings in selected members of selected source files. Scan for trailing blanks by enclosing scan string in quotes. For example. 'ABC ' would scan for ABC followed by three blank spaces. :NT.To define many scan files to select with single keyword, add records to JCRSMLTCHF. These records drive the choice text when F4 prompt the File Name. Great way to pre-select groups of often scanned source files. CHOICEKEY MUST START WITH * .:ENT. :P.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) to search for in specified source members. 'XX ' will search for XX and a space or blank character. :NT.If scanning for '11', 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 for 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 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 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 the command will search. :NT.Associate unlimited numbers of files with single keyword in file JCRSMLTCHF. Choice Keyword must begin with character * :ENT.:EHELP. :HELP NAME='JCRSMLT/QUICKSCAN'.Exit First Occurrence Found - Help :XH3.Exit First Occurrence Found (QUICKSCAN) :P.Exit JCRSMLT at first occurrence found. Allows you to quickly find something without waiting on entire scan to complete :PARML.:PT.:PK def.N:EPK.:PD.Scan all selected members. :PT.Y:PD.Exit JCRSMLT when first occurence is found.:EPARML.: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 interactive session for long periods of time if scanning large number of members.:EPARML.:EHELP. :HELP NAME='JCRSMLT/OUTFILE'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output.:EHELP. :HELP NAME='JCRSMLT/OUTMBR'.Output - Help :XH3.Output (OUTMBR) :P.File member to receive command output. note: outfile is SQL DDL and does not allow multiple members.:EHELP. :HELP NAME='JCRSMLT/OUTQ'.Outq name - Help :XH3.Outq name (OUTQ) :P.Name and library of output queue to place the spooled file.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- 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 80 A 90DATE EDTCDE(Y) A SCSYSTEM 8A 100 A 110'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 HSRCLIB 10A O 20 A HSRCFIL 10A O 32 A HSRCMBR 10A O 44 A HSRCMBRTYP 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 SETTYPE 7A 61 A N10 SETVERBAGE 50A 73 *---------------------------------------------------------------- A R PRTHEAD4 SPACEA(1) A 1'Library' A 12'File' A 23'Member' A 34'Type' A 27 45'Seqno' A 27 54'Source Data' A 27 135'Chg Date' A 144'Text' A SPACEA(1) A*--- *--- A 1'----------' A 12'----------' A 23'----------' A 34'----------' A 45'-------' A 54'----------------------------------- A ------------------------------------ A -----------' A 135'--------' A 144'----------------------------------- A -------' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SRCLIB 10A O 1 A SRCFIL 10A O 12 A RTVMBR 10A O 23 A MBRTYPE 10 34 A 27 SRCSEQ 6 2O 45 A EDTCDE(4) A 27 SRCDTA80 80A O 54 A 20 SRCCHGDAT 6 0 135 A EDTCDE(Y) A SRCTXT41 41A 144 *---------------------------------------------------------------- A R PRTSPACEA1 SPACEA(1) A 1' ' *---------------------------------------------------------------- A R PRTENDOR SPACEB(1) A 2'* End Of Report' ]]> '); //--------------------------------------------------------- // JCRSMLTR - Scan mult source file/mbrs - scanner //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f MBRSRC disk(112) extfile(extifile) extmbr(rtvmbr) usropn infds(infds); dcl-ds InputDS; SrcSeq zoned(6:2) pos(1); SrcChgdat zoned(6) pos(7); SrcComment char(1) pos(19); SrcCommentFree char(2) pos(19); SrcDta char(100) pos(13); end-ds; dcl-f JCRSMLTF usage(*output) extfile(extofile) extmbr(extombr) usropn; dcl-f JCRSMLTP printer oflind(IsOverFlow) indds(ind) usropn; dcl-f JCRSMLTCHF keyed; /define ApiErrDS /define psds /define Constants /define Ind /define Infds /define Quslmbr /define f_BlankCommentsCL /define f_GetQual /define f_GetDayName /define f_Quscrtus /define f_OvrPrtf /define f_Dltovr /COPY JCRCMDS,JCRCMDSCPY dcl-s extOmbr char(10); dcl-s NumOfFiles uns(3); dcl-s NumOfScanValues uns(3); dcl-s ScanLen uns(3); dcl-s ToPosSave uns(3); dcl-s ToPos uns(3); dcl-s FromPos uns(3); dcl-s ScanRRN uns(10) dim(16000); dcl-s SaveRRN uns(10); dcl-s CurrentRRN uns(10); dcl-s OffsetToNext int(5) based(displaceptr); dcl-s RtvMbr char(10); dcl-s SrcCase like(srcdta); dcl-s SrcListPtr pointer inz(*null); dcl-s IsAllFound ind; dcl-s IsNoneFound ind; dcl-s IsSomeFound ind; dcl-s IsFoundArry ind dim(10); dcl-s yy uns(5); dcl-s ScanVals varchar(25) dim(10) based(parsevaluesptr); dcl-s PredefinedKey like(ChoiceKey); // Get number of source files and source file/lib/mbr names dcl-ds InnerList based(InnerListPtr); SrcFil char(10) pos(3); SrcLib char(10) pos(13); SrcMbr char(10) pos(23); SrcMbrTyp char(10) pos(33); end-ds; dcl-ds LdaDS DTAARA(*usrctl: *LDA) qualified; SrcFiles char(398); ScanStrings char(272); Case char(4); IfContains char(7); QuickScan char(1); Listlvl char(6); ScanComment char(5); From uns(3); To uns(3); Output char(8); OutqQual char(20); OutFileQual char(20); OutMbrOpt char(22); end-ds; dcl-ds OutFileData; ScanStr1; ScanStr2; ScanStr3; ScanStr4; ScanStr5; ScanStr6; ScanStr7; ScanStr8; ScanStr9; ScanStr10; ScanStrOutFile like(scanstr1) dim(10) pos(1); end-ds; //--*ENTRY------------------------------------------------- // LDA is used for long parms in LdaDS; SrcListPtr = %addr(LdaDS.SrcFiles); ParseValuesPtr = %addr(LdaDS.ScanStrings) + 2; NumOfFiles = f_ParmListCount(LdaDS.SrcFiles); NumOfScanValues = f_ParmListCount(LdaDS.ScanStrings); scDow = f_GetDayName(); // if not case senstitive, covert all to upper case 1b if LdaDS.Case = '*NO'; 2b for cc = 1 to NumOfScanValues; ScanVals(cc) = %upper(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 files/Lib/mbr names at top of report. // Spin down number of offsets to List entries. // Inner List pointer (start of List + OffsetToNext // pointer) moves DS through List // OR // if file is one of the predefined source lists in JCRSMLTCHF // then list the choice selections in that file. // Predefined source lists must start with * . //--------------------------------------------------------- 1b if LdaDS.OutPut = '*PRINT'; f_OvrPrtf('JCRSMLTP': LdaDS.OutqQual: ScanVals(1)); open JCRSMLTP; write PrtHead1; isOverFlow = *off; pListLvl = LdaDS.ListLvl; pScanCmnt = LdaDS.ScanComment; DisplacePtr = SrcListPtr; 2b for ForCount2 = 1 to NumOfFiles; DisplacePtr += 2; InnerListPtr = SrcListPtr + OffsetToNext; 3b if not(%subst(SrcFil:1 :1) = '*'); hSrcLib = SrcLib; hSrcFil = SrcFil; hSrcMbr = SrcMbr; hSrcMbrTyp = SrcMbrTyp; write PrtHead2; 3x else; PredefinedKey = %subst(SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; reade PredefinedKey JCRSMLTCHR; 4b dow not %eof; hSrcLib = ChoiceLib; hSrcFil = ChoiceFil; hSrcMbr = ChoiceMbr; hSrcMbrTyp = ChoiceTyp; write PrtHead2; 5b if IsOverFlow; write PrtHead1; IsOverFlow = *off; 5e endif; Ind.HeadingSwitch = *on; reade PredefinedKey JCRSMLTCHR; 4e enddo; 3e endif; Ind.HeadingSwitch = *on; 2e endfor; write PrtSpaceA1; //--------------------------------------------------------- // Print strings in heading of report. // Load verbiage for set definition parameter. //--------------------------------------------------------- settype = LdaDS.IfContains; 2b if LdaDS.IfContains = '*ALL'; setverbage = 'Member contains ALL 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; rdate = %date(); rtime = %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 ApiHeadPtr = f_Quscrtus(UserSpaceName); // load user space with mbr name list DisplacePtr = SrcListPtr; 1b for ForCount2 = 1 to NumOfFiles; DisplacePtr += 2; InnerListPtr = SrcListPtr + OffsetToNext; extIfile = f_GetQual(SrcFil + SrcLib); 2b if not(%subst(SrcFil:1 :1) = '*'); exsr srGetMbrList; 2x else; PredefinedKey = %subst(SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; reade PredefinedKey JCRSMLTCHR; 3b dow not %eof; SrcLib = ChoiceLib; SrcFil = ChoiceFil; SrcMbr = ChoiceMbr; SrcMbrTyp = ChoiceTyp; extIfile = f_GetQual(SrcFil + SrcLib); exsr srGetMbrList; reade PredefinedKey JCRSMLTCHR; 3e enddo; 2e endif; 1e endfor; exsr srexit; begsr srexit; 1b if LdaDS.OutPut = '*PRINT'; write prtendor; // end of report close JCRSMLTP; f_Dltovr('JCRSMLTP'); 1x else; close JCRSMLTF; 1e endif; *inlr = *on; return; endsr; //----------------------------------------------------- //----------------------------------------------------- begsr srGetMbrList; callp QUSLMBR( UserSpaceName: 'MBRL0200': SrcFil + SrcLib: SrcMbr: '0': ApiErrDS); 1b if ApiErrDS.BytesReturned = 0; //no errors on return // Process members in user space, // override input file to each member QuslmbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 2b for ForCount = 1 to ApiHead.ListEntryCount; RtvMbr = QuslmbrDS.MbrName; // member type selection 3b if SrcMbrTyp in %list('*ALL':QuslmbrDS.MbrType); SrcTxt = QuslmbrDS.Text; Mbrtype = QuslmbrDS.MbrType; 4b monitor; open MBRSRC; exsr srReadMbr; close MBRSRC; // Exclusive options, *NONE and *NOTALL // can only be processed after entire member is read. 5b if (LdaDS.IfContains = '*NONE' and IsNoneFound) or (LdaDS.IfContains = '*NOTALL' and IsSomeFound); exsr srPrintLine; 5e endif; 4x on-error; 4e endmon; 3e endif; QuslmbrPtr += ApiHead.ListEntrySize; 2e endfor; 1e endif; endsr; //--------------------------------------------------------- // read through member scanning for each find string. // For inclusive sets (*ALL *ANY), keep track of // RRNs that are used later for printing. //--------------------------------------------------------- begsr srReadMbr; IsFoundArry(*) = *off; IsAllFound = *off; IsSomeFound = *off; IsNoneFound = *on; CurrentRRN = 0; cc = 0; read MBRSRC InputDS; 1b dow not %eof; CurrentRRN += 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 %scan('//':srcdta)>0)); 3b if InfdsRecLen = 92 or ((QuslmbrDS.MbrType = 'RPGLE' or QuslmbrDS.MbrType = 'SQLRPGLE') and LdaDS.ScanComment = '*NO'); %subst(SrcDta:81) = *blanks; // blank out inline comments 3e endif; 3b if LdaDS.Case = '*NO'; SrcCase = %upper(Srcdta); 3x else; SrcCase = SrcDta; 3e endif; // If scan comment = *NO, then blank out comments 3b if LdaDS.ScanComment = '*NO'; 4b if QuslmbrDS.MbrType in %list('RPGLE':'SQLRPGLE'); aa = %scan('//': SrcCase); 5b if aa > 0; %subst(SrcCase:aa) = *blanks; 5e endif; // blank out all comments before scanning 4x elseif QuslmbrDS.MbrType in %list('CLP':'CLLE':'CMD':'CLP38'); SrcCase = f_BlankCommentsCL(SrcCase); 4e endif; 3e endif; //--------------------------------------------------------- 3b for aa = 1 to NumOfScanValues; // number 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. // Spin through member to see if all strings are present. // If user has selected to view only *FIRST occurrence of each string, // then only load RRN of each first occurrence into array. // If user has selected *ALL occurrences of string, then must // load all rrns, until known all strings are present, // then just read and print reset. //--------------------------------------------------------- 6b if not IsAllFound; 7b if cc = 0; ScanRRN(1) = CurrentRRN; cc = 1; 7x else; 8b if not(LdaDS.ListLvl = '*FIRST' and IsFoundArry(aa) = *on); 9b if not(ScanRRN(cc) = CurrentRRN); //no duplicates cc += 1; ScanRRN(cc) = CurrentRRN; 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 previously found records. // 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; SaveRRN = CurrentRRN; 8b for yy = 1 to cc; CurrentRRN = ScanRRN(yy); chain CurrentRRN MBRSRC InputDS; exsr srPrintLine; 8e endfor; CurrentRRN = SaveRRN; chain CurrentRRN MBRSRC InputDS; 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 InputDS; 1e enddo; endsr; //--------------------------------------------------------- // Print detail line //--------------------------------------------------------- begsr srPrintLine; 1b monitor; SrcSeq = SrcSeq; 1x on-error; SrcSeq = 0; 1e endmon; 1b monitor; SrcChgdat = SrcChgdat; 1x on-error; SrcChgdat = 0; 1e endmon; Ind.IsChangedDate = (SrcChgdat > 0); 1b if LdaDS.OutPut = '*PRINT'; SrcDta80 = SrcDta; SrcTxt41 = SrcTxt; write PrtDetail; 1x else; 2b if Ind.ShowSrcData = *off; SrcSeq = 0; SrcChgdat = 0; clear SrcDta; 2e endif; write JCRSMLTFR; 1e endif; 1b if LdaDS.QuickScan = 'Y'; exsr srexit; 1e endif; endsr; //--------------------------------------------------------- // return number of elements passed in parameter list //--------------------------------------------------------- dcl-proc f_ParmListCount; dcl-pi *n uns(5); p_ListParm char(2); end-pi; dcl-ds ExtractDS qualified; Bin uns(5); end-ds; ExtractDS = p_ListParm; return ExtractDS.bin; end-proc; ]]> '); //--------------------------------------------------------- // JCRSMLTRC - Choice program for predefined source lists // Used by command JCRSMLT and JCRFSET to return choicekeys list to command prompt. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRSMLTCHF keyed; dcl-ds BinDS qualified; Length int(5) inz; end-ds; dcl-ds p1DS qualified; Command char(10) pos(1); Keyword char(10) pos(11); CorP char(1) pos(21); end-ds; dcl-s NumberOfEntries uns(5); dcl-s Offset uns(5); dcl-s stringvar varchar(32); //--*ENTRY------------------------------------------------- dcl-pi *n; p1 char(21); p2 char(2000); end-pi; //--------------------------------------------------------- p1ds = p1; p2 = *blanks; // return initial headings when command is executed 1b if p1DS.CorP = 'C'; p2='Files or F4 Predefined Key'; 1x elseif p1DS.CorP = 'P'; NumberOfEntries = 0; Offset = 3; setll *loval JCRSMLTCHR; read JCRSMLTCHR; 2b dow not %eof; 3b if ChoiceTxt > *blanks; stringvar = %trimr(ChoiceKey) + ' = ' +%trimr(ChoiceTxt); 3x else; stringvar = %trimr(ChoiceKey); 3e endif; BinDS.Length = %len(stringvar); %subst(p2:Offset) = BinDS + stringvar; Offset += (BinDS.Length + 2); NumberOfEntries += 1; // only select 1st record of each group setgt ChoiceKey JCRSMLTCHR; read JCRSMLTCHR; 2e enddo; BinDS.Length = NumberOfEntries; %subst(p2:1:2) = BinDS; 1e endif; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRSMLTRS - Scan mult source file/mbrs - job submitter // Save existing *LDA // Load long list variables to *LDA // sbmjob for print, run interactive for display // Reset *LDA to previous value. // Normally, I DEPRECATE *LDA!! (that would make a good bumper sticker). But // given the limitations of long parms on SBMJOB, this is the best choice. //--------------------------------------------------------- /define ControlStatements /define f_RunCmd /define f_SndCompMsg /define f_DisplayLastSplf /define f_GetQual // *ENTRY /define p_JCRSMLTRS /COPY JCRCMDS,JCRCMDSCPY dcl-s SavLda like(LdaDS); dcl-s submitOutq char(21); dcl-ds LdaDS DTAARA(*LDA) qualified; SrcFiles char(398); ScanStrings char(272); Case char(4); IfContains char(7); QuickScan char(1); Listlvl char(6); ScanComment char(5); From uns(3); To uns(3); Output char(8); OutqQual char(20); OutFileQual char(20); OutMbrOpt char(22); end-ds; dcl-pr p_JCRSMLTR extpgm('JCRSMLTR') end-pr; //--------------------------------------------------------- SavLda = LdaDs; LdaDs.srcFiles = p_SrcFiles; LdaDS.Case = p_Case; LdaDS.IfContains = p_IfContains; LdaDS.SrcFiles = p_SrcFiles; LdaDS.QuickScan = p_QuickScan; LdaDS.Listlvl = p_Listlvl; LdaDS.ScanComment = p_ScanComment; LdaDS.From = p_From; LdaDS.To = p_To; LdaDS.Output = p_Output; LdaDS.OutqQual = p_OutqQual; LdaDS.OutFileQual = p_OutFileQual; LdaDS.OutMbrOpt = p_OutMbrOpt; LdaDS.ScanStrings = p_ScanStrings; out LdaDS; //----------------------------------------------------------- 1b if p_Output = '*'; callp p_JCRSMLTR(); // interactive show spooled file f_DisplayLastSplf('JCRSMLTP': '*'); 1x else; 2b if %subst(p_OutqQual:11:10) > *blanks; submitOutq = f_GetQual(p_OutqQual); 2x else; 3b if p_OutqQual = '*JOB'; submitOutq = '*JOBD'; 3x else; submitOutq = p_OutqQual; 3e endif; 2e endif; f_RunCmd('SBMJOB CMD(CALL JCRSMLTR) JOB(JCRSMLT) JOBQ(QTXTSRCH) + OUTQ(' + %trimr(submitOutq) + ')'); f_SndCompMsg('Job JCRSMLT submitted to job queue QTXTSRCH.'); 1e endif; // replace overlaid LDA LdaDs = SavLda; out LdaDS; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRSMLTV - Validity checking program for list elements // If the file name starts with *, then read and check the // pre-defined file groups and short cuts in JCRSMLTCHF. //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj /define f_SndEscapeMsg /define f_OutFileCrtDupObj // *ENTRY /define p_JCRSMLTRS /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRSMLTCHF keyed usropn; dcl-s OffsetToNext int(5) based(DisplacePtr); dcl-s NumOfLists int(5) based(p_SrcFilesPtr); dcl-s ForCount uns(3); dcl-s PredefinedKey like(ChoiceKey); // Get number of source files and source file/lib/Mbr names dcl-ds InnerList based(InnerListPtr) qualified; SrcFil char(10) pos(3); SrcLib char(10) pos(13); end-ds; //--------------------------------------------------------- // Use pointers to overlay input parms with DS values. // Spin down number of offsets to list entries. // Inner list pointer (start of list + OffsetToNext) // 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 + OffsetToNext; 2b if not(%subst(InnerList.SrcFil: 1: 1) = '*'); f_CheckMbr(InnerList.SrcFil + InnerList.SrcLib:'*FIRST'); 2x else; exsr srCheckPreDefinedFiles; 2e endif; 1e endfor; // Check OUTFILE parameter 1b if p_Output = '*OUTFILE'; 2b if %subst(p_OutFileQual:11:10) = 'QTEMP'; f_SndEscapeMsg('Outfile Lib can not be QTEMP.'); 2e endif; f_OutFileCrtDupObj(p_OutFileQual: p_OutMbrOpt: 'JCRSMLTF'); 1x elseif p_Output = '*PRINT'; 2b if not(%subst(p_OutqQual:1:1) = '*'); 3b if %subst(p_OutqQual:11) = *blanks; %subst(p_OutqQual:11) = '*LIBL'; 3e endif; f_CheckObj(p_OutqQual: '*OUTQ'); 2e endif; 1e endif; *inlr = *on; return; //------------------------------------------ begsr srCheckPreDefinedFiles; open JCRSMLTCHF; PredefinedKey = %subst(InnerList.SrcFil: 1: 10); setll PreDefinedKey JCRSMLTCHR; 1b if not %equal; f_SndEscapeMsg('Predefined key ' + %trimr(PreDefinedKey) + ' not in file JCRSMLTCHF.'); 1x else; reade PredefinedKey JCRSMLTCHR; 2b dow not %eof; f_CheckObj(ChoiceFil + ChoiceLib:'*FILE'); reade PredefinedKey JCRSMLTCHR; 2e enddo; 1e endif; close JCRSMLTCHF; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('List Spool Files with Options') PARM KWD(SELECT) TYPE(SELECTDS) CHOICE(*NONE) + PROMPT('Select files for') SELECTDS: ELEM TYPE(*GENERIC) LEN(10) DFT(*CURRENT) + SPCVAL((*CURRENT) (*ALL)) CHOICE('Name, + generic*, *CURRENT, *ALL') PROMPT('User') ELEM TYPE(*CHAR) LEN(10) DFT(*ALL) CHOICE('Name, + *ALL') PROMPT('User data') ELEM TYPE(OUTQ) PROMPT('Outq') ELEM TYPE(*GENERIC) LEN(10) DFT(*ALL) + SPCVAL((*ALL)) PROMPT('Spooled File') ELEM TYPE(*NAME) LEN(10) DFT(*ALL) SPCVAL((*STD) + (*ALL)) PROMPT('Form type') OUTQ: QUAL TYPE(*NAME) LEN(10) DFT(*ALL) SPCVAL((*ALL)) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A CA03 A CA05 A CA11 A CA12 A CF13 A INDARA A PRINT *---------------------------------------------------------------- A R SBFDTA1 SFL A 11 SFLNXTCHG A AOPTIONS1 1A P A SCSPLNO 6S 0H A SBFOPTION 1A B 6 3DSPATR(&AOPTIONS1) A SCSPLFNAME 10A O 6 7 A SCUSERID 10A O 6 19 A SCOUTQ 10A O 6 31 A SCUSRDTA 10A O 6 42 A SCNUMPAGES 5Y 0O 6 53EDTCDE(4) A SCCOPIES 3Y 0O 6 59EDTCDE(4) A SCSPLFDATE 8A O 6 64 A SCSPLFTIME 8A O 6 74 A SCJOBNAME 10A O 6 84 A SCJOBNO 6A O 6 96 A SCFORMTYPE 10A O 6104 A SCSTATUS 10A O 6115 *---------------------------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(0495) A SFLPAG(0019) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRSPLF' A COLOR(BLU) A 1 23'List Spool Files with Options' A DSPATR(HI) A SCDOW 9A O 1110COLOR(BLU) A 1120DATE A EDTCDE(Y) A COLOR(BLU) A 2110SYSNAME A COLOR(BLU) A 3 4'1=SndNet' A COLOR(BLU) A SCOPTIONS 63A O 3 15COLOR(BLU) A 4 4'6=Release' A COLOR(BLU) A 4 15'7=Duplicate' A COLOR(BLU) A 4 28'8=Attributes' A COLOR(BLU) A 4 49'9=Copy to PF or PDF (*TOSTMF)' A COLOR(BLU) A 5 2'Opt' A DSPATR(HI) A 5 7'File' A DSPATR(HI) A 5 19'User' A DSPATR(HI) A 5 31'Queue' A DSPATR(HI) A 5 42'User Data' A DSPATR(HI) A 5 53'Pages' A DSPATR(HI) A 5 59'Cpy' A DSPATR(HI) A 5 64'Creation Date/Time' A DSPATR(HI) A 5 84'Job Name' A DSPATR(HI) A 5 96'Number' A DSPATR(HI) A 5104'FormType' A DSPATR(HI) A 5115'Status' A DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 A OVERLAY A BLINK A 26 2'F3=Exit' A COLOR(BLU) A 26 20'F5=Refresh' A COLOR(BLU) A 26 49'F13=Repeat' A COLOR(BLU) A 26 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA12 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 EDTCDE(Y) 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 SCOUTQ 10A B 5 27 A SCUSRDTA 10A B 5 39 A SCPAGNBR 5Y 0O 5 52EDTCDE(4) A SCNUMCOPYS 3Y 0B 5 60EDTCDE(4) A 8 3'Page Rotation:' DSPATR(HI) A SCPAGEROT 3Y 0B 8 18EDTCDE(N) A 8 25'-1=*Auto fit to paper' A 9 25'-2=*Devd device default' A 10 25'-3=*Cor rotate to potrait' A 11 26'0=No Rotation' A 12 25'90, 180, 270 = degrees clockwise r- A otation' A 14 10'Duplex:' DSPATR(HI) A SCDUPLEX 1A B 14 18 A 14 24'Hold:' DSPATR(HI) A SCHOLD 1A B 14 30 A 14 34'Save:' DSPATR(HI) A SCSAVE 1A B 14 40 A 14 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 N10 18 3'Front Overlay:' A N10 SCFOVERLAY 21A O 18 18 A N11 19 3'Back Overlay:' A N11 SCBOVERLAY 21A O 19 18 A 23 2'F3=Exit' COLOR(BLU) A 23 69'F12=Cancel' COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Displays list of spooled file names that meet selection criteria. Select useful options to perform. Uses SPLF0030 format that is faster than WRKSPLF for large sets of spooled files.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRSPLF/SELECT'.Select files for - Help :XH3.Select files for (SELECT) :P.Specifies which group of files is selected to be displayed.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRSPLFR - List spool files with Options // Uses SPLF0300 API format that is way faster than WRKSPLF // parms use likeds to match ELEM scheme of wrksplf //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRSPLFD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define ApiErrDS /define Constants /define Infds /define f_IsValidObj /define FunctionKeys /define Ind /define Dspatr /define Quslspl /define psds /define f_RunOptionSplf /define f_Quscrtus /define f_GetDayName /define f_RmvSflMsg // *ENTRY /define p_JCRSPLFR /COPY JCRCMDS,JCRCMDSCPY dcl-s OptionSav like(sbfoption); dcl-s SflRcdNbrSav like(sflrcdnbr); dcl-s rrnx like(rrn); dcl-s LastRrn like(rrn); dcl-s IsOption4 ind; dcl-s IsRefresh ind; dcl-s tabtyp zoned(2) dim(12) ctdata perrcd(1); dcl-s tabdesc char(4) dim(12) alt(tabtyp); dcl-s IsSndSplf ind; dcl-s IsEsend ind; dcl-c oE const('E=ESndMail '); dcl-c oS const('S=SndSplf '); dcl-c o2 const('2=Change '); dcl-c o3 const('3=Hold '); dcl-c o4 const('4=Delete '); dcl-c o5 const('5=Display'); dcl-pr p_JCRSPLFR2 extpgm('JCRSPLFR2'); *n char(10); // Job Name *n char(10); // User Name *n char(6); // Job Number *n char(10); // Spooled File Name *n zoned(6) const; // Spooled File Number end-pr; //--------------------------------------------------------- scDow = 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 ApiHeadPtr = f_Quscrtus(UserSpaceName); // line up option headings depending on what is installed 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; exsr srRefreshScreen; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2e endif; f_RmvSflMsg(ProgId); // refresh SflRcdNbr = InfdsSflRcdNbr; 2b if InfdsFkey = f05; IsRefresh = *on; SflRcdNbrSav = SflRcdNbr; Ind.sfldsp = *off; Ind.sfldspctl = *off; aoptions1 = %bitor(Green:UL); Ind.sflnxtchg = *off; write sbfctl1; rrn = 0; exsr srRefreshScreen; 2x elseif Ind.sfldsp; // process user requests readc sbfdta1; 3b dow not %eof; 4b if sbfOption > ' '; IsOption4 = (sbfOption = '4'); //--------------------------------------------------------- 5b if InfdsFkey = f13; exsr srRepeat_Option; 3v leave; 5x elseif sbfOption = '7'; //duplicate spooled file callp p_JCRSPLFR2( scJobName: scUserID: scJobNo: scSplfName: scSplno); snd-msg 'Create duplicate + Spooled File ' + %trimr(scSplfName) + ' - completed'; 5x else; f_RunOptionSplf( sbfOption: scSplfName: %editc(scSplno: 'X'): scJobName: scUserID: scJobNo: ProgId); 5e endif; // update subfile to reflect change aoptions1 = %bitor(Green:UL); 5b if sbfOption = '3'; scStatus = 'HLD'; 5x elseif sbfOption = '6'; scStatus = 'RLS'; 5e endif; clear sbfOption; update sbfdta1; // flag deleted spooled file in all views 5b if IsOption4; chain rrn sbfdta1; clear sbfdta1; scSplfName = '*deleted'; aoptions1 = ND; update sbfdta1; 5e endif; SflRcdNbr = rrn; 4e endif; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; //--------------------------------------------------------- // 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 = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.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 %tlookup(splf0300DS.Status: tabtyp: tabdesc); 3x scStatus = tabdesc; 3e endif; scSplfName = splf0300DS.SplfName; scNumPages = splf0300DS.PageNum; scCopies = splf0300DS.Copies; scOutq = splf0300DS.Outq; 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/); scSplfTime = %char(%time(splf0300DS.CreateHHMMSS: *HMS0)); clear sbfOption; rrn += 1; 3b if rrn = 9999; 1v leave; 3e endif; write sbfdta1; 2e endif; splf0300Ptr += ApiHead.ListEntrySize; 1e endfor; Lastrrn = rrn; //--------------------------------------------------------- //--------------------------------------------------------- SflRcdNbr = 1; Ind.sfldsp = (rrn > 0); 1b if (not Ind.sfldsp); snd-msg 'No spooled files match selection'; 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; endsr; //--------------------------------------------------------- // 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; chain rrnx sbfdta1; 2b if not %found; 1v leave; 2e endif; Ind.sflnxtchg = *on; sbfOption = OptionSav; update sbfdta1; 1e endfor; Ind.sflnxtchg = *off; endsr; ** 01RDY 02OPN 03CLO 04SAV 05WTR 06HLD 07MSGW 08PND 09PRT 10FIN 11SND 12DFR ]]> '); //--------------------------------------------------------- // 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. // changing overlay name on afpds file does not change the overlay. // See bottom of discussion at link //http://fixunix.com/ibm-as400/358192-adding-overlay-copied-spooled-file-*afpds-format.html //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Qspclosp /define Qspgetsp /define Qspopnsp /define f_Quscrtus /define f_GetQual /define f_GetDayName /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRSPLFD2 workstn; dcl-s BufferOrdinal int(10) inz(-1); dcl-s p_Splfbin int(10); dcl-s SplfHandle1 int(10); dcl-s SplfHandle2 int(10); // Create Spooled File dcl-pr Qspcrtsp extpgm('QSPCRTSP'); *n int(10); // splf handle *n like(QusrsplaDS); // attributes *n like(ApiErrDS); end-pr; // Create spooled file API requires DS as a parm dcl-ds QusrsplaDS len(4000) qualified inz; IntJobId char(16) pos(17); IntSplfId char(16) pos(33); SpflNum int(10) pos(85); FrmType char(10) pos(89); UsrDta char(10) pos(99); Hold char(10) pos(129); Save char(10) pos(139); TotPages int(10) pos(149); Copies int(10) pos(173); CopiesLeft int(10) pos(177); LPI int(10) pos(181); CPI int(10) pos(185); Outq char(10) pos(191); OutqLib char(10) pos(201); PageRotate int(10) pos(553); Duplex char(10) pos(561); FrontOverlay char(10) pos(737); FrontOverLib char(10) pos(747); BackOverlay char(10) pos(773); BackOverLib char(10) pos(783); AfpdsCreated char(1) pos(2857); end-ds; // Retrieve Spooled File Attributes dcl-pr Qusrspla extpgm('QUSRSPLA'); *n like(QusrsplaDS); // receiver *n int(10) const; // receiver length *n char(8) const; // api format *n char(26) const; // qualified job *n char(16) const; // internal job id *n char(16) const; // internal spool id *n char(10) const; // spool file name *n int(10) const; // spool file Num *n like(ApiErrDS); end-pr; // Put Spooled File Data dcl-pr Qspputsp extpgm('QSPPUTSP'); *n int(10); // splf handle *n char(20); // user space *n like(ApiErrDS); end-pr; // Delete User Space dcl-pr Qusdltus extpgm('QUSDLTUS'); *n char(20); // user space *n like(ApiErrDS); end-pr; //--*ENTRY------------------------------------------------- dcl-pi *n; p_JobName char(10); p_JobUser char(10); p_JobNumber char(6); p_SplfName char(10); p_SplfNumber zoned(6); end-pi; //--------------------------------------------------------- scDow = f_GetDayName(); UserSpaceName = 'JCRSPLFR2 QTEMP'; p_SplfBin = p_SplfNumber; //get into proper format // load spooled file attributes callp QUSRSPLA( QusrsplaDS: %size(QusrsplaDS): '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; scUsrDta = QusrsplaDS.UsrDta; scPagNbr = QusrsplaDS.TotPages; scNumCopys = QusrsplaDS.Copies; scOutq = QusrsplaDS.outq; scPageRot = QusrsplaDS.PageRotate; scDuplex = %subst(QusrsplaDS.Duplex: 2: 1); scHold = %subst(QusrsplaDS.Hold: 2: 1); scSave = %subst(QusrsplaDS.Save: 2: 1); *in10 = *on; 1b if not(QusrsplaDS.FrontOverlay = '*NONE'); *in10 = *off; scfOverLay = f_GetQual(QusrsplaDS.FrontOverlay + QusrsplaDS.FrontOverLib); 1e endif; *in11 = *on; 1b if QusrsplaDS.BackOverlay = '*FRONTOVL'; 2b if not(QusrsplaDS.FrontOverlay = '*NONE'); *in11 = *off; scbOverlay = QusrsplaDS.BackOverlay; 2e endif; 1x elseif not(QusrsplaDS.BackOverlay = '*NONE'); *in11 = *off; scbOverLay = f_GetQual(QusrsplaDS.BackOverlay + QusrsplaDS.BackOverLib); 1e endif; scLPI = QusrsplaDS.LPI; scCPI = QusrsplaDS.CPI/10; exfmt screen; 1b if *inkc or *inkl; *inlr = *on; return; 1e endif; // overlay attributes with screen fields QusrsplaDS.UsrDta = scUsrDta; QusrsplaDS.Copies = scNumCopys; QusrsplaDS.CopiesLeft = scNumCopys; 1b if QusrsplaDS.Outq <> scOutq; QusrsplaDS.OutqLib = '*LIBL '; 1e endif; QusrsplaDS.Outq = scOutq; QusrsplaDS.PageRotate = scPageRot; QusrsplaDS.LPI = scLPI; QusrsplaDS.CPI = scCPI * 10; 1b if scDuplex = 'N'; QusrsplaDS.Duplex = '*NO'; 1x else; QusrsplaDS.Duplex = '*YES'; 1e endif; 1b if scHold = 'N'; QusrsplaDS.Hold = '*NO'; 1x else; QusrsplaDS.Hold = '*YES'; 1e endif; 1b if scSave = 'N'; QusrsplaDS.Save = '*NO'; 1x else; QusrsplaDS.Save = '*YES'; 1e endif; // create new spooled file callp QSPCRTSP( SplfHandle2: QusrsplaDS: ApiErrDS); // create user space f_Quscrtus(UserSpaceName); // open input spooled file callp QSPOPNSP( SplfHandle1: '*INT': QusrsplaDS.IntJobId: QusrsplaDS.IntSplfId: '*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 callp QUSDLTUS( UserSpaceName: ApiErrDS); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRSPLFV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj // *ENTRY /define p_JCRSPLFR /COPY JCRCMDS,JCRCMDSCPY 1b if not(%subst(p.OutqQual: 1: 10) = '*ALL'); f_CheckObj(p.OutqQual: '*OUTQ'); 1e endif; 1b if %scan('*':p.Usrprf) = 0; f_CheckObj(p.Usrprf + 'QSYS': '*USRPRF'); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Scan Interactive SQL sessions') PARM KWD(USERID) TYPE(*CHAR) LEN(10) + DFT(*CURRENT) PROMPT('User ID') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&USER) DCL VAR(&USER) 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(&USER *EQ '*CURRENT') THEN(RTVJOBA + USER(&USER)) OVRPRTF FILE(QPSRVDMP) PRTTXT(*BLANK) + MAXRCDS(*NOMAX) 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 &USER *TCAT '*') DMPSYSOBJ OBJ(&OBJECT) CONTEXT(QRECOVERY) TYPE(19) SUBTYPE(EE) MONMSG MSGID(CPF3502) EXEC(DO) SNDPGMMSG MSG('No system object for user ' *CAT &USER + *TCAT ' found.') RETURN ENDDO CPYSPLF FILE(QPSRVDMP) TOFILE(QTEMP/JCRSSQL) + SPLNBR(*LAST) MBROPT(*REPLACE) /*--------------------------------------------------------------------------*/ CALL PGM(JCRSSQLR) DLTSPLF FILE(QPSRVDMP) SPLNBR(*LAST) MONMSG MSGID(CPF3309) /* deleted already */ DLTOVR FILE(QPSRVDMP) ENDPGM ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA12 A R DATA1 SFL A AOPTIONS 1A P A SBFSQLID 9 0H A SBFOPTION 1A B 5 3 A DSPATR(&AOPTIONS) A VDATA 68A O 5 5 *---------------------------------------------- A R CONTRL1 SFLCTL(DATA1) OVERLAY A SFLPAG(17) SFLSIZ(1717) 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' 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 EDTCDE(Y) 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 SFLPAG(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> '); //--------------------------------------------------------- // JCRSSQLE - execute selected SQL statements // 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. // Get the EXCSQL utility from www.dbg400.net . //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Constants /define f_Runcmd /define f_RtvMsgAPI /define f_IsValidObj /COPY JCRCMDS,JCRCMDSCPY dcl-s Select6 char(6); dcl-s Sql_Request varchar(2500) inz; // Verify Sql Statement Syntax dcl-pr qsQchks extpgm('QSQCHKS'); *n char(32767) const options(*varsize); // i_SqlStmt *n int(10) const; // i_SqlStmtLen *n int(10) const; // i_NumRcds *n char(10) const; // i_Language *n char(32767) const options(*varsize); // i_Options *n char(32767) options(*varsize); // o_stmtInf *n int(10) const; // i_StmtInfLen *n int(10); // o_numRcdsPrc *n like(ApiErrDS); end-pr; dcl-ds SqlOptionDS qualified; *n int(10) inz(1); // number of keys *n int(10) inz(1); // key value *n int(10) inz(10); // length of data *n char(10) inz('*SYS'); // data end-ds; dcl-ds SqlStmtInfoDS qualified inz; MsgFile char(10); MsgFileLib char(10); NumberOfStmt int(10); BytesReturned int(10); FirstByteRecNum int(10); FirstByteColNum int(10); LastByteRecNum int(10); LastByteColNum int(10); ErrorRecNum int(10); ErrorColNum int(10); MessageID char(7); SqlState char(5); LenMsgRplTxt int(10); MsgReplaceText char(128); end-ds; //--------------------------------------------------------- // SQL Column types dcl-c SqlCHAR const(1); dcl-c SqlNUMERIC const(2); dcl-c SqlDECIMAL const(3); dcl-c SqlLONG const(4); dcl-c SqlSHORT const(5); dcl-c SqlFLOAT const(6); dcl-c SqlREAL const(7); dcl-c SqlDOUBLE const(8); dcl-c SqlDATE const(91); dcl-c SqlTIME const(92); dcl-c SqlTIMESTAMP const(93); // Sql constants dcl-c SqlNts const(-3); dcl-c SqlTrue const(1); dcl-c SqlDrop const(1); dcl-c CommitNone const(1); dcl-c SysNaming const(10002); dcl-c AttrCommit const(0); dcl-s SqlNumRcd int(10); dcl-s retCode int(10); dcl-s henv int(10); dcl-s hdbc int(10); dcl-s server char(10) inz('*LOCAL'); dcl-s hstmt int(10); dcl-s cOptVal int(10); // Retrieve Error Information dcl-s sqlState char(5); dcl-s pfNativeErr int(10); dcl-s szErrMsg char(256); dcl-s cbErrMsg int(5); // Set environment attribute dcl-s envAttr int(10); //--------------------------------------------------------- // Allocate Environment Handle dcl-pr SQLAllocEnv int(10) extproc(*dclcase); *n pointer value; // enviroment handle end-pr; dcl-pr SQLBindCol int(10) extproc(*dclcase); *n int(10) value; // statement handle *n int(5) value; // column number *n int(5) value; // data type *n pointer value; // rgb value *n int(10) value; // cb max value *n pointer value; // pcb value end-pr; dcl-pr SQLSetEnvAttr int(10) extproc(*dclcase); *n int(10) value; // enviroment handle *n int(10) value; // attr *n pointer value; // p value *n int(10) value; // strlen end-pr; dcl-pr SQLAllocConnect int(10) extproc(*dclcase); *n int(10) value; // enviroment handle *n pointer value; // ptr to connection end-pr; dcl-pr SQLConnect int(10) extproc(*dclcase); *n int(10) value; // connection handle *n pointer value options(*string); // szdsn *n int(5) value; // cbdsn *n pointer value options(*string); // szuid *n int(5) value; // cbuid *n pointer value options(*string); // szauthstr *n int(5) value; // cbauthstr end-pr; dcl-pr SQLSetConnectOption int(10) extproc(*dclcase); *n int(10) value; // connection handle *n int(5) value; // foption *n pointer value; // vparam end-pr; dcl-pr SQLAllocStmt int(10) extproc(*dclcase); *n int(10) value; // connection handle *n pointer value; // phstmt end-pr; dcl-pr SQLExecDirect int(10) extproc(*dclcase); *n int(10) value; // statement handle *n pointer value options(*string); // szSqlStr *n int(10) value; // cbSqlStr end-pr; dcl-pr SQLFreeStmt int(10) extproc(*dclcase); *n int(10) value; // statement handle *n int(5) value; // foption end-pr; dcl-pr SQLDisconnect int(10) extproc(*dclcase); *n int(10) value; // connection handle end-pr; dcl-pr SQLFreeConnect int(10) extproc(*dclcase); *n int(10) value; // connection handle end-pr; dcl-pr SQLFreeEnv int(10) extproc(*dclcase); *n int(10) value; // rnvironment handle end-pr; dcl-pr SQLError int(10) extproc(*dclcase); *n int(10) value; // environment handle *n int(10) value; // hdbc *n int(10) value; // hstmt *n pointer value; // szSqlState *n pointer value; // pfNativeErr *n pointer value; // szErrMsg *n int(5) value; // cbErrMsgMax *n pointer value; // pcbErrMsg end-pr; //--*ENTRY------------------------------------------------- dcl-pi *n; i_ParmSql char(2500); i_ParmRtnMsg char(75); end-pi; //--------------------------------------------------------- clear i_ParmRtnMsg; Select6 = %subst(i_ParmSql: 1: 6); Select6 = %upper(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); // load return error message, exit program 2b if SqlStmtInfoDS.MessageID > *blanks; 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 not(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; // disconnect and free sql handle ----- retCode = SQLFreeStmt(hstmt: SQLDROP); retCode = SQLDisconnect(hdbc); retCode = SQLFreeConnect(hdbc); retCode = SQLFreeEnv(henv); 2b if i_ParmRtnMsg = *blanks; i_ParmRtnMsg = 'SQL completed normally.'; 2e endif; 1e endif; *inlr = *on; return; //--------------------------------------------------------- // Allocate SQL Environment Handle //--------------------------------------------------------- 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; //--------------------------------------------------------- // Check if the EXCSQL command is on board, // if so use it to run the SELECT statement // If EXCSQL not installed, select statements cannot be run. // This utility can be downloaded at www.dbg400.net // Subroutine code by Martin Rowe. //--------------------------------------------------------- begsr srSELECT; 1b if f_IsValidObj('EXCSQL': '*LIBL': '*CMD'); // 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; f_RunCmd('?excsql sql(' + %trim(Sql_Request) + ')'); 3b if ApiErrDS.BytesReturned > 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; ]]> .*-------------------------------------------------------------------- :P.Searches through interactive SQL sessions for selected criteria! Newest shows first. :P.This utility is extremely useful to cut/paste from the subfile into a STRSQL session, or just to see how something was done. 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, download Martin Rowe's EXCSQL utility from www.dbg400.net . :NT.Must have authority to execute the DMPSYSOBJ command.:ENT.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCRSSQL/USERID'. User ID - Help :XH3.User ID (USERID) :P.Specifies user ID whose interactive SQL sessions are 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 having *ALLOBJ authority. Pull up other user ID interactive SQL sessions. :EPARML. :EHELP. :EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRSSQLR - Scan strsql sessions for sql statements // // Process the dmpsysobj of interactive sql commands. The dump consists of STRSQL // sessions broken in 32 character blocks per record with embedded IBM control characters. // Reconstruct all these short blocks into single sql statements then present a // subfile of sql statements that meet selection criteria. // // This screen is useful to cut/paste from the subfile into a STRSQL session, or // just to see how 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, download the utility EXCSQL from // Martin Rowe's website www.dbg400.net . JCRSSQL will detect if Martin's utility is // installed. // // This utility may be operating system sensitive due to using a system dump file. // Meaning IBM has been known to change the format of dumps on different OS releases. // This program works on current v7 releases. // 09/12/19 sort most recent slq statement first on screen. // 05/05/21 use count id to fetch entire statement for execution //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRSSQLD workstn sfile(data1: rrn1) infds(infds) indds(ind); dcl-f JCRSSQL disk(264) infds(infds2) extfile('QTEMP/JCRSSQL'); /define ApiErrDS /define Constants /define Dspatr /define Infds /define FunctionKeys /define Ind /define psds /define BitMask /define f_RmvSflMsg /define f_SndStatMsg /define f_GetRowColumn /define f_GetDayName /define f_Quscrtus /define Qlgsort /COPY JCRCMDS,JCRCMDSCPY // fields to sort newest sql first on screen dcl-s countid uns(20); dcl-s countline uns(5); dcl-s ListEntryCount like(ApiHead.ListEntryCount); dcl-s ListEntrySize like(ApiHead.ListEntrySize); dcl-s uPtr pointer; dcl-s SequenceAscend int(10) inz(1); dcl-s SequenceDescend int(10) inz(2); dcl-s QuickSort char(200) based(uptr); dcl-s prvid uns(20); dcl-ds dsortds based(uPtr2) qualified; // sort entries descending id uns(20); line uns(5); vdata like(vdata); end-ds; dcl-s isparseid ind; dcl-s execsql char(2500); dcl-s savScRelation like(screlation); dcl-s savScVal1 like(scval1); dcl-s savScVal2 like(scval2); dcl-s WrkSC like(sc); dcl-s Asterisk char(1); dcl-s ConstantPeriod char(50) inz(*all'.'); dcl-s InPrgVary varchar(50) inz; dcl-s InProgressMsg char(50); dcl-s KeysMsg char(75); dcl-s LastStatement char(69) inz('A'); dcl-s LongString varchar(32767) inz; dcl-s RawDumpData char(32); dcl-s ScanStart varchar(64) inz; dcl-s Sql varchar(2500) inz; dcl-s Sql_and_Msg varchar(2500) inz; dcl-s SqlKeyWord char(5); dcl-s SqlMsg char(67); dcl-s SqlWrk varchar(2500) inz; dcl-s StatementStart char(12) inz('TH'); dcl-s UpperCased varchar(2500) inz; dcl-s NextSc uns(10); dcl-s PercentComp uns(10); dcl-s RecordCnt uns(10); dcl-s rrn1 like(rrn); dcl-s sc uns(10); dcl-s TestLen uns(10); dcl-s TwoPercent uns(10); dcl-s xm uns(5); dcl-s xx uns(5); dcl-s IsAllRead ind inz(*off); dcl-s IsDoubleByte ind inz(*off); dcl-s IsStarted ind inz(*off); dcl-s IsFirstTime ind; dcl-ds Infds2; NbrOfRcds int(10) pos(156); MiscFlags char(1) pos(196); end-ds; // Double Byte Character Set - IO data structure dcl-ds DoubleByteChar len(264) qualified inz; NotAuthorized char(20) pos(2); Asterisk char(1) pos(88); DumpText char(32) pos(89); end-ds; // Single Byte Character Set - IO data structure dcl-ds SingleByteChar len(264) qualified inz; NotAuthorized char(20) pos(1); Asterisk char(1) pos(87); DumpText char(32) pos(88); end-ds; // Run SQL dcl-pr p_JCRSSQLE extpgm('JCRSSQLE'); *n char(2500); // sql statement *n char(75); // return message end-pr; //--------------------------------------------------------- IsDoubleByte = (%bitand(bit6: MiscFlags) = bit6); eval(h) TwoPercent = NbrOfRcds/50; scDow = f_GetDayName(); // create user space to hold initial retrieve // so can be sorted descending uPtr = f_Quscrtus(UserSpaceName); isFirstTime = *on; //--------------------------------------------------------- // show subfile / edit check scan requests //--------------------------------------------------------- 1b dow not(InfdsFkey = f03); savScVal1 = scval1; savScRelation = screlation; savScVal2 = scval2; Ind.sfldsp = (rrn1 > 0); 2b if isFirstTime; snd-msg 'Enter Search selections'; 2x elseif not Ind.sfldsp; snd-msg 'No SQL Statements match selection'; 2e endif; isFirstTime = *off; Ind.sfldspctl = *on; write msgctl; write keys; exfmt contrl1; 2b if InfdsFkey in %list(f03 :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); snd-msg '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); snd-msg '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; exsr srWriteSubfile; 1i iter; 2e endif; //--------------------------------------------------------- 2b if (not Ind.sfldsp); //no records 1i iter; 2e endif; //--------------------------------------------------------- readc data1; 2b dow not %eof; 3b if sbfOption > ' '; SflRcdNbr = rrn1; 4b if sbfOption = 'X'; // use count id to rebuild sql string uptr2 = uptr; prvid = dsortds.id; aOptions = %bitor(Green:UL); // reconstruct original sql string isparseid = *off; execsql = *blanks; 5b for ForCount = 1 to ListEntryCount; 6b if isparseid and SBFSQLID <> dsortds.id; 5v leave; 6e endif; 6b if SBFSQLID = dsortds.id; isparseid = *on; execsql = %trimr(execsql) + dsortds.vdata; 6e endif; uPtr2 += ListEntrySize; 5e endfor; //----------------------------- // truncate any completion messages aa = %scan('Msg: ':execsql); 5b if aa > 0; %subst(execsql:aa) = *blanks; 5e endif; callp p_JCRSSQLE(execsql: KeysMsg); 5b if KeysMsg > *blanks; snd-msg 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; //--------------------------------------------------------- // 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. Load next record 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; countid = 0; ListEntryCount = 0; countline = 0; uptr2 = uptr; // reset sorter userspace pointer 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'; snd-msg '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); //--------------------------------------------------------- // 'TH' and 10 blanks and an SQL keyword is // ONLY reliable way to determine start of sql statement // So if found '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 = %upper(SqlKeyWord); 5b if not (SqlKeyWord in %list('SELEC': 'UPDAT':'DELET':'INSER':'CALL':'COMME':'COMMI':'CONNE': 'CREAT':'DISCO':'DROP':'GRANT':'LABEL':'LOCK':'RENAM': 'RELEA':'REVOK':'ROLLB':'ALTER':'SET C':'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); C Next1000 tag xx = 0; 3b dow *on; 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; C NotTrueTH tag nextsc = %scan(StatementStart: LongString: wrksc + 12); //--------------------------------------------------------- // 'TH' and 10 blanks and an SQL keyword is the // ONLY reliable way to determine start of sql statement // So if found '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 = %upper(SqlKeyWord); 6b if not (SqlKeyWord in %list('SELEC':'UPDAT': 'DELET':'INSER':'CALL':'COMME':'COMMI':'CONNE': 'CREAT':'DISCO':'DROP':'GRANT':'LABEL':'LOCK': 'RENAM':'RELEA':'REVOK':'ROLLB':'ALTER':'SET C': 'SET T')); wrksc = nextsc - 10; GO C goto NotTrueTH 6e endif; 5e endif; //--------------------------------------------------------- // (LastStatement) // If nextsc = 0 then there are no more begin statements in file, // there is however the last statement 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. // 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; 8b if testlen <= xm + 14 + 1; SqlMsg = *blanks; 8x else; SqlMsg = %subst(SqlWrk: xm + 14: (TestLen - (xm + 14) + 1)); 8e 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 to filter 6b if not(%upper(Sql) in %list(' ':'SELECT':'DELETE':'UPDATE':'WRKSPLF') or %subst(SqlMsg: 1: 9) = 'Prompting' or %subst(SqlMsg: 1: 22) = 'Session ended abnormal'); // determine if completion message is 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 scans %len(UpperCased) = %len(Sql_and_Msg); UpperCased = %upper(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 srWriteToSortSpace; 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); GO C goto Next1000 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 srWriteToSortSpace; // load into user space so can be sorted descending countid += 1; countline = 0; xx = 1; Sql = %triml(Sql); 1b if %len(Sql) > 0; 2b dou xx > %len(Sql); countline += 1; ListEntryCount += 1; dsortds.id = countid; dsortds.line = countline; dsortds.vdata = %subst(Sql: xx); xx += %size(vdata); uptr2 += %size(dsortds); // set to next space 2e enddo; 1e endif; 1b if SqlMsg > *blanks and SqlMsg <> 'SELECT statement run complete.'; dsortds.id = countid; countline += 1; ListEntryCount += 1; dsortds.line = countline; dsortds.vdata = ' Msg: ' + SqlMsg; uptr2 += %size(dsortds); // set to next space 1e endif; endsr; //--------------------------------------------------------- // now sort the data descending on the id count and // ascending on the line count and load subfile //--------------------------------------------------------- begsr srWriteSubfile; 1b if ListEntryCount > 0; ListEntrySize = %len(dsortds); qlgsortDS.RecordLength = ListEntrySize; qlgsortDS.RecordCount = ListEntryCount; qlgsortDS.NumOfKeys = 2; qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1: 8: 9: SequenceDescend) + f_AddSortKey(9: 3: 9: SequenceAscend); qlgsortDS.BlockLength = %len(%trimr(qlgsortDS)); callp QLGSORT( qlgsortDS: QuickSort: QuickSort: ListEntryCount * ListEntrySize: ListEntryCount * ListEntrySize: ApiErrDS); uptr2 = uptr; prvid = dsortds.id; aOptions = %bitor(Green:UL); 2b for ForCount = 1 to ListEntryCount; 3b if prvid <> dsortds.id; prvid = dsortds.id; aOptions = ND; clear vdata; rrn1 += 1; write data1; aOptions = %bitor(Green:UL); 3e endif; sbfsqlid = dsortds.id; vdata = dsortds.vdata; rrn1 += 1; 3b if rrn1 > 1699; snd-msg '100++ pages returned. Narrow search.'; LV leavesr; 3e endif; write data1; aOptions = ND; uPtr2 += ListEntrySize; 2e endfor; 1e endif; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('SUNDRY programs Selection Menu') ]]> */ /*--------------------------------------------------------------------------*/ 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(&AMSGDTA) TYPE(*CHAR) STG(*DEFINED) LEN(112) DEFVAR(&APIERRDS 17) MONMSG MSGID(CPF0000) CHGVAR VAR(&PROGID) VALUE('JCRSUNDRYC') RMVMSG CLEAR(*ALL) CHGVAR VAR(&V01) VALUE(' 1) Subsystem memory pools list') CHGVAR VAR(&C01) VALUE('jcrsbsdr') CHGVAR VAR(&V02) VALUE(' 2) Print BIG characters example') CHGVAR VAR(&C02) VALUE('jcrmrbig') CHGVAR VAR(&V03) VALUE(' 3) Hex/Biton characters display') CHGVAR VAR(&C03) VALUE('jcrhexchr') CHGVAR VAR(&V04) VALUE(' 4) Hex to Decimal to Hex converter') CHGVAR VAR(&C04) VALUE('jcrhexr') CHGVAR VAR(&V05) VALUE(' 5) License Locks') CHGVAR VAR(&C05) VALUE('jcrlicuse') CHGVAR VAR(&V06) VALUE(' 6) Search Job Schedule Entries') CHGVAR VAR(&C06) VALUE('jcrscde') CHGVAR VAR(&V07) VALUE(' 7) Search Jobd for Lib or Outq or Jobq') CHGVAR VAR(&C07) VALUE('jcrjobd') CHGVAR VAR(&V08) VALUE(' 8) What system name am I on?') CHGVAR VAR(&C08) VALUE('jcrparti') CHGVAR VAR(&V09) VALUE(' 9) Usrprf class/ special authorities list') CHGVAR VAR(&C09) VALUE('jcrusraut') CHGVAR VAR(&V10) VALUE('10) Games') CHGVAR VAR(&C10) VALUE('jcrgames') CHGVAR VAR(&V11) VALUE(' ') CHGVAR VAR(&C11) VALUE(' ') CHGVAR VAR(&V12) VALUE(' ') CHGVAR VAR(&C12) VALUE(' ') CHGVAR VAR(&V13) VALUE('13) Usrprf retrieve email address list') CHGVAR VAR(&C13) VALUE('jcrusremlr') CHGVAR VAR(&V14) VALUE('14) Search + name/text/jobd/outq for Usrprfs') CHGVAR VAR(&C14) VALUE('jcrusers') CHGVAR VAR(&V15) VALUE('15) Binary Clock') CHGVAR VAR(&C15) VALUE('jcrzanim0') CHGVAR VAR(&V16) VALUE('16) Raise the flag') CHGVAR VAR(&C16) VALUE('jcrzanim3') CHGVAR VAR(&V17) VALUE('17) I am with stupid classic') CHGVAR VAR(&C17) VALUE('jcrzanim4') CHGVAR VAR(&V18) VALUE('18) To Boldly Go') CHGVAR VAR(&C18) VALUE('jcrzanim5') CHGVAR VAR(&V19) VALUE('19) Racquetball Server Rotation') CHGVAR VAR(&C19) VALUE('jcrzanim6') 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(&IN06) THEN(WRKSPLF) WHEN COND(&IN10) THEN(CALL PGM(QUSCMDLN)) WHEN COND(&SCOPTION = '1') THEN(DO) CALL PGM(JCRSBSDR) CHGVAR VAR(&PGM) VALUE('JCRSBSDR') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '2') THEN(DO) ?JCRMRBIG MONMSG MSGID(CPF6801) EXEC(DO) ITERATE ENDDO CHGVAR VAR(&PGM) VALUE('JCRMRBIG') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '3') THEN(DO) CALL PGM(JCRHEXCHR) SNDPGMMSG MSG('JCRHEXCHR hex characters completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '4') THEN(DO) CALL PGM(JCRHEXR) SNDPGMMSG MSG('JCRHEXR hex conversion completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '5') THEN(DO) CALL PGM(JCRLICUSE) SNDPGMMSG MSG('JCRLICUSE List license locks completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '6') THEN(DO) ?JCRSCDE MONMSG MSGID(CPF6801) EXEC(DO) RMVMSG CLEAR(*ALL) SNDPGMMSG MSG('JCRSCDE Search Job Schedule Entries + canceled') TOPGMQ(*SAME) ITERATE ENDDO ENDDO /*-------------------------------------------------*/ WHEN COND(&SCOPTION = '7') THEN(DO) JCRJOBD MONMSG MSGID(CPF6801) EXEC(DO) RMVMSG CLEAR(*ALL) SNDPGMMSG MSG('JCRJOBD Search Jobd using selected + Library canceled') TOPGMQ(*SAME) ITERATE ENDDO CHGVAR VAR(&PGM) VALUE('JCRJOBD') CALLSUBR SUBR(SRLASTSPLF) ENDDO /*-------------------------------------------------*/ WHEN COND(&SCOPTION = '8') THEN(DO) JCRPARTI SNDPGMMSG MSG('JCRPARTI Retrieve Partition Info + completed') TOPGMQ(*SAME) ITERATE ENDDO /*-------------------------------------------------*/ WHEN COND(&SCOPTION = '9') THEN(DO) ?JCRUSRAUT MONMSG MSGID(CPF6801) EXEC(DO) RMVMSG CLEAR(*ALL) SNDPGMMSG MSG('JCRUSRAUT List profile + class/authorities canceled') TOPGMQ(*SAME) ITERATE ENDDO CHGVAR VAR(&PGM) VALUE('JCRUSRAUT') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '10') THEN(DO) JCRGAMES ENDDO WHEN COND(&SCOPTION = '13') THEN(DO) CALL PGM(JCRUSREMLR) CHGVAR VAR(&PGM) VALUE('JCRUSREMLR') CALLSUBR SUBR(SRLASTSPLF) ENDDO WHEN COND(&SCOPTION = '14') THEN(DO) JCRUSERS MONMSG MSGID(CPF6801) EXEC(DO) SNDPGMMSG MSG('JCRUSERS Search Usrprfs + canceled') TOPGMQ(*SAME) ITERATE ENDDO ENDDO /*-------------------------------------------------*/ WHEN COND(&SCOPTION = '15') THEN(DO) CALL PGM(JCRZANIM0) SNDPGMMSG MSG('JCRZANIM0 Binary clock completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '16') THEN(DO) CALL PGM(JCRZANIM3) SNDPGMMSG MSG('JCRZANIM3 raise the flag completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '17') THEN(DO) CALL PGM(JCRZANIM4) SNDPGMMSG MSG('JCRZANIM4 I am with stupid completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '18') THEN(DO) CALL PGM(JCRZANIM5) SNDPGMMSG MSG('JCRZANIM5 To Boldly Go completed') TOPGMQ(*SAME) ENDDO WHEN COND(&SCOPTION = '19') THEN(DO) CALL PGM(JCRZANIM6) SNDPGMMSG MSG('JCRZANIM6 Racquetball Server 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 ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A CA03(03) A CA06(06) A CA10(10) A CA12(12) A R SCREEN A OVERLAY A BLINK A 1 2'JCRSUNDRY' A COLOR(BLU) A 1 23'Various and Sundry' A DSPATR(HI) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A V01 45A O 2 3 A C01 10A O 2 49COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A V02 45A O 3 3 A C02 10A O 3 49COLOR(BLU) A V03 45A O 4 3 A C03 10A O 4 49COLOR(BLU) A V04 45A O 5 3 A C04 10A O 5 49COLOR(BLU) A V05 45A O 6 3 A C05 10A O 6 49COLOR(BLU) A V06 45A O 7 3 A C06 10A O 7 49COLOR(BLU) A V07 45A O 8 3 A C07 10A O 8 49COLOR(BLU) A V08 45A O 9 3 A C08 10A O 9 49COLOR(BLU) A V09 45A O 10 3 A C09 10A O 10 49COLOR(BLU) A V10 45A O 11 3 A C10 10A O 11 49COLOR(BLU) A V11 45A O 12 3 A C11 10A O 12 49COLOR(BLU) A V12 45A O 13 3 A C12 10A O 13 49COLOR(BLU) A V13 45A O 14 3 A C13 10A O 14 49COLOR(BLU) A V14 45A O 15 3 A C14 10A O 15 49COLOR(BLU) A V15 45A O 16 3 A C15 10A O 16 49COLOR(BLU) A V16 45A O 17 3 A C16 10A O 17 49COLOR(BLU) A V17 45A O 18 3 A C17 10A O 18 49COLOR(BLU) A V18 45A O 19 3 A C18 10A O 19 49COLOR(BLU) A V19 45A O 20 3 A C19 10A O 20 49COLOR(BLU) A SCOPTION 2A B 22 2 A 22 5'Option' A 22 14'F3=Exit' A COLOR(BLU) A 22 27'F6=Wrksplf' A COLOR(BLU) A 22 42'F10=Command Entry' A COLOR(BLU) *---------------------------------------------------------------- A R MSGSFL SFL SFLMSGRCD(23) A MSGSFLKEY SFLMSGKEY A PROGID SFLPGMQ(10) A R MSGCTL SFLCTL(MSGSFL) A SFLDSP SFLDSPCTL SFLINZ A N14 SFLEND A SFLPAG(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Menu list to select other useful or otherwise entertaining programs.:EHELP.:EPNLGRP. ]]> */ /*--------------------------------------------------------------------------*/ 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)) 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('Scan + Relationship') PARM KWD(STRING2) TYPE(*CHAR) LEN(25) + PROMPT('Scan string 2') 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) 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) ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT A CA03 CA05 CA12 CA13 CA14 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(105) A SFLCSRRRN(&CSRRRN) A 31 SFLDSP A 32 SFLDSPCTL A N32 SFLCLR A N34 SFLEND(*MORE) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A CSRRRN 5S 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 EDTCDE(Y) 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'SpaceName' DSPATR(HI) A 6 16'String' DSPATR(HI) *---------------------------------------------------------------- A R SFOOTER1 OVERLAY BLINK A 23 2'F3=Exit' COLOR(BLU) A 23 16'Click SpaceName to view entire use- A r space.' A 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRUFINDF; CREATE TABLE JCRUFINDF ( SBFNAME CHAR(10) NOT NULL DEFAULT '' , SBFCRTUSR CHAR(10) NOT NULL DEFAULT '' , SBFLASTUDT CHAR(10) NOT NULL DEFAULT '' , SBFSTRING CHAR(61) NOT NULL DEFAULT '' ) RCDFMT JCRUFINDFR ; LABEL ON TABLE JCRUFINDF IS 'Find string in user spaces - outfile jcr' ; LABEL ON COLUMN JCRUFINDF ( SBFNAME TEXT IS 'Space Name' , SBFCRTUSR TEXT IS 'Created By' , SBFLASTUDT TEXT IS 'Last Used' , SBFSTRING TEXT IS 'String Where Found' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRUFINDF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Searches for string(s) in selected user spaces in selected library. A subfile of user space names with selected string is displayed. :NT.This utility is great for searching through ASC Sequel views to find where files are 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, say a string of 1000 X'00' is end of data in user space. If selected 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 to search for in specified user spaces.: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 to search for in specified user spaces.: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'.OutFile - Help :XH3.File (OUTFILE) :P.File and library to receive command output. :P.JCRUFINDF cannot be specified as outfile to receive output.:EHELP. :HELP NAME='JCRUFIND/OUTMBR'.OutMbr - Help :XH3.OutMbr (OUTMBR) :P.File member to receive command output.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCRUFINDR - Find string in user spaces // call APIs to retrieve user space names // use pointer to search user space for string // if found, display or outfile view name // // Original intent was to search through ASC Sequel views to find files where // used. ASC data is always in first 5K or so bytes of user space. // // Performance problem was if 16Meg user space did not contain requested string. // Program was spinning through all 16 million bytes. Arbitrarily, // say string of 1000 X'00' is end of scannable data in user space. If user // spaces have longer strings of nulls then change value OneThousand00 to a higher value. // // V7: Add option to click name in subfile to show entire user space contents //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRUFINDD workstn sfile(sbfdta1: rrn) infds(infds) usropn indds(ind); dcl-f JCRUFINDF usage(*output) extfile(extofile) extmbr(extombr) usropn; /define ApiErrDS /define Constants /define Dspatr /define Infds /define FunctionKeys /define Ind /define Quslobj /define Qusptrus /define Qusrusat /define psds /define f_Quscrtus /define f_BuildString /define f_GetQual /define f_Qusrobjd /define f_RmvSflMsg /define f_SndCompMsg /define f_SndStatMsg /define f_GetRowColumn /define f_GetApiISO /define f_GetDayName /define f_RtvMsgApi // *ENTRY /define p_JCRUFINDR /COPY JCRCMDS,JCRCMDSCPY dcl-s OneThousand00 uns(5) inz(1000); dcl-s savscLib like(scLib); dcl-s savscName like(scName); dcl-s savscRelation like(scRelation); dcl-s savscVal1 like(scVal1); dcl-s savscVal2 like(scVal2); dcl-s ThisUspace char(20); dcl-s EndOfSpace uns(10); dcl-s Hex00Count uns(5); dcl-s xx int(20); dcl-s yy int(20); dcl-s IsAnd1 ind; dcl-s IsAnd2 ind; dcl-s VarySearch1 varchar(25); dcl-s VarySearchLen1 uns(3); dcl-s Upper1 varchar(25); dcl-s VarySearch2 varchar(25); dcl-s VarySearchLen2 uns(3); dcl-s Upper2 varchar(25); dcl-s uSpaceSlice char(25) based(SlicePtr); dcl-s uSpaceChar char(1) based(uCharPtr); dcl-s LastChar char(1); dcl-s ExtOMbr char(10); //-----Show contents of user space ---------------------------- dcl-pr p_JCRUSPACER extpgm('JCRUSPACER'); *n char(20) const; // p_uspacequal end-pr; //--------------------------------------------------------- // Get pointer to user space created in validity checking program callp QUSPTRUS(UserSpaceName: ApiHeadPtr: ApiErrDS); // open either display file or outfile depending 1b if p_Output = '*'; open JCRUFINDD; scDow = 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; //--------------------------------------------------------- 1b if p_Output = '*'; exsr srShowSubfile; 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 JCRUFIND.'); 1e endif; *inlr = *on; return; //--------------------------------------------------------- // load object name list begsr srShowSubfile; SflRcdNbr = 1; 1b dow not(InfdsFkey = f03); savscVal1 = scVal1; savscRelation = scRelation; savscVal2 = scVal2; savScName = scName; savScLib = scLib; Ind.sfldsp = (rrn > 0); 2b if (not Ind.sfldsp); snd-msg 'No strings match selection'; 2e endif; Ind.sfldspctl = *on; csrrrn = 1; write msgctl; write sfooter1; exfmt sbfctl1; 2b if InfdsFkey in %list(f03 :f12); LV leavesr; 2e endif; f_RmvSflMsg(ProgId); ascVal1 = %bitor(Green: UL); ascRelat = %bitor(Green: UL); ascName = %bitor(Green: UL); ascLib = %bitor(Green: UL); // show user space contents if clicked 2b if csrrrn > 0; chain csrrrn sbfdta1; 3b if %found; callp p_JCRUSPACER(SBFNAME + SCLIB); SflRcdNbr = csrrrn; 3e endif; 2e endif; //--------------------------------------------------------- // 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); snd-msg '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); snd-msg '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); snd-msg 'Must enter Name Filter'; 1i iter; 2e endif; 2b if scLib = *blanks; CsrRowColDS = f_GetRowColumn('SCLIB':InfdsFile:InfdsLib:InfdsRcdfmt); asclib = %bitor(White: RI); snd-msg '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); snd-msg '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); 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; SflRcdNbr = 1; 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))); // load user space name list callp QUSLOBJ( UserSpaceName: 'OBJL0100': scName + scLib: '*USRSPC': ApiErrDS); // spin through list by moving QuslobjPtr pointer QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; sbfName = QuslobjDS.ObjNam; ThisUspace = sbfName + QuslobjDS.ObjLib; // Get last used date here, before scanning user space // as scanning alters last used date 2b if p_OutPut = '*OUTFILE'; QusrObjDS = f_QUSROBJD(ThisUspace: '*USRSPC': 'OBJD0400'); sbfCrtUsr = QusrObjDS.CreatedByUser; // user spaces show last used date as last changed date sbfLastUdt = f_GetApiISO(QusrObjDS.ChangeDateTime); 2e endif; // Get pointer to user space callp QUSPTRUS( ThisUspace: SlicePtr: ApiErrDS); 2b if ApiErrDS.BytesReturned > 0; snd-msg ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); 2x else; // Get user space size so do not move pointer past that point callp QUSRUSAT( QusrusatDS: %size(QusrusatDS): 'SPCA0100': ThisUspace: 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 = %upper(%subst(uSpaceSlice:1:VarySearchLen1)); if VarySearchLen2 = 0; Upper2 = *blanks; else; Upper2 = %upper(%subst(uSpaceSlice:1:VarySearchLen2)); endif; 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 += ApiHead.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 compressing multiple spaces // down to one single space to display more. // // 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, stop loading after // 1000 x00s //--------------------------------------------------------- begsr srCompressAndWrite; LastChar = *blanks; sbfString = *blanks; Hex00Count = 0; yy = 0; // find start loading position 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; 1x elseif p_OutPut = '*OUTFILE'; write JCRUFINDFR; 1e endif; endsr; ]]> '); //--------------------------------------------------------- // JCRUFINDV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_CheckObj /define f_Quscrtus /define Quslobj /define f_RtvMsgAPI /define f_SndEscapeMsg /define f_GetQual /define f_BuildString /define f_OutFileCrtDupObj // *ENTRY /define p_JCRUFINDR /COPY JCRCMDS,JCRCMDSCPY //--------------------------------------------------------- f_CheckObj(%subst(p_ScanSpaces: 11: 10) + 'QSYS':'*LIB'); ApiHeadPtr = 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 = ApiHeadPtr + ApiHead.OffSetToList; 1b if ApiHead.ListEntryCount = 0; f_SndEscapeMsg( f_BuildString('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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Search User Profiles') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A CA03 A CA05 A CA08 A CA09 A CA12 A PRINT *---------------------------------------------- A R SBFDTA1 SFL A SFINITLIB 10A H A SFOPT 1A B 6 2 A SFUSRPRF 10A O 6 5 A SFTEXT 39A O 6 16 A SFSTATUS 10A O 6 56 A SFINITPGM 10A O 6 67 A SFJOBD 10A O 6 78 A SFJOBDLIB 10A O 6 89 A SFOUTQ 10A O 6100 A SFOUTQLIB 10A O 6111 A SFLASTUSED 10A O 6122 A SFHOMEDIR 125 O 7 5DSPATR(HI) *---------------------------------------------- A R SBFCTL1 SFLCTL(SBFDTA1) A SFLSIZ(1900) A SFLPAG(0009) A CHANGE(12) A OVERLAY A 31 SFLDSP A 32 SFLDSPCTL A N31 SFLCLR A N34 SFLEND(*MORE) A SFLDROP(CA02) A SFLRCDNBR 4S 0H SFLRCDNBR(CURSOR) A 1 2'JCRUSERS' A COLOR(BLU) A 1 23'Search User Profiles' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 5'PosTo' A COLOR(BLU) A 2 16'(leading space = contains) ' A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 2'2=ChgUsrPrf' A COLOR(BLU) A 3 15'5=DspUsrPrf' A COLOR(BLU) A 3 29'6=Email Address' A COLOR(BLU) A 3 47'7=WrkUsrJOB' A COLOR(BLU) A 3 60'8=Wrksplf' A COLOR(BLU) A 3 72'9=WrkUsrPRF' A COLOR(BLU) A SCUSER 10A B 4 2CHANGE(12) A SCTEXT 40A B 4 16 A SCINIT 10A B 4 67 A SCJOBD 10A B 4 78 A SCOUTQ 10A B 4100 A 5 2'Op' A DSPATR(HI) A DSPATR(UL) A 5 5'User Id ' A DSPATR(HI) A DSPATR(UL) A 5 16'Text - A ' A COLOR(WHT) A DSPATR(UL) A 5 56'Status ' A DSPATR(HI) A DSPATR(UL) A 5 67'Init Pgm ' A DSPATR(HI) A DSPATR(UL) A 5 78'Jobd ' A DSPATR(HI) A DSPATR(UL) A 5100'Outq ' A DSPATR(HI) A DSPATR(UL) A 5123'Last Used ' A DSPATR(HI) A DSPATR(UL) *---------------------------------------------- A R SFOOTER1 A OVERLAY A 26 2'F3=Exit' A COLOR(BLU) A 26 12'F2=Home Directory' A COLOR(BLU) A 26 33'F5=Refresh' A COLOR(BLU) A 26 50'F6=Print' A COLOR(BLU) A 26 65'F8=Wrksplf' A COLOR(BLU) A 26 82'F9=Outfile' A COLOR(BLU) *---------------------------------------------------------------- A R EMAILWIN A CA06 A OVERLAY A WINDOW(3 10 7 110 *NOMSGLIN) A WDWTITLE((*TEXT 'Email Address') (*- A COLOR WHT) (*DSPATR HI)) A WCUSRPRF 10A O 2 2 A WCTEXT 39A O 2 14 A WCADDRESS 100A O 4 2DSPATR(HI) A 6 2'Enter=Proceed' A COLOR(BLU) A WCF6MSG 37A O 6 21COLOR(BLU) *---------------------------------------------- A R ADDDIRE A BLINK A 1 2'JCRUSERS' A COLOR(BLU) A WDTITLE 29A O 1 22DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE A EDTWRD('0 / / ') A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 4'User Profile:' A WCUSRPRF 10A O 3 18 A WCTEXT 39A O 3 29 A 6 4'User Identifier:' A WDUSRID 8A B 6 22 A 01 DSPATR(PC) A 6 34'Descriptive Text shown in WRKDIRE - A list.' A COLOR(BLU) A 8 4'Address:' A WDADDRESS 8A B 8 22 A 02 DSPATR(PC) A 8 34'Descriptive Text. Location perhaps- A .' A COLOR(BLU) A 11 4'Email Address:' A WDBEFORE 24A B 11 22 A 03 DSPATR(PC) A 11 47'@' A DSPATR(HI) A WDAFTER 50A B 11 49 A 04 DSPATR(PC) A WDERRMSG 75A O 17 10DSPATR(HI) *--------------------------------------------------------------------- A R OUTFILEWIN A BLINK A WINDOW(3 10 12 90 *NOMSGLIN) A WDWTITLE((*TEXT 'Outfile') (*COLOR - A WHT) (*DSPATR HI)) A OVERLAY A CSRLOC(CSRROW CSRCOL) A CSRROW 3S 0H A CSRCOL 3S 0H A PTS01 1A P A PTS02 1A P A PTS03 1A P A 2 3'Outfile . . . . . . . . . . . .' A OUTFILE 10A B 2 37 A DSPATR(&PTS01) A 2 52'Name' A 3 5'Library . . . . . . . . . . .' A OUTLIB 10A B 3 39 A DSPATR(&PTS02) A 3 52'Name, *LIBL, *CURLIB' A 4 3'Output member options: ' A 5 5'Member to receive output . . .' A EXTOMBR 10A B 5 37 A 5 52'Name, *FIRST' A 6 5'Replace or add records . . . .' A OUTMBROPT 10A B 6 37 A DSPATR(&PTS03) A 6 52'*REPLACE, *ADD' A 8 4'Press Enter to Proceed' A COLOR(BLU) A ERRMSG 75A O 10 4DSPATR(HI) *---------------------------------------------- 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> -- ---------------------------------------------------------------- -- DROP TABLE JCRUSERSF; CREATE TABLE JCRUSERSF ( SFINITLIB CHAR(10), SFOPT char(1), SFUSRPRF CHAR(10), SFTEXT char(39), SFSTATUS CHAR(10), SFINITPGM CHAR(10), SFJOBD CHAR(10), SFJOBDLIB CHAR(10), SFOUTQ CHAR(10), SFOUTQLIB CHAR(10), SFLASTUSED CHAR(10), WCADDRESS CHAR(100)) RCDFMT JCRUSERSFR ; LABEL ON TABLE JCRUSERSF IS 'Search User Profiles - outfile jcr' ; LABEL ON COLUMN JCRUSERSF ( SFUSRPRF TEXT IS 'User Id' , SFTEXT TEXT IS 'Text' , SFSTATUS TEXT IS 'Status' , SFINITPGM TEXT IS 'Initial Pgm', SFINITLIB TEXT IS 'Initial Lib', SFJOBD TEXT IS 'Jobd' , SFJOBDLIB TEXT IS 'Jobd Lib', SFOUTQ TEXT IS 'Outq', SFOUTQLIB TEXT IS 'Outq Lib', SFLASTUSED TEXT IS 'Last Used', WCADDRESS TEXT IS 'Email' ) ; GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE ON JCRUSERSF TO PUBLIC WITH GRANT OPTION ; ]]> .*-------------------------------------------------------------------- :P.Allows you to search list of user profiles for jobd, outq, initial pgm, etc.. :EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSRJOBD' A 20'Search User Profiles' A SCDOW 9A O 70 A 80DATE EDTCDE(Y) A SCSYSTEM 8A 90 A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'JOBD:' A SCOBJHEAD 105A 8SPACEA(2) *--- A 5'User Id' A 16'Text' A 56'Status' A 67'Init Pgm' A 78'Jobd' A 100'Outq' A 123'Last Used' *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A SFUSRPRF 10A 5 A SFTEXT 39A 16 A SFSTATUS 10A 56 A SFINITPGM 10A 67 A SFJOBD 10A 78 A SFJOBDLIB 10A 89 A SFOUTQ 10A 100 A SFOUTQLIB 10A 111 A SFLASTUSED 10A 122 ]]> '); //--------------------------------------------------------------- // JCRUSERSR - Search User Profiles/ Outq / Jobd / Initial program // (wip) add option to create directory (email entry) if not defined. // add logic to decode ccsid of home directory. Press F2 to see home directory // user space re-purpose note in case I ever try to figure out what I did. // use the OBJL0400 format of object list so the user space entry is // long enough from me to overlay it with user profile info. // I use user space from quslobj to get user profile names, then // repurpose that space with user profile information so I do not // have to reload each time a filter is selected. //--------------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRUSERSF usage(*output) extfile(extofile) extmbr(extombr) usropn; dcl-f JCRUSERSD workstn sfile(sbfdta1:rrn1) infds(infds); dcl-f JCRUSERSP printer oflind(IsOverFlow) usropn; /define psds /define Infds /define Dspatr /define Constants /define FunctionKeys /define f_Quscrtus /define ApiErrDS /define f_GetDayName /define f_GetApiISO /define f_BuildString /define f_RunCmd /define f_RmvSflMsg /define ListAuthorizedUsers /define Quslobj /define f_GetEmail /define f_IsValidObj /define f_IsValidmbr /define f_GetFileLevelID /define f_RtvMsgApi /define f_getqual /define f_GetRowColumn /define f_ConvertCcsid /COPY JCRCMDS,JCRCMDSCPY dcl-s rrn1 uns(5); dcl-s xx uns(5); dcl-s yy uns(5); dcl-s isfirsttime ind; dcl-s IsOk1 ind; dcl-s IsOk2 ind; dcl-s IsOk3 ind; dcl-s IsOk4 ind; dcl-s IsOk5 ind; dcl-s lenscan uns(3); dcl-s upcase char(50); dcl-s extOmbr char(10); //-------------------------- // name screen indicators dcl-ds ind qualified; changes ind pos(12) inz(*off); sfldsp ind pos(31) inz(*off); sfldspctl ind pos(32) inz(*off); end-ds; // overlay portion of user space to store usri info. // I can sort, search, and redisplay without reloading from API dcl-ds Autu0100DS based(QuslobjPtr) qualified; UsrPrf char(10); lastused char(10); Status char(10); Text char(39); Initialpgm char(10); InitialpgmL char(10); Jobd char(10); JobdL char(10); Outq char(10); OutqL char(10); HomeDirectory char(125); end-ds; f_RmvSflMsg(ProgId); scDow = f_GetDayName(); ApiHeadPtr = f_Quscrtus(UserSpaceName); exsr srclearsfl; isfirsttime = *on; //--------------------------------------------------------- //--------------------------------------------------------- 1b dow *on; *in31 = (rrn1 > 0); *in32 = *on; write msgctl; write SFOOTER1; exfmt SBFCTL1; f_RmvSflMsg(ProgId); 2b if InfdsFkey in %list(f03 :f12); *inlr = *on; return; 2x elseif infdsfkey = f05; scuser = *blanks; sctext = *blanks; scinit = *blanks; scjobd = *blanks; scoutq = *blanks; exsr srclearsfl; 2x elseif infdsfkey = f06; exsr srPrint; snd-msg 'Print Completed'; 2x elseif infdsfkey = f08; f_RunCmd('WRKSPLF'); 2x elseif infdsfkey = f09; exsr srOutfile; snd-msg errmsg; 2x elseif *in12; // changes 3b if IsFirsttime; exsr srUserspaceLoad; isfirsttime = *off; 3x else; exsr srUserspaceSearch; 3e endif; //---------------------------------------- 2x elseif (rrn1 > 0); readc sbfdta1; 3b dow not %eof(); 4b if sfopt = '2'; f_RunCmd(f_buildstring( '?CHGUSRPRF USRPRF(&)': sfusrprf)); 4x elseif sfopt = '5'; f_RunCmd(f_buildstring( 'DSPUSRPRF USRPRF(&)': sfusrprf)); 4x elseif sfopt = '6'; wcusrprf = sfusrprf; wctext = sftext; wcAddress = f_GetEmail(sfusrprf); wcF6msg = *blanks; 5b if wcAddress = *blanks; wcAddress = 'User Not Setup In WRKDIRE'; wdtitle = 'Create a Directory Entry'; wcF6msg = 'F6=' + wdtitle; 5x elseif wcAddress = '@'; wcAddress = 'Email Address Not Setup In WRKDIRE'; //---------------------------------------------------- // when have a couple weeks, figure out how to // retrieve user and address from getemail function. // Documentation on QOKSCHD api will make head explode //---------------------------------------------------- // wdtitle = 'Add Email To Directory Entry'; // wcF6msg = 'F6=' + wdtitle; 5e endif; exfmt EMAILWIN; 5b if infdsfkey = f06; exsr srDirectoryEntry; 5e endif; 4x elseif sfopt = '7'; f_RunCmd(f_buildstring( '?WRKUSRJOB USER(&)': sfusrprf)); 4x elseif sfopt = '8'; f_RunCmd(f_buildstring( 'WRKSPLF SELECT(&)': sfusrprf)); 4x elseif sfopt = '9'; f_RunCmd(f_buildstring( 'WRKUSRPRF USRPRF(&)': sfusrprf)); 4e endif; 4b if sfopt > *blanks; clear sfopt; SflRcdNbr = rrn1; 4e endif; update sbfdta1; readc sbfdta1; 3e enddo; 2e endif; 1e enddo; *inlr = *on; //--------------------------------------------------------- // load user profile names into user space. //--------------------------------------------------------- begsr srUserspaceLoad; exsr srclearsfl; callp QUSLOBJ( UserSpaceName: 'OBJL0400': '*ALL QSYS ': '*USRPRF ': ApiErrDS); //--------------------------------------------------------- // get user id then load info from qsyrusri into user space // do initial sbfile load as quickly as possible. //--------------------------------------------------------- QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; // retrieve values from the user profile. callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0300': QuslobjDS.ObjNam: ApiErrDS); Autu0100DS.Usrprf = QuslobjDS.ObjNam; Autu0100DS.LastUsed = f_GetApiISO(Usri0300DS.PrvSignDatTim); Autu0100DS.Status = usri0300DS.status; Autu0100DS.Text = usri0300DS.text; Autu0100DS.Initialpgm = usri0300DS.InitialPgm; Autu0100DS.InitialpgmL = usri0300DS.InitialPgmL; Autu0100DS.Jobd = usri0300DS.Jobd; Autu0100DS.JobdL = usri0300DS.JobdL; Autu0100DS.Outq = usri0300DS.Outq; Autu0100DS.OutqL = usri0300DS.OutqL; // weirdly, home directory info comes back in different ccsid. // turn cartwheels to convert to default 37 ccsid Autu0100DS.HomeDirectory = f_convertccsid( %subst(usri0300DS: usri0300DS.HomeDirectoryOffset + 1: usri0300DS.HomeDirectorylength)); exsr srApplyFilters; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srPrint; open JCRUSERSP; write PrtHead; IsOverFlow = *off; yy = rrn1; 1b for xx = 1 to yy; chain xx sbfdta1; write PrtDetail; 2b if IsOverFlow; write PrtHead; IsOverFlow = *off; 2e endif; 1e endfor; close JCRUSERSP; endsr; //--------------------------------------------------------- begsr srOutfile; errmsg = *blanks; OutMbrOpt = '*REPLACE'; extombr = '*FIRST'; InfdsRcdFmt = 'OUTFILEWIN'; CsrRowColDS = f_GetRowColumn('OUTFILE':InfdsFile:InfdsLib:InfdsRcdfmt); pts01 = %bitor(Green: UL); pts02 = pts01; pts03 = pts01; 1b dou 1 = 2 ; exfmt outfilewin; 2b if *inkc or *inkl; LV leavesr; 2e endif; pts01 = %bitor(Green: UL); pts02 = pts01; pts03 = pts01; 2b if OutMbrOpt = *blanks; OutMbrOpt = '*REPLACE'; 2e endif; 2b if extombr = *blanks; extombr = '*FIRST'; 2e endif; 2b if OutFile = *blanks; errmsg = ('Must select Outfile name'); CsrRowColDS = f_GetRowColumn('OUTFILE':InfdsFile:InfdsLib:InfdsRcdfmt); pts01 = %bitor(Green: RI); 1i iter; 2e endif; 2b if not(OutLib = '*LIBL' or OutLib = '*CURLIB' or f_IsValidObj(OutLib: 'QSYS': '*LIB')); errmsg = 'Library Name Invalid'; CsrRowColDS = f_GetRowColumn('OUTLIB':InfdsFile:InfdsLib:InfdsRcdfmt); pts02 = %bitor(Green: RI); 1i iter; 2e endif; 2b if not (OutMbrOpt in %list('*REPLACE':'*ADD')); errmsg = 'Replace or add records Invalid'; CsrRowColDS = f_GetRowColumn('OUTMBROPT':InfdsFile:InfdsLib:InfdsRcdfmt); pts03 = %bitor(Green: RI); 1i iter; 2e endif; // smurf ApiErrDS.ErrMsgId = *blanks; f_IsValidMbr(Outfile + Outlib: extombr); 2b if ApiErrDS.ErrMsgId = 'CPF9812'; 3b if OutLib = '*LIBL'; errmsg = ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); 1i iter; 3x else; f_RunCmd( f_BuildString('CRTDUPOBJ OBJ(&) FROMLIB(*LIBL) + OBJTYPE(*FILE) TOLIB(&) NEWOBJ(&) + DATA(*NO) CST(*NO) TRG(*NO)': 'JCRUSERSF ': OutLib: OutFile)); 4b if ApiErrDS.BytesReturned > 0; errmsg = ApiErrDS.ErrMsgId + ': Error occurred on CRTPF'; 1i iter ; 4e endif; 4b if extombr = '*FIRST'; extOmbr = OutFile; 4e endif; // note ddl created files can not have all members removed f_RunCmd( f_BuildString('RNMM FILE(&/&) MBR(&) NEWMBR(&)': OutLib: OutFile: 'JCRUSERSF ': extOmbr)); 3e endif; // if File exists but member does not, // make sure member can be added to File. 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; ApiErrDS.ErrMsgId = *blanks; 3b if extombr = '*FIRST'; extOmbr = OutFile; 3e endif; f_RunCmd(f_BuildString('ADDPFM &/& &': OutLib: OutFile: extOmbr)); 3b if (ApiErrDS.ErrMsgId = 'CPF7306'); errmsg = ('Members for OutFile more than MAX allowed.'); 1i iter; 3e endif; 2x elseif ApiErrDS.ErrMsgId > *blanks; errmsg = ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)); 1i iter; 2e endif; 2b if OutMbrOpt = '*REPLACE'; f_RunCmd( f_BuildString('CLRPFM FILE(&/&) MBR(&)': OutLib: OutFile: extOmbr)); 2e endif; // compare record format ID for level check issues 2b if not(f_GetFileLevelID('JCRUSERSF ' + '*LIBL') = f_GetFileLevelID(OutFile + OutLib)); errmsg = f_BuildString('CPF4131: Level check on file & in library &.': OutFile: OutLib); 1i iter; 2e endif; extOfile = f_GetQual(OutFile + OutLib); open JCRUSERSF; yy = rrn1; 2b for xx = 1 to yy; chain xx sbfdta1; wcAddress = f_GetEmail(sfusrprf); 3b if wcAddress = '@'; wcAddress = *blanks; 3e endif; write JCRUSERSFR; 2e endfor; close JCRUSERSF; errmsg = 'Outfile ' + %trimr(extOfile) + ' generated by JCRUSERS'; LV leavesr; 1e enddo; endsr; //--------------------------------------------------------- // spin through user space applying filters //--------------------------------------------------------- begsr srUserspaceSearch; exsr srclearsfl; QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; exsr srApplyFilters; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; endsr; //----------------------- //----------------------- begsr srclearsfl; *in31 = *off; *in32 = *off; write SBFCTL1; *in32 = *on; rrn1 = 0; sfopt = *blanks; SflRcdNbr = 1; endsr; //----------------------- // if first character is blank, then filter is a wild card // if first character <> blank, then trailing is wild card // scuser is position to. // sctext, scinit, scjobd, scoutq is only show these. //----------------------- begsr srApplyFilters; IsOk1 = *off; 1b if scuser > *blanks; 2b if %subst(scuser:1:1)>*blanks; lenscan = %len(%trimr(scuser)); 3b if %subst(Autu0100DS.usrprf:1:lenscan) >= scuser; IsOk1 = *on; 3e endif; 2x else; 3b if %scan(%trim(scuser): Autu0100DS.usrprf: 1) > 0; IsOk1 = *on; 3e endif; 2e endif; 1x else; IsOk1 = *on; 1e endif; //----------------------------- IsOk2 = *off; 1b if sctext > *blanks; upcase = %upper(Autu0100DS.text); 2b if %subst(sctext:1:1)>*blanks; lenscan = %len(%trimr(sctext)); 3b if %subst(upcase:1:lenscan) = sctext; IsOk2 = *on; 3e endif; 2x else; 3b if %scan(%trim(sctext): upcase: 1) > 0; IsOk2 = *on; 3e endif; 2e endif; 1x else; IsOk2 = *on; 1e endif; //----------------------------- IsOk3 = *off; 1b if scinit > *blanks; 2b if %subst(scinit:1:1)>*blanks; lenscan = %len(%trimr(scinit)); 3b if %subst(Autu0100DS.Initialpgm:1:lenscan) = scinit; IsOk3 = *on; 3e endif; 2x else; 3b if %scan(%trim(scinit): Autu0100DS.Initialpgm: 1) > 0; IsOk3 = *on; 3e endif; 2e endif; 1x else; IsOk3 = *on; 1e endif; //----------------------------- IsOk4 = *off; 1b if scjobd > *blanks; 2b if %subst(scjobd:1:1)>*blanks; lenscan = %len(%trimr(scjobd)); 3b if %subst(Autu0100DS.Jobd:1:lenscan) = scjobd; IsOk4 = *on; 3e endif; 2x else; 3b if %scan(%trim(scjobd): Autu0100DS.Jobd: 1) > 0; IsOk4 = *on; 3e endif; 2e endif; 1x else; IsOk4 = *on; 1e endif; //------------------------------------- IsOk5 = *off; 1b if scoutq > *blanks; 2b if %subst(scoutq:1:1)>*blanks; lenscan = %len(%trimr(scoutq)); 3b if %subst(Autu0100DS.Outq:1:lenscan) = scoutq; IsOk5 = *on; 3e endif; 2x else; 3b if %scan(%trim(scoutq): Autu0100DS.Outq: 1) > 0; IsOk5 = *on; 3e endif; 2e endif; 1x else; IsOk5 = *on; 1e endif; 1b if IsOk1 and IsOk2 and IsOk3 and IsOk4 and IsOk5; rrn1 += 1; sfusrprf = Autu0100DS.UsrPrf; sftext = Autu0100DS.text; sfLastUsed = Autu0100DS.lastused; sfstatus = Autu0100DS.status; sfinitpgm = Autu0100DS.Initialpgm; sfinitlib = Autu0100DS.InitialpgmL; sfjobd = Autu0100DS.Jobd; sfjobdlib = Autu0100DS.JobdL; sfoutq = Autu0100DS.Outq; sfoutqlib = Autu0100DS.OutqL; sfhomedir = Autu0100DS.HomeDirectory; write sbfdta1; 1e endif; endsr; //--------------------------------------------------------- //--------------------------------------------------------- begsr srDirectoryEntry; f_RmvSflMsg(ProgId); wdusrid = WCUSRPRF; wdaddress = *blanks; wdbefore = *blanks; wdafter = *blanks; 1b dow *on; exfmt ADDDIRE; *in01 = *off; *in02 = *off; *in03 = *off; *in04 = *off; wderrmsg = *blanks; 2b if InfdsFkey in %list(f03 :f12); snd-msg 'Directory Entry Not Added'; LV leavesr; 2e endif; 2b if wdusrid = *blanks; *in01 = *on; wderrmsg = 'Populate User Indentifier'; 1i iter; 2e endif; 2b if wdaddress = *blanks; *in02 = *on; wderrmsg = 'Populate Address'; 1i iter; 2e endif; 2b if wdbefore = *blanks; *in03 = *on; wderrmsg = '{Populate Email'; 1i iter; 2e endif; 2b if wdafter = *blanks; *in04 = *on; wderrmsg = 'Populate Email'; 1i iter; 2e endif; 2b if %scan('.': wdafter ) = 0; *in04 = *on; wderrmsg = 'Address Needs a Period.'; 1i iter; 2e endif; f_RunCmd('ADDDIRE USRID(' + %trimr(wdusrid) + ' ' + %trimr(wdaddress) + ') USRD(' + qs + %trimr(wctext) + qs + ') USER(' + %trimr(wcusrprf) + ') SYSNAME(*LCL) ' + 'USRDFNFLD((SMTPAUSRID SMTP ' + qs + %trimr(wdbefore) + qs + ') (SMTPDMN SMTP ' + qs + %trimr(wdafter) + qs + ')) MSFSRVLVL(*SYSMS) PREFADR(*SMTP)') ; 2b if ApiErrDS.BytesReturned > 0; wderrmsg = ApiErrDS.ErrMsgId + ': ' + f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal); 1i iter; 2e endif; snd-msg 'Directory Entry Added'; LV leavesr; 1e enddo; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('User Space Data Display') PARM KWD(USERSPACE) TYPE(USERSPACE) MIN(1) + PROMPT('User Space') USERSPACE: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') ]]> *---------------------------------------------------------------- A DSPSIZ(27 132 *DS4) A INDARA CA03 CA12 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'User Space Data Display' 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 EDTCDE(Y) 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(200) 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 EDTCDE(Y) 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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.View contents of selected user space. Values below hex 40 are not shown. Position To any offset or search by character string is provided. 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. ]]> '); //--------------------------------------------------------- // JCRUSPACER - User space data display // 27x132 display size is required to use this utility. // Search is case sensitive. // If large user space size, search function could take a few moments // as each BYTE in the user space must be scanned. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f JCRUSPACED workstn sfile(sbfdta1: rrn) infds(infds) sfile(sbfdta2: rrn2) indds(ind); /define ApiErrDS /define Constants /define Cvthc /define Infds /define Dspatr /define psds /define FunctionKeys /define Ind /define Qusptrus /define Qusrusat /define f_GetDayName /define f_RmvSflMsg /COPY JCRCMDS,JCRCMDSCPY dcl-s ByteFromSpace char(1) based(Ptr1); dcl-s ByteToSubfile char(1) based(Ptr2); dcl-s SpaceString char(40) based(SearchPtr); dcl-s DeepInSpace int(10) inz(1); dcl-s LastFoundCnt int(10); dcl-s SaveDeep int(10) inz(1); dcl-s RcdsToWrite uns(3) inz(1); dcl-s rrnsav like(rrn); dcl-s rrn2 like(rrn); dcl-s SflPag uns(3) inz(21); dcl-s WriteCount uns(3) inz(1); dcl-s SavePtr1 pointer inz(*null); dcl-s uSpacePtr pointer inz(*null); dcl-s IsFound ind; dcl-s IsLastScan ind; dcl-ds HexVal qualified; TopRowHex char(1); BotRowHex char(1); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_uSpaceQual char(20); end-pi; //--------------------------------------------------------- f_RmvSflMsg(ProgId); scDow = f_GetDayName(); // Get pointer to user space callp QUSPTRUS(p_uSpaceQual: uSpacePtr: ApiErrDS); Ptr1 = uSpacePtr; // Get user space size so do not move pointer past that point callp QUSRUSAT( QusrusatDS: %size(QusrusatDS): 'SPCA0100': p_uSpaceQual: ApiErrDS); scSpace = %subst(p_uSpaceQual: 1: 10); scLib = QusrusatDS.SpaceLibrary; scSize = QusrusatDS.SpaceSize; SflRcdNbr = 1; exsr srLoadSubfilePage; //--------------------------------------------------------- 1b dow *on; Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write msgctl; write sfooter1; exfmt sbfctl1; f_RmvSflMsg(ProgId); 2b if InfdsFkey in %list(f03 :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 at cursor location //--------------------------------------------------------- 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 aa = 1 to 100; sbfRecChar = %subst(sbfRecData: aa: 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; snd-msg '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! snd-msg 'Position To is past end of space size'; 4x else; //--------------------------------------------------------- // Load a full subfile record starting 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; snd-msg '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; WriteCount = 1; Ind.sfldsp = *off; Ind.sfldspctl = *off; rrn = 0; write sbfctl1; 1b dow WriteCount <= SflPag and DeepInSpace <= QusrusatDS.SpaceSize; SavePtr1 = Ptr1; SaveDeep = DeepInSpace; 2b for bb = 1 to RcdsToWrite; DeepInSpace = SaveDeep; Ptr2 = %addr(sbfRecData); clear sbfRecData; 3b for aa = 1 to 100; 4b if bb = 1; ByteToSubfile = ByteFromSpace; 4x elseif bb = 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 not(bb = RcdsToWrite); Ptr1 = SavePtr1; 3e endif; 3b if not(bb = 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 pointers 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! aa = %scan(%trimr(scSearch): SpaceString: 1); 2b if aa > 0; IsFound = *on; DeepInSpace = DeepInSpace + aa - 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; ]]> '); //--------------------------------------------------------- // JCRUSPACEV - Validity checking program // note: Retrieving pointers to system domain objects is not allowed at seclvl 40 // ie. Cannot search system domain user spaces //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define Qusptrus /define ApiErrDS /define f_RtvMsgAPI /define f_SndEscapeMsg /COPY JCRCMDS,JCRCMDSCPY dcl-s uSpacePtr pointer inz(*null); //--*ENTRY------------------------------------------------- dcl-pi *n; p_uSpaceQual char(20); end-pi; //--------------------------------------------------------- f_CheckObj(p_uSpaceQual: '*USRSPC'); // check for system domain errors CPF3C48 callp QUSPTRUS(p_uSpaceQual: uSpacePtr: ApiErrDS); 1b if ApiErrDS.BytesReturned > 0; f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' + %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal))); 1e endif; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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(*) VALUES(* *PRINT) PROMPT('Output') ]]> .*-------------------------------------------------------------------- :P.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 or * Display the list.:EHELP.:EPNLGRP. ]]> *---------------------------------------------------------------- *--- 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 70 A 80DATE EDTCDE(Y) A SCSYSTEM 8A 90 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 P_STATUS 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 TEXT33 33A O 99 ]]> '); //--------------------------------------------------------- // JCRUSRAUTR - List user profile class/special authorities // use likeds method to bring in list of entries. cool //--------------------------------------------------------- /define ControlStatements /define psds /define f_Quscrtus /define ApiErrDS /define f_GetApiISO /define f_DisplayLastSplf /define f_GetDayName /define ListAuthorizedUsers /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRUSRAUTP printer oflind(IsOverFlow) usropn; dcl-s xx uns(3); dcl-s IsKeeper ind; dcl-ds PrtfHeading inz; pAuth1; pAuth2; pAuth3; pAuth4; pAuth5; pAuth6; pAuth7; pAuth8; pAuth9; pHeadArry char(9) dim(8) pos(1); end-ds; dcl-ds PrtfDetail; PALLOBJ; PSECADM; PJOBCTL; PSPLCTL; PSAVSYS; PSERVICE; PAUDIT; PIOSYSCH; pDetailArry char(1) dim(8) pos(1); end-ds; dcl-ds entlistds qualified; Count uns(5); Arry char(9) dim(8); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_Class char(7); p_AuthList likeds(entlistds); p_Status char(9); p_Output char(8); end-pi; //--------------------------------------------------------- // load input parms into print fields open JCRUSRAUTP; pClass = p_Class; scDow = f_GetDayName(); pHeadArry = %subarr(p_AuthList.Arry: 1: p_AuthList.Count); write PrtHead; IsOverFlow = *off; // load user profile names into user space ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QSYLAUTU(UserSpaceName: 'AUTU0200': ApiErrDS); Autu0200ptr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; // retrieve values from user profile callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0300': UsrPrf: ApiErrDS); // Check selection conditions IsKeeper = *off; 2b if p_Status = '*ALL' or Usri0300DS.Status = p_Status; 3b if p_Class = '*ALL' or Usri0300DS.UserClass = p_Class; 4b if p_AuthList.Arry(1) = '*ALL'; IsKeeper = *on; 4x else; 5b if (Usri0300DS.SpecialAuthArry(1) = 'Y' and %lookup('*ALLOBJ': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(2) = 'Y' and %lookup('*SECADM': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(3) = 'Y' and %lookup('*JOBCTL': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(4) = 'Y' and %lookup('*SPLCTL': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(5) = 'Y' and %lookup('*SAVSYS': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(6) = 'Y' and %lookup('*SERVICE': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(7) = 'Y' and %lookup('*AUDIT': p_AuthList.Arry: 1: p_AuthList.Count) > 0) or (Usri0300DS.SpecialAuthArry(8) = 'Y' and %lookup('*IOSYSCFG': p_AuthList.Arry: p_AuthList.Count) > 0); IsKeeper = *on; 5e endif; 4e endif; 3e endif; 2e endif; 2b if IsKeeper; LastUsed = f_GetApiISO(Usri0300DS.PrvSignDatTim); 3b for xx = 1 to 8; 4b if Usri0300DS.SpecialAuthArry(xx) = 'Y'; pDetailArry(xx) = 'Y'; 4x else; pDetailArry(xx) = '.'; 4e endif; 3e endfor; pdClass = Usri0300DS.UserClass; Text33 = UsrPrfTxt; write PrtDetail; 3b if IsOverFlow; write PrtHead; IsOverFlow = *off; 3e endif; 2e endif; Autu0200Ptr += ApiHead.ListEntrySize; 1e endfor; close JCRUSRAUTP; f_DisplayLastSplf('JCRUSRAUTR': p_Output); *inlr = *on; ]]> *---------------------------------------------------------------- *--- PAGESIZE(66 132) A R PRTHEAD SKIPB(1) SPACEA(1) A 2'JCRUSREMLR' A 20'User Profile Email Address' A SCDOW 9A O 70 A 80DATE EDTCDE(Y) A SCSYSTEM 8A 90 A 104'Page' A +1PAGNBR EDTCDE(4) SPACEA(1) *--- A 2'User Profile' A 15'Text' A 48'Email Address' SPACEA(1) *---------------------------------------------------------------- A R PRTDETAIL SPACEA(1) A PRTUSER 10A O 2 A PRTTXT 30A O 15 A PRTEMAIL 85A O 48 ]]> '); //--------------------------------------------------------- // JCRUSREMLR - User profile retrieve email address list // EmailAddress = f_GetEmail(UserProfile); // List user profiles with directory entries and have smtp defined. //--------------------------------------------------------- /define ControlStatements /define psds /define ApiErrDS /define Quslobj /define f_Quscrtus /define f_GetDayName /define f_DisplayLastSplf /define f_SndStatMsg /define f_GetEmail /define ListAuthorizedUsers /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRUSREMLP printer oflind(IsOverFlow) usropn; dcl-s EmailAddress char(150); f_SndStatMsg('List user email address - in progress'); open JCRUSREMLP; scDow = f_GetDayName(); write PrtHead; IsOverFlow = *off; // load list of user profile names into user space ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QUSLOBJ( UserSpaceName: 'OBJL0200': '*ALL QSYS': '*USRPRF': ApiErrDS); QuslobjPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; callp QSYRUSRI( Usri0300DS: %len(Usri0300DS): 'USRI0100': QuslobjDS.ObjNam: ApiErrDS); 2b if usri0300DS.status = '*ENABLED '; //------------------------------------------------- EmailAddress = f_GetEmail(QuslobjDS.ObjNam); //------------------------------------------------- // *blanks = user not defined in WRKDIRE. @ = email address not setup in WRKDIRE 3b if not (EmailAddress in %list(' ':'@')); PrtUser = QuslobjDS.ObjNam; PrtTxt = QuslobjDS.ObjText; PrtEmail = EmailAddress; write PrtDetail; 3e endif; 2e endif; QuslobjPtr += ApiHead.ListEntrySize; 1e endfor; close JCRUSREMLP; f_DisplayLastSplf('JCRUSREMLP': '*'); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRVALLIBV - Validity checking program for library name //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); end-pi; //--------------------------------------------------------- 1b if not(%subst(p_ObjQual: 11: 1) = '*'); f_CheckObj(%subst(p_ObjQual:11:10)+'QSYS':'*LIB'); 1e endif; *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRVALMBRV - Validity checking program for lib/file/member //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_Mbr char(10); p_FileQual char(20); end-pi; //--------------------------------------------------------- f_CheckMbr(p_FileQual: p_Mbr); *inlr = *on; return; ]]> '); //--------------------------------------------------------- // JCRVALOBJV - Validity checking program for lib/obj/type //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_ObjQual char(20); p_ObjTyp char(10); end-pi; //--------------------------------------------------------- f_CheckObj(p_ObjQual: p_ObjTyp); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('XML programs selection menu') ]]> */ /*--------------------------------------------------------------------------*/ PGM DCLF FILE(JCRXMLD) MONMSG MSGID(CPF6801) DOUNTIL COND(1 *EQ 2) SNDRCVF RCDFMT(SCREEN) WAIT(*YES) SELECT WHEN COND((&IN03) *OR (&IN12)) THEN(DO) LEAVE ENDDO WHEN COND(&IN06) THEN(WRKSPLF) /*------------------------------------------------------------------------*/ /* the compiler does strange here. I have my ifs directory as a */ /* default in the command, but if that IFS directory name is not on the */ /* install system (which it probably will not be) this program would not */ /* compile. Wrap it in a qcmdexc so it will compile on install system */ /*------------------------------------------------------------------------*/ WHEN COND(&SCOPTION = '1') THEN(DO) CALL PGM(QCMDEXC) PARM('?JCRIFSCPY ' 11) ENDDO WHEN COND(&SCOPTION = '2') THEN(DO) ?XMLSRCFIL ENDDO WHEN COND(&SCOPTION = '3') THEN(DO) ?XMLGEN ENDDO WHEN COND(&SCOPTION = '4') THEN(DO) ?XMLGENCMD ENDDO WHEN COND(&SCOPTION = '5') THEN(DO) ?XMLGENINC ENDDO WHEN COND(&SCOPTION = '6') THEN(DO) ?XMLGENMBR ENDDO WHEN COND(&SCOPTION = '7') THEN(DO) ?XMLSCRIPT ENDDO /*-------------------------------------------------*/ WHEN COND(&SCOPTION = '8') THEN(DO) ?XMLPREVIEW ENDDO ENDSELECT CHGVAR VAR(&SCOPTION) VALUE(' ') ENDDO ENDPGM ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A PRINT A CA03(03) A CA06(06) A CA12(12) *---------------------------------------------------------------- A R SCREEN A OVERLAY A 1 3'JCRXML' A COLOR(BLU) A 1 27'XML programs selection menu' A DSPATR(HI) A 1 72DATE A EDTCDE(Y) A COLOR(BLU) A 2 72SYSNAME A COLOR(BLU) A 3 3'1) JCRIFSCPY - Copy/Install from I- A FS drive' A 5 3'2) XMLSRCFIL - Generate XML for al- A l members in source file' A 7 3'3) XMLGEN - Generate XML source- A member from selected scripting mem- A ber' A 8 3'4) XMLGENCMD - embed command in s- A cripting member' A 9 3'5) XMLGENINC - Include yes/no xml- A installer program in scripting mem- A ber' A 10 3'6) XMLGENMBR - Include selected m- A ember in scripting member' A 12 2'7) XMLSCRIPT - review scripting m- A embers you have created' A 14 2'8) XMLPREVIEW- preview uploaded X- A ML scripts before install (recommen- A ded)' A SCOPTION 2A B 22 2 A 22 7'Option' A 22 18'F3=Exit' A COLOR(BLU) A 22 37'F6=Show Spooled Files' A COLOR(BLU) ]]> .*-------------------------------------------------------------------- :P.Menu list to select XML programs.:EHELP.:EPNLGRP. ]]> '); //---------------------------------------------------------- // 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. // use dataq to monitor if command key was pressed as there is no display file read //---------------------------------------------------------- /define ControlStatements /define f_GetDayName /define usleep /define qdtaqproto /define f_RunCmd /define ApiErrDS /define FunctionKeys /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRZANIM0D workstn infds(infds) usropn; dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s PreviousSecond uns(3); dcl-s CurrTime time inz; dcl-s BitPlace uns(3); // binary clock face 3d array dcl-ds BitPlacex qualified template; row char(9) dim(5); end-ds; dcl-ds HmsLine dim(3) qualified based(DspPtr); BitPlace likeds(BitPlacex) dim(6); end-ds; dcl-s DspPtr pointer inz(%addr(DspDs)); dcl-ds HmsAtr dim(3) qualified based(AtrPtr); BitPlace char(1) dim(6); end-ds; dcl-s AtrPtr pointer inz(%addr(AtrDs)); dcl-ds DspDS; Grid16Row1; Grid16Row2; Grid16Row3; Grid16Row4; Grid16Row5; Grid15Row1; Grid15Row2; Grid15Row3; Grid15Row4; Grid15Row5; Grid14Row1; Grid14Row2; Grid14Row3; Grid14Row4; Grid14Row5; Grid13Row1; Grid13Row2; Grid13Row3; Grid13Row4; Grid13Row5; Grid12Row1; Grid12Row2; Grid12Row3; Grid12Row4; Grid12Row5; Grid11Row1; Grid11Row2; Grid11Row3; Grid11Row4; Grid11Row5; Grid26Row1; Grid26Row2; Grid26Row3; Grid26Row4; Grid26Row5; Grid25Row1; Grid25Row2; Grid25Row3; Grid25Row4; Grid25Row5; Grid24Row1; Grid24Row2; Grid24Row3; Grid24Row4; Grid24Row5; Grid23Row1; Grid23Row2; Grid23Row3; Grid23Row4; Grid23Row5; Grid22Row1; Grid22Row2; Grid22Row3; Grid22Row4; Grid22Row5; Grid21Row1; Grid21Row2; Grid21Row3; Grid21Row4; Grid21Row5; Grid36Row1; Grid36Row2; Grid36Row3; Grid36Row4; Grid36Row5; Grid35Row1; Grid35Row2; Grid35Row3; Grid35Row4; Grid35Row5; Grid34Row1; Grid34Row2; Grid34Row3; Grid34Row4; Grid34Row5; Grid33Row1; Grid33Row2; Grid33Row3; Grid33Row4; Grid33Row5; Grid32Row1; Grid32Row2; Grid32Row3; Grid32Row4; Grid32Row5; Grid31Row1; Grid31Row2; Grid31Row3; Grid31Row4; Grid31Row5; end-ds; dcl-ds ATRDS; atr16; atr15; atr14; atr13; atr12; atr11; atr26; atr25; atr24; atr23; atr22; atr21; atr36; atr35; atr34; atr33; atr32; atr31; end-ds; //--------------------------------------------------------- scDow = f_GetDayName(); f_RunCmd('CRTDTAQ DTAQ(QTEMP/JCRZANIM0) ' + 'MAXLEN(80) SEQ(*FIFO)'); 1b if ApiErrDS.BytesReturned > 0; callp QCLRDTAQ('JCRZANIM0 ':'QTEMP'); 1e endif; f_RunCmd('OVRDSPF FILE(JCRZANIM0D) DTAQ(QTEMP/JCRZANIM0) + OVRSCOPE(*JOB)'); open JCRZANIM0D; 1b dow *on; 2b dou not(eSecond = PreviousSecond); usleep(50000); // check every half second 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); //------------------------------------------------------- // read data queue to see if dspf is signaling f3 or f12 callp qrcvdtaq( 'JCRZANIM0': 'QTEMP': 80: dtaqEntry: 0); 2b if %subst(dtaqEntry:1:5) = '*DSPF'; read JCRZANIM0D; 3b if InfdsFkey in %list(f03 :f12); 1v leave; 3e endif; 2e endif; //------------------------------------------------------- write clockd; 1e enddo; close JCRZANIM0D; f_RunCmd('DLTOVR FILE(JCRZANIM0D LVL(*JOB)'); *inlr = *on; //--------------------------------------------------------- // Load characters and attributes for binary values // As first 0 is set to 1, every thing before that position = 0 // works slick. //--------------------------------------------------------- dcl-proc f_FillGrid; dcl-pi *n; pLine uns(3) const; pValue packed(2); end-pi; dcl-s binary uns(3) inz dim(6); dcl-s xx uns(3); dcl-s yy uns(3); dcl-s zz uns(3); dcl-c White const(x'22'); dcl-c Pink const(x'38'); 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; HmsAtr(pLine).BitPlace(BitPlace) = Pink; HmsLine(pLine).BitPlace(BitPlace).Row = %list( ' 111 ': ' 11 ': ' 11 ': ' 11 ': ' 111111'); 2x else; HmsAtr(pLine).BitPlace(BitPlace) = White; HmsLine(pLine).BitPlace(BitPlace).Row = %list( ' 00000': ' 00 00': ' 00 00': ' 00 00': ' 00000'); 2e endif; 1e endfor; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA12 A R CLOCKD A INVITE 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 EDTCDE(Y) COLOR(BLU) A 3 3'Hour' COLOR(BLU) A GRID11ROW1 9A O 4 3DSPATR(&ATR11) A GRID12ROW1 9A O 4 15DSPATR(&ATR12) A GRID13ROW1 9A O 4 27DSPATR(&ATR13) A GRID14ROW1 9A O 4 39DSPATR(&ATR14) A GRID15ROW1 9A O 4 51DSPATR(&ATR15) A GRID16ROW1 9A O 4 63DSPATR(&ATR16) A GRID11ROW2 9A O 5 3DSPATR(&ATR11) A GRID12ROW2 9A O 5 15DSPATR(&ATR12) A GRID13ROW2 9A O 5 27DSPATR(&ATR13) A GRID14ROW2 9A O 5 39DSPATR(&ATR14) A GRID15ROW2 9A O 5 51DSPATR(&ATR15) A GRID16ROW2 9A O 5 63DSPATR(&ATR16) A GRID11ROW3 9A O 6 3DSPATR(&ATR11) A GRID12ROW3 9A O 6 15DSPATR(&ATR12) A GRID13ROW3 9A O 6 27DSPATR(&ATR13) A GRID14ROW3 9A O 6 39DSPATR(&ATR14) A GRID15ROW3 9A O 6 51DSPATR(&ATR15) A GRID16ROW3 9A O 6 63DSPATR(&ATR16) A EHOUR 2 0O 6 76DSPATR(HI) A GRID11ROW4 9A O 7 3DSPATR(&ATR11) A GRID12ROW4 9A O 7 15DSPATR(&ATR12) A GRID13ROW4 9A O 7 27DSPATR(&ATR13) A GRID14ROW4 9A O 7 39DSPATR(&ATR14) A GRID15ROW4 9A O 7 51DSPATR(&ATR15) A GRID16ROW4 9A O 7 63DSPATR(&ATR16) A GRID11ROW5 9A O 8 3DSPATR(&ATR11) A GRID12ROW5 9A O 8 15DSPATR(&ATR12) A GRID13ROW5 9A O 8 27DSPATR(&ATR13) A GRID14ROW5 9A O 8 39DSPATR(&ATR14) A GRID15ROW5 9A O 8 51DSPATR(&ATR15) A GRID16ROW5 9A O 8 63DSPATR(&ATR16) A 10 3'Minute' COLOR(BLU) A GRID21ROW1 9A O 11 3DSPATR(&ATR21) A GRID22ROW1 9A O 11 15DSPATR(&ATR22) A GRID23ROW1 9A O 11 27DSPATR(&ATR23) A GRID24ROW1 9A O 11 39DSPATR(&ATR24) A GRID25ROW1 9A O 11 51DSPATR(&ATR25) A GRID26ROW1 9A O 11 63DSPATR(&ATR26) A GRID21ROW2 9A O 12 3DSPATR(&ATR21) A GRID22ROW2 9A O 12 15DSPATR(&ATR22) A GRID23ROW2 9A O 12 27DSPATR(&ATR23) A GRID24ROW2 9A O 12 39DSPATR(&ATR24) A GRID25ROW2 9A O 12 51DSPATR(&ATR25) A GRID26ROW2 9A O 12 63DSPATR(&ATR26) A GRID21ROW3 9A O 13 3DSPATR(&ATR21) A GRID22ROW3 9A O 13 15DSPATR(&ATR22) A GRID23ROW3 9A O 13 27DSPATR(&ATR23) A GRID24ROW3 9A O 13 39DSPATR(&ATR24) A GRID25ROW3 9A O 13 51DSPATR(&ATR25) A GRID26ROW3 9A O 13 63DSPATR(&ATR26) A EMINUTE 2 0O 13 76DSPATR(HI) A GRID21ROW4 9A O 14 3DSPATR(&ATR21) A GRID22ROW4 9A O 14 15DSPATR(&ATR22) A GRID23ROW4 9A O 14 27DSPATR(&ATR23) A GRID24ROW4 9A O 14 39DSPATR(&ATR24) A GRID25ROW4 9A O 14 51DSPATR(&ATR25) A GRID26ROW4 9A O 14 63DSPATR(&ATR26) A GRID21ROW5 9A O 15 3DSPATR(&ATR21) A GRID22ROW5 9A O 15 15DSPATR(&ATR22) A GRID23ROW5 9A O 15 27DSPATR(&ATR23) A GRID24ROW5 9A O 15 39DSPATR(&ATR24) A GRID25ROW5 9A O 15 51DSPATR(&ATR25) A GRID26ROW5 9A O 15 63DSPATR(&ATR26) A 17 3'Second' COLOR(BLU) A GRID31ROW1 9A O 18 3DSPATR(&ATR31) A GRID32ROW1 9A O 18 15DSPATR(&ATR32) A GRID33ROW1 9A O 18 27DSPATR(&ATR33) A GRID34ROW1 9A O 18 39DSPATR(&ATR34) A GRID35ROW1 9A O 18 51DSPATR(&ATR35) A GRID36ROW1 9A O 18 63DSPATR(&ATR36) A GRID31ROW2 9A O 19 3DSPATR(&ATR31) A GRID32ROW2 9A O 19 15DSPATR(&ATR32) A GRID33ROW2 9A O 19 27DSPATR(&ATR33) A GRID34ROW2 9A O 19 39DSPATR(&ATR34) A GRID35ROW2 9A O 19 51DSPATR(&ATR35) A GRID36ROW2 9A O 19 63DSPATR(&ATR36) A GRID31ROW3 9A O 20 3DSPATR(&ATR31) A GRID32ROW3 9A O 20 15DSPATR(&ATR32) A GRID33ROW3 9A O 20 27DSPATR(&ATR33) A GRID34ROW3 9A O 20 39DSPATR(&ATR34) A GRID35ROW3 9A O 20 51DSPATR(&ATR35) A GRID36ROW3 9A O 20 63DSPATR(&ATR36) A ESECOND 2 0O 20 76DSPATR(HI) A GRID31ROW4 9A O 21 3DSPATR(&ATR31) A GRID32ROW4 9A O 21 15DSPATR(&ATR32) A GRID33ROW4 9A O 21 27DSPATR(&ATR33) A GRID34ROW4 9A O 21 39DSPATR(&ATR34) A GRID35ROW4 9A O 21 51DSPATR(&ATR35) A GRID36ROW4 9A O 21 63DSPATR(&ATR36) A GRID31ROW5 9A O 22 3DSPATR(&ATR31) A GRID32ROW5 9A O 22 15DSPATR(&ATR32) A GRID33ROW5 9A O 22 27DSPATR(&ATR33) A GRID34ROW5 9A O 22 39DSPATR(&ATR34) A GRID35ROW5 9A O 22 51DSPATR(&ATR35) A GRID36ROW5 9A O 22 63DSPATR(&ATR36) A 24 2'F3=Exit' COLOR(BLU) A 24 69'F12=Cancel' COLOR(BLU) ]]> '); //--------------------------------------------------------- // JCRZANIM3 - raise USA flag //--------------------------------------------------------- /define ControlStatements /define usleep /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRZANIM3D workstn; //--------------------------------------------------------- wpos = 2; 1b for wlin = 10 downto 5; write screen; usleep(80000); // delay milliseconds 1e endfor; exfmt screen; 1b for wlin = 5 to 10; write screen; usleep(80000); // delay milliseconds 1e endfor; *inlr = *on; return; ]]> *---------------------------------------------------------------- A CA03 CA12 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 1 9' * * * * * * * * * * ' A DSPATR(HI RI CS BL) A STRIPE01 34A 1 31DSPATR(RI BL) A 2 9' * * * * * * * * * * ' A DSPATR(HI RI CS BL) A STRIPE02 34A 2 31DSPATR(HI RI) A 3 9' * * * * * * * * * * ' A DSPATR(HI RI CS BL) A STRIPE03 34A 3 31DSPATR(RI BL) A 4 9' * * * * * * * * * * ' A DSPATR(HI RI CS BL) A STRIPE04 34A 4 31DSPATR(HI RI) A 5 9' * * * * * * * * * * ' A DSPATR(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) ]]> '); //--------------------------------------------------------- // JCRZANIM4 - Animation- classic I'm With Stupid pointing finger //--------------------------------------------------------- /define ControlStatements /define Dspatr /define usleep /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRZANIM4D workstn; dcl-s cc uns(3); dcl-s col uns(3); dcl-s DoCount uns(3); dcl-s SpinCount uns(3); dcl-s aText char(11); dcl-s xx uns(3); dcl-s FingArry char(11) dim(14); dcl-ds GridRow dim(11) qualified based(ptr); col char(1) dim(48); end-ds; dcl-s Ptr pointer inz(%addr(LIN001)); // map screen fields into DS so arrays can manipulate values dcl-ds *n; LIN001; LIN002; LIN003; LIN004; LIN005; LIN006; LIN007; LIN008; LIN009; LIN010; LIN011; end-ds; FingArry = %list( ' XX ': ' X X ': ' X XXX ': ' X X X ': ' X X XXXX ': ' X X X X X': 'XX X X X X': 'X X X X X': 'X X X': 'X X': ' X X ': ' X X ': ' XXXXXX ': ' X X '); //--------------------------------------------------------- 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; 1b for cc = 1 to 10; atr01 = White; write screen; usleep(50000); // delay milliseconds atr01 = Red; write screen; usleep(50000); atr01 = Blue; write screen; usleep(50000); 1e endfor; exfmt screen; *inlr = *on; //--------------------------------------------------------- // 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(5).col(2) = 'X' // so I would have X // X on the screen //--------------------------------------------------------- begsr srWriteScreen; 1b for cc = 1 to 11; // number of lines on screen GridRow(cc).Col(col) = %subst(aText:cc:1); 1e endfor; col -= 1; write screen; endsr; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A CA03 CA12 A R SCREEN A ATR01 1A P A LIN001 48A O 3 3DSPATR(&ATR01) A LIN002 48A O 4 3DSPATR(&ATR01) A IM 3A O 4 57DSPATR(HI) A LIN003 48A O 5 3DSPATR(&ATR01) A 5 57'WITH' DSPATR(HI) A LIN004 48A O 6 3DSPATR(&ATR01) A 6 57'STUPID' DSPATR(HI) A LIN005 48A O 7 3DSPATR(&ATR01) A LIN006 48A O 8 3DSPATR(&ATR01) A LIN007 48A O 9 3DSPATR(&ATR01) A LIN008 48A O 10 3DSPATR(&ATR01) A LIN009 48A O 11 3DSPATR(&ATR01) A LIN010 48A O 12 3DSPATR(&ATR01) A LIN011 48A O 13 3DSPATR(&ATR01) ]]> '); //--------------------------------------------------------- // JCRZANIM5 - scrolling text on random star field // use dataq to monitor if command key was pressed as there is no display file read //--------------------------------------------------------- /define ControlStatements /define f_CenterText /define f_GetRandom /define qdtaqproto /define f_RunCmd /define ApiErrDS /define FunctionKeys /define usleep /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRZANIM5D workstn sln(lineno) infds(infds) usropn; dcl-ds Infds; InfdsFkey char(1) pos(369); end-ds; dcl-s LineNo packed(2); dcl-s StarsPerLine uns(3); dcl-s xx uns(3); dcl-s MsgElement char(61); //--------------------------------------------------------- dcl-s Msg char(61) dim(7); msg = %list('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 person has gone before ...': '... www.jcrcmds.com ...'); f_RunCmd('CRTDTAQ DTAQ(QTEMP/JCRZANIM5) ' + 'MAXLEN(80) SEQ(*FIFO)'); 1b if ApiErrDS.BytesReturned > 0; callp QCLRDTAQ('JCRZANIM5 ':'QTEMP'); 1e endif; f_RunCmd('OVRDSPF FILE(JCRZANIM5D) DTAQ(QTEMP/JCRZANIM5) + OVRSCOPE(*JOB)'); open JCRZANIM5D; //--------------------------------------------------------- 1b for-each MsgElement in Msg; *in10 = *off; // highlight text // 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(61): 1) = '*'; 3e endfor; write DspRow; 2e endfor; // load text from array to screen field LineNo = 11; aText = f_CenterText(MsgElement:61); *in10 = *on; write DspRow; sleep(2); // delay seconds //------------------------------------------------------- // read data queue to see if dspf is signaling f3 or f12 callp qrcvdtaq( 'JCRZANIM5': 'QTEMP': 80: dtaqEntry: 0); 2b if %subst(dtaqEntry:1:5) = '*DSPF'; read JCRZANIM5D; 3b if InfdsFkey in %list(f03 :f12); 1v leave; 3e endif; 2e endif; //------------------------------------------------------- 1e endfor; close JCRZANIM5D; f_RunCmd('DLTOVR FILE(JCRZANIM5D LVL(*JOB)'); *inlr = *on; return; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3) A CA03 CA12 A R DSPROW SLNO(*VAR) OVERLAY CLRL(*NO) A INVITE A ATEXT 78 1 2 A 10 DSPATR(HI) ]]> '); //--------------------------------------------------------- // JCRZANIM6 - Animation- Racquetball cutthroat serve rotate // Screen showing proper rotation of players during serve changes. // This ensures that all players will play all positions against all other players. //--------------------------------------------------------- /define ControlStatements /define FunctionKeys /define f_GetDayName /define Dspatr /COPY JCRCMDS,JCRCMDSCPY dcl-f JCRZANIM6D workstn infds(infds); dcl-ds Infds; fkey char(1) pos(369); end-ds; dcl-s RotateCnt uns(3); dcl-s row uns(3); dcl-s col uns(3); // row, column, then 5 lines 3d array dcl-ds DspColx qualified template; DspLine char(8) dim(5); end-ds; dcl-ds DspCol likeds(DspColx) dim(3) based(ptr1); dcl-s ptr1 pointer inz(%addr(DspDs)); dcl-ds DspDS; Grid1Row1; Grid1Row2; Grid1Row3; Grid1Row4; Grid1Row5; Grid2Row1; Grid2Row2; Grid2Row3; Grid2Row4; Grid2Row5; Grid3Row1; Grid3Row2; Grid3Row3; Grid3Row4; Grid3Row5; end-ds; dcl-s AtrPos char(1) dim(3) based(ptr2); dcl-s ptr2 pointer inz(%addr(AtrDs)); dcl-ds ATRDS; Atr1; Atr2; Atr3; end-ds; //--------------------------------------------------------------- dcl-ds ServeCnt dim(7) qualified based(ptr3); col char(1) dim(4); end-ds; dcl-s ptr3 pointer inz(%addr(C11)); dcl-ds ServeCntA dim(7) likeds(ServeCnt) based(ptr4); dcl-s ptr4 pointer inz(%addr(C11a)); dcl-ds *n; c11; c12; c13; c14; c21; c22; c23; c24; c31; c32; c33; c34; c41; c42; c43; c44; c51; c52; c53; c54; c61; c62; c63; c64; c71; c72; c73; c74; C11A; C12A; C13A; C14A; C21A; C22A; C23A; C24A; C31A; C32A; C33A; C34A; C41A; C42A; C43A; C44A; C51A; C52A; C53A; C54A; C61A; C62A; C63A; C64A; C71A; C72A; C73A; C74A; end-ds; scDow = f_GetDayName(); //--------------------------------------------------------- // six rotations for all players to play all positions 1b for rotateCnt = 1 to 6; 2b if RotateCnt = 1; 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; *in01=*on; *in02=*off; *in03=*off; 2x elseif RotateCnt = 2; 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; *in01=*off; *in02=*on; *in03=*off; 2x elseif RotateCnt = 3; 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; 2x elseif RotateCnt = 4; 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; *in01=*on; *in02=*off; *in03=*off; 2x elseif RotateCnt = 5; 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; *in01=*off; *in02=*off; *in03=*on; 2x elseif RotateCnt = 6; 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; 2e endif; exsr srShowServeCnt; exfmt screen; 2b if fkey in %list(f03 :f12); *inlr = *on; return; 2e endif; 2b if RotateCnt = 6; RotateCnt = 0; 2e endif; 1e endfor; //--------------------------------------------------------- //--------------------------------------------------------- begsr srShowServeCnt; ServeCnt = f_LoadServeCnt(RotateCnt); 1b for col = 1 to 4; 2b for row = 1 to 7; 3b if ServeCnt(row).Col(col) > ' '; ServeCntA(row).Col(col) = %bitor(Blue: RI); 3x else; ServeCntA(row).Col(col) = ND; 3e endif; 2e endfor; 1e endfor; endsr; //--------------------------------------------------------- // Return 5 X 8 array of selected character dcl-proc f_FillGrid; dcl-pi *n char(8) dim(5); pBaseChar char(1) const; end-pi; dcl-s Line char(8) dim(5); 1b if pBaseChar = 'A'; Line(*) = %list( ' AA ': ' AA AA ': 'AAAAAAAA': 'AA AA': 'AA AA'); 1x elseif pBaseChar = 'B'; Line = %list( 'BBBBBBB ': 'BB BB': 'BBBBBB ': 'BB BB': 'BBBBBBB '); 1x elseif pBaseChar = 'C'; Line = %list( ' CCCCC': ' CCC ': 'CCC ': ' CCC ': ' CCCCC'); 1e endif; return Line; end-proc; //--------------------------------------------------------- // Return 7 row X 4 column array serve count //--------------------------------------------------------- dcl-proc f_LoadServeCnt; dcl-pi *n char(4) dim(7); pBaseNum uns(3); end-pi; dcl-s Line char(4) dim(7); 1b if pBaseNum = 1; Line(*) = ' 1'; Line(1) = ' 11 '; Line(7) = ' 111'; 1x elseif pBaseNum = 2; line = %list( '222 ': ' 2': ' 2': ' 22 ': '2 ': '2 ': '2222'); 1x elseif pBaseNum = 3; line = %list( '333 ': ' 3': ' 3': ' 333': ' 3': ' 3': '333 '); 1x elseif pBaseNum = 4; line = %list( ' 44': ' 4 4': '4 4': '4444': ' 4': ' 4': ' 4'); 1x elseif pBaseNum = 5; line = %list( ' 555': '5 ': '5 ': ' 555': ' 5': ' 5': '5555'); 1x elseif pBaseNum = 6; line = %list( ' 666': '6 ': '6 ': '666 ': '6 6': '6 6': ' 66 '); 1e endif; return Line; end-proc; ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 - A 27 132 *DS4) A CA03 A CA12 A R SCREEN A*%%TS SD 20220524 074512 DP_RUTLEDG REL-V7R3M0 5770-WDS A ATR1 1A P A ATR2 1A P A ATR3 1A P A C11A 1A P A C12A 1A P A C13A 1A P A C14A 1A P A C21A 1A P A C22A 1A P A C23A 1A P A C24A 1A P A C31A 1A P A C32A 1A P A C33A 1A P A C34A 1A P A C41A 1A P A C42A 1A P A C43A 1A P A C44A 1A P A C51A 1A P A C52A 1A P A C53A 1A P A C54A 1A P A C61A 1A P A C62A 1A P A C63A 1A P A C64A 1A P A C71A 1A P A C72A 1A P A C73A 1A P A C74A 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 A EDTCDE(Y) A COLOR(BLU) A 3 8'----------------------------------- A ---' A COLOR(BLU) A GRID1ROW1 8A O 4 23DSPATR(&ATR1) A GRID1ROW2 8A O 5 23DSPATR(&ATR1) A GRID1ROW3 8A O 6 23DSPATR(&ATR1) A 6 53'Server Sequence' A GRID1ROW4 8A O 7 23DSPATR(&ATR1) A 7 53'A starts' A COLOR(WHT) A GRID1ROW5 8A O 8 23DSPATR(&ATR1) A 8 53'B serves after A' A COLOR(YLW) A 9 19'You serve 1 and 4' A 01 DSPATR(RI) A 01 COLOR(BLU) A 9 53'C serves after B' A COLOR(PNK) A GRID2ROW1 8A O 11 14DSPATR(&ATR2) A GRID3ROW1 8A O 11 31DSPATR(&ATR3) A GRID2ROW2 8A O 12 14DSPATR(&ATR2) A GRID3ROW2 8A O 12 31DSPATR(&ATR3) A 12 53'It helps to watch the' A GRID2ROW3 8A O 13 14DSPATR(&ATR2) A GRID3ROW3 8A O 13 31DSPATR(&ATR3) A 13 53'A player and how he relates' A GRID2ROW4 8A O 14 14DSPATR(&ATR2) A GRID3ROW4 8A O 14 31DSPATR(&ATR3) A 14 53'to the other two.' A GRID2ROW5 8A O 15 14DSPATR(&ATR2) A GRID3ROW5 8A O 15 31DSPATR(&ATR3) A 16 6'2 and 3 play Left' A 02 DSPATR(RI) A 02 COLOR(BLU) A 16 31'5 and 6 play Right' A 03 DSPATR(RI) A 03 COLOR(BLU) A 18 11'Serve Count:' A COLOR(BLU) A C11 1A O 18 24DSPATR(&C11A) A C12 1A O 18 26DSPATR(&C12A) A C13 1A O 18 28DSPATR(&C13A) A C14 1A O 18 30DSPATR(&C14A) A 18 53'If you can keep track' A C21 1A O 19 24DSPATR(&C21A) A C22 1A O 19 26DSPATR(&C22A) A C23 1A O 19 28DSPATR(&C23A) A C24 1A O 19 30DSPATR(&C24A) A 19 53'of counting to 6, you' A C31 1A O 20 24DSPATR(&C31A) A C32 1A O 20 26DSPATR(&C32A) A C33 1A O 20 28DSPATR(&C33A) A C34 1A O 20 30DSPATR(&C34A) A 20 53'have it whupped.' A C41 1A O 21 24DSPATR(&C41A) A C42 1A O 21 26DSPATR(&C42A) A C43 1A O 21 28DSPATR(&C43A) A C44 1A O 21 30DSPATR(&C44A) A C51 1A O 22 24DSPATR(&C51A) A C52 1A O 22 26DSPATR(&C52A) A C53 1A O 22 28DSPATR(&C53A) A C54 1A O 22 30DSPATR(&C54A) A C61 1A O 23 24DSPATR(&C61A) A C62 1A O 23 26DSPATR(&C62A) A C63 1A O 23 28DSPATR(&C63A) A C64 1A O 23 30DSPATR(&C64A) A 24 2'F3=Exit' A COLOR(BLU) A C71 1A O 24 24DSPATR(&C71A) A C72 1A O 24 26DSPATR(&C72A) A C73 1A O 24 28DSPATR(&C73A) A C74 1A O 24 30DSPATR(&C74A) A 24 43'Press Enter to Rotate Serves' A COLOR(BLU) ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Maximize Conversion to RPG4') PARM KWD(PGM) TYPE(*NAME) LEN(10) MIN(1) + PGM(*YES) PROMPT('RPG program') 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(6) RSTD(*YES) + DFT(*LOWER) VALUES(*NONE *LOWER) + PROMPT('Character Case') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &FILEQUAL &STYLE) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&FILEQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&FILE) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&FILEQUAL 1) DCL VAR(&LIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&FILEQUAL 11) DCL VAR(&DOCOPY) TYPE(*LGL) DCL VAR(&STYLE) TYPE(*CHAR) LEN(6) DCL VAR(&SEVERITY) TYPE(*CHAR) LEN(2) DCL VAR(&INDENTLVL) TYPE(*DEC) LEN(1 0) VALUE(3) IF COND(&LIB = '*LIBL') THEN(RTVMBRD + FILE(&LIB/&FILE) MBR(&MBR) RTNLIB(&LIB)) /* generate D specs */ 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 &FILEQUAL '*NO ' + '*YES' '*NO ' &INDENTLVL '*YES' 'JCR4MAX') /* and or modification */ OVRDBF FILE(LOOKAHEADR) TOFILE(&LIB/&FILE) + MBR(&MBR) OVRSCOPE(*JOB) CALL PGM(JCR4MAXR1) DLTOVR FILE(LOOKAHEADR) LVL(*JOB) /* eval modification */ CALL PGM(JCR4MAXR2) PARM(&MBR &FILE &LIB &SEVERITY) IF COND(&SEVERITY *GT '20') THEN(DO) DLCOBJ OBJ((&LIB/&FILE *FILE *EXCLRD &MBR)) 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 /* lower case adjustments */ IF COND(&STYLE *EQ '*LOWER') THEN(CALL + PGM(JCR4MAXR3)) DLTOVR FILE(MODIFYSRC) LVL(*JOB) SNDPGMMSG MSG('RPG4 modification for ' *CAT &MBR *TCAT + ' in ' *CAT &LIB *TCAT '/' *CAT &FILE + *TCAT ' - completed') DLCOBJ OBJ((&LIB/&FILE *FILE *EXCLRD &MBR)) ENDPGM ]]> .*-------------------------------------------------------------------- :P.Designed to run immediately after CVTRPGSRC command. 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.Select case conversion of the source code (STYLE).:EUL. :P.To complement new ability to have lower case characters, the following options are offered by STYLE keyword. :LINES. *NONE - Leave code as is. *LOWER - Convert source to lower case.:ELINES.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCR4MAX/PGM'.RPG program name - Help :XH3.RPG program name (PGM) :P.Source member to modify.:EHELP. :HELP NAME='JCR4MAX/SRCFILE'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file containing source program.:EHELP. :HELP NAME='JCR4MAX/STYLE'.Character Case - Help :XH3.Character Case (STYLE) :P.Case specific action to be taken. :PARML.:PT.:PK def.*LOWER:EPK. :PD.Convert all characters to lower case. :PT.:PK.*NONE:EPK.:PD.Do not change case of any source code. :EPARML.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // 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 //--------------------------------------------------------- // I thought it ironic using RPGII technology to update RPGIV code. // Multifile logic to enable look ahead. // Look ahead to determine if following statement was AND or OR. // Matching record logic to keep update and lookahead files in sync. // Force logic to spin through lookahead file if required to get next // executable line of source. // Added code to ignore SQL statements //--------------------------------------------------------- /define ControlStatements /define Constants /COPY JCRCMDS,JCRCMDSCPY FLOOKAHEADRIP F 112 DISK FMODIFYSRC US F 112 DISK //--------------------------------------------------------- // dcl-s tabrelat char(2) dim(*ctdata) perrcd(1); // EQ NE GT LT GE LE // dcl-s tabsymbol char(2) dim(*ctdata) alt(tabrelat); // = <> > < >= <= dcl-s tabrelat char(2) dim(6) ctdata perrcd(1); // EQ NE GT LT GE LE dcl-s tabsymbol char(2) dim(6) alt(tabrelat); // = <> > < >= <= dcl-s OldOpcode like(NewOpcode); dcl-s look_aheadU like(look_ahead); dcl-s IsAndOr char(3); dcl-s Extendedf2 char(45); dcl-s NewOpcode char(10); dcl-s Relations char(2); dcl-s IsForced ind; // nxt record is forced dcl-ds SrcDS len(92) inz; SrcFactor1 char(14) pos(24); SrcOpcode char(10) pos(38); OpWhen char(4) overlay(SrcOpcode:1); OpWhenRel char(2) overlay(SrcOpcode:5); OpDox char(3) overlay(SrcOpcode:1); OpDoxRel char(2) overlay(SrcOpcode:4); OpIf char(2) overlay(SrcOpcode:1); OpIfRel char(2) overlay(SrcOpcode:3); OpAnd char(3) overlay(SrcOpcode:1); OpAndRel char(2) overlay(SrcOpcode:4); OpOr char(2) overlay(SrcOpcode:1); OpOrRel char(2) overlay(SrcOpcode:3); SrcFactor2 char(14) pos(48); SrcResult char(14) pos(62); SrcLength char(1) pos(80); end-ds; //--*INPUT SPECS------------------------------------------- // All lines that are comment or have eject character are // ignored. The first compile time table or array that is // found sets on LR. Record type indicators determine // which code is 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 checks next look ahead. //--------------------------------------------------------- 1b if *in01; IsForced = *off; IsAndOr = *blanks; 2b if (look_type = 'C' or look_type = 'c') and (look_comt <> '*' and look_comt <> '/' and look_comt <> '+'); look_aheadU = %upper(look_ahead); 3b if %subst(look_aheadU: 38: 3) = 'AND'; 4b if (%subst(look_aheadU: 38 + 3: 1)) > ' '; IsAndOr = 'and'; 4e endif; 3x elseif %subst(look_aheadU: 38: 2) = 'OR'; 4b if (%subst(look_aheadU: 38 + 2: 1)) > ' '; IsAndOr = '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 = %upper(SrcDS); NewOpcode = *blanks; OldOpcode = *blanks; *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 IsAndOr > *blanks; Extendedf2 = %trimr(Extendedf2) + ' ' + IsAndOr; 1e endif; except UpdateSrc; endsr; OModifySrc e UpdateSrc O 11 20 ' ' O 37 ' ' O NewOpcode 47 O Extendedf2 92 ** EQ= NE<> LE<= GE>= LT< GT> ]]> '); //--------------------------------------------------------- // JCR4MAXR2 - convert codes to EVAL // Convert character Fields and Constant moves to EVAL // MOVE rules are: %size(Factor2) = %size(Result) // // MOVEL rules are: %size(Factor2) = %size(Result) or // %size(Factor2) > %size(Result) // // Z-ADD rules are: %size(Factor2) = %size(Result) or // %size(Factor2) > %size(Result) // // 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 ControlStatements /define FieldsArry /define Constants /define FieldsAttrDS /define p_JCRGETFLDR /COPY JCRCMDS,JCRCMDSCPY FMODIFYSRC UP F 112 DISK dcl-s ExtendedF2 char(45); dcl-s Factor1typ char(1); dcl-s Factor2typ char(1); dcl-s NewOpcode char(10); dcl-s ResultType char(1); dcl-s WorkInd char(2); dcl-s WorkTyp char(1); dcl-s IsZeroBlank ind; dcl-s Factor1dec zoned(2); dcl-s Factor2dec zoned(2); dcl-s ResultDec zoned(2); dcl-s WorkDec zoned(2); dcl-s Factor1len uns(5); dcl-s Factor2len uns(5); dcl-s nn uns(5); dcl-s ResultLen uns(5); dcl-s WorkLen uns(5); dcl-s xx uns(5); dcl-s PepCnt packed(3); dcl-ds Work5 inz; fact1value zoned(5) pos(1); end-ds; dcl-ds FactorxDS qualified; First1 char(1) pos(1); First3 char(3) pos(1); IsLookup char(14) pos(1); end-ds; dcl-ds *n inz; Src char(92) pos(1); SrcFactor1 char(14) pos(24); SrcF1p1 char(1) overlay(SrcFactor1:1); SrcOpcode char(10) pos(38); opmove char(4) overlay(SrcOpcode:1); opsub char(4) overlay(SrcOpcode:1); opz_ char(2) overlay(SrcOpcode:1); opsubst char(5) overlay(SrcOpcode:1); SrcFactor2 char(14) pos(48); SrcResult char(14) pos(62); resltlook char(14) overlay(SrcResult:1); reslt_in char(3) overlay(SrcResult:1); SrcLength char(1) pos(80); SrcRstind char(6) pos(83); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFil char(10); p_SrcLib char(10); p_DiagSeverity char(10); end-pi; //--*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 //--------------------------------------------------------- // If a calc record spec 1b if *in01 and SrcLength = *blanks; SrcOpcode = %upper(SrcOpcode); 2b if SrcRstind = *blanks AND SrcOpcode in %list('MOVE':'MOVEL':'MOVEL(P)':'MOVE(P)': 'Z-ADD':'Z-SUB':'SUB':'ADD':'MULT':'MULT(H)':'SUBST''SUBST(P)'); //--------------------------------------------------------- // Determine field sizes of Factor1, 2, Result Field //--------------------------------------------------------- IsZeroBlank = *off; Src = %upper(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 in %list('*ON':'*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: FieldsArry(*).Name: 1: FieldsArryCnt); 4b if nn = 0; bb = %scan('(': SrcResult: 1); 5b if bb > 0; resltlook = %subst(SrcResult: 1: (bb - 1)); nn = %lookup(resltlook: FieldsArry(*).Name: 1: FieldsArryCnt); 5e endif; 4e endif; 4b if nn > 0; FieldsAttrDS = FieldsArry(nn).Attr; 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 in %list('SETON':'SETOFF'); WorkInd = *blanks; 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 IsZeroBlank or (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 // Convert '1' to *on, '0' to *off 2b if SrcOpcode = 'MOVE' and SrcLength = ' ' and ResultType = 'A' and Resultlen = 1 and SrcFactor2 in %list('*ON':'*OFF':'''1''':'''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 IsZeroBlank = *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; IsZeroBlank = *off; 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; WorkTyp = *blanks; 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 in %list('*BL':'*ZE'); IsZeroBlank = *on; 1x else; //FIELD NAME nn = %lookup(FactorxDS: FieldsArry(*).Name: 1: FieldsArryCnt); //--------------------------------------------------------- // if lookup not found, it could be an array or // date field with : in it. Test both ways. //--------------------------------------------------------- 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: FieldsArry(*).Name: 1: FieldsArryCnt); 3e endif; 2e endif; //--------------------------------------------------------- 2b if nn > 0; FieldsAttrDS = FieldsArry(nn).Attr; 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: PepCnt); 1b if DiagSeverity > '20'; p_DiagSeverity = DiagSeverity; *inlr = *on; return; 1e endif; endsr; OmodifySrc e updateSrc O 37 ' ' O NewOpcode 47 O ExtendedF2 92 ]]> '); //--------------------------------------------------------- // JCR4MAXR3 - convert source code to lower case //--------------------------------------------------------- /define ControlStatements /define Constants /define f_IsIgnoreLine /define f_IsCompileTimeArray /COPY JCRCMDS,JCRCMDSCPY dcl-f modifysrc disk(112) usage(*update); dcl-ds InputDS len(112) inz; CompileArray char(3) pos(13); SpecType char(1) pos(18); d_Extended char(38) pos(18); Src char(74) pos(19); end-ds; dcl-s ApostropheCnt uns(3); dcl-s string varchar(94); //--------------------------------------------------------- read modifysrc InputDS; 1b dow not %eof; 2b if f_IsCompileTimeArray(CompileArray) or %upper(SpecType) = 'P'; *inlr = *on; return; 2e endif; string = %trimr(Src); 2b if not f_IsIgnoreLine(string); SpecType = %upper(SpecType); ApostropheCnt = 0; 3b for aa = 1 to 74; 4b if %subst(Src: aa: 1) = qs; ApostropheCnt += 1; 4e endif; //--------------------------------------------------------- // If extended D spec or record id characters, // or if first letter is L, as in L1, do not xlate //--------------------------------------------------------- 4b if not (d_Extended = 'D' or (SpecType = 'I' and (aa = 24 or aa = 32 or aa = 40)) or (aa = 1 and %subst(Src: aa: 1) = 'L')) and %rem(ApostropheCnt: 2) = 0; %subst(Src:aa:1) = %lower(%subst(Src: aa: 1)); 4e endif; 3e endfor; update modifysrc InputDS; 2e endif; read modifysrc InputDS; 1e enddo; *inlr = *on; ]]> '); //--------------------------------------------------------- // JCR4MAXR4 - Generate D specs for program defined fields (except parms) // Generate standard H specs in converted source. //--------------------------------------------------------- /define ControlStatements /define Constants /define f_IsCompileTimeArray /COPY JCRCMDS,JCRCMDSCPY dcl-f MODIFYSRC disk(112) usage(*update: *output); dcl-f NEWSRC disk(112) usage(*output); dcl-s FldStorage dim(%elem(defined)) like(storageds); dcl-s DataType char(1); dcl-s Defined char(14) dim(32767); dcl-s HeaderSrc char(70); dcl-s likeDefine char(20); dcl-s DefinedCount uns(10); dcl-s IsAlreadyDone ind; dcl-s IsDefined ind; dcl-ds StorageDS inz; dsUppercas char(14); dsFactor1 char(14); dsFactor2 char(14); dsResult char(14); dsLength char(5); dsDecimals char(2); dsText char(20); end-ds; //--*ENTRY------------------------------------------------- dcl-pi *n; p_CreateNew ind; end-pi; //--*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 //--------------------------------------------------------- p_CreateNew = *off; read modifySrc; 1b dow not %eof; // All lines that are comment or have eject character are // ignored. The first compile time table or array that is // found will exit read loop. 2b if f_IsCompileTimeArray(CompileArray); 1v leave; 2e endif; 2b if not (Asterisk in %list('*':'/':'+')); 3b if %upper(SpecType) = 'D' and SrcDspecs > *blanks; SrcDspecs = %upper(Srcdspecs); bb += 1; Defined(bb) = %triml(SrcDspecs); 3x elseif %upper(SpecType) = 'C' and SrcOpcode > *blanks and %scan('(': SrcResult: 1) = 0; //skip arrays SrcOpcode = %upper(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 = %upper(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 = %upper(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: 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, must write out new member. // 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 = ' ctl-opt DFTACTGRP(*NO) ACTGRP(*CALLER) EXPROPTS(*RESDECPOS)'; except Header; SrcSeqno += .01; HeaderSrc = ' DATFMT(*ISO) TIMFMT(*ISO) OPTION(*NODEBUGIO: *NOUNREF);'; except Header; setll *start modifySrc; read modifySrc; 2b dow not %eof; 3b if not IsAlreadyDone; 4b if %upper(SpecType) in %list('D':'C':'I'); IsAlreadyDone = *on; // Process back through array and write D specs HeaderSrc = *blanks; SrcSeqno += .01; except Header; SrcSeqno += .01; HeaderSrc = ' //---------------------------------------------'; 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; ONEWSRC e Header O SrcSeqno 6 O 12 '000000' O HeaderSrc 87 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 ]]> '); //--------------------------------------------------------- // JCR4MAXV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define f_GetQual /define f_SndEscapeMsg /define f_RunCmd /define f_IsValidSrcType /COPY JCRCMDS,JCRCMDSCPY //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); p_Style char(12); end-pi; //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_SrcFilQual: p_SrcMbr:'RPGLE':'SQLRPGLE'); f_SndEscapeMsg('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_RunCmd('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 ' + f_GetQual(p_SrcFilQual)); 1e endif; // changed to release locks after update occurs in CL //f_RunCmd('DLCOBJ OBJ((' + f_GetQual(p_SrcFilQual) + //' *FILE *EXCLRD ' + %trimr(p_SrcMbr) + '))'); *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ 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') ]]> .*-------------------------------------------------------------------- :P.THIS IS THE V5R4 FIXED FORMAT PROTOTYPER!! Several people asked me to keep the old fixed column version. If wanting DCL-PR and DCL-PI, use JCRPROTO. :P.Reads 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 library list, utility will auto-document prototypes with object text. :P.After conversion, 1) 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 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 whose 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. Utility will not replace existing member!:EHELP. :HELP NAME='JCR4PROTO/PROTSFL'.Source file - Help :XH3.Source file (SRCFILE) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCR4PROTOR - Convert *entry/call parms to FIXED FORMAT 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 find *ENTRY and call Opcodes. // Seek2RPG input file find defined parm Lists. // RPGSRC will be generated code. // This program converts CALLs having variable names as the // program name. // Prototype name is 'v_' + field name. //--------------------------------------------------------- /define ControlStatements /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 // *ENTRY /define p_JCRPROTOR /COPY JCRCMDS,JCRCMDSCPY dcl-f ORIGINRPG disk(112) extfile(extifile) extmbr(p_inmbr) usropn; dcl-f SEEK1RPG disk(112) extfile(extifile) extmbr(p_inmbr) usropn; dcl-f SEEK2RPG disk(112) extfile(extifile) extmbr(p_inmbr) usropn; dcl-f RPGSRC disk(112) usage(*output) extfile(extofile) extmbr(p_outmbr) usropn; //--------------------------------------------------------- dcl-s SrcOut like(src112); dcl-s AlreadyProto char(15) dim(1000); dcl-s PiSrcArry char(100) dim(512); dcl-s CalledPgmName char(10); dcl-s CallExtender char(10); dcl-s CallpArry char(100) dim(512); dcl-s CallpPostArry char(100) dim(512); dcl-s CallpPreArry char(100) dim(512); dcl-s PListName char(14); dcl-s SrcCspec char(100); dcl-s hyphens char(50) inz(*all'-'); dcl-s SrcSeq zoned(6: 2); dcl-s Crrn1 uns(10); dcl-s Crrn2 uns(10); dcl-s pi uns(5); dcl-s rr uns(5); dcl-s v1 uns(5); dcl-s v2 uns(5); dcl-s v3 uns(5); dcl-s IsArray ind; dcl-s IsCompileTime ind; dcl-s IsDefinePList ind; dcl-s IsComment ind; dcl-s IsFirstTime ind; dcl-s pepcnt packed(3); //--*INPUT SPECS------------------------------------------- IOriginRPG ns I a 13 15 CompileArry I a 13 112 Src112 I a 19 19 Asterisk 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 //--------------------------------------------------------- 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: PepCnt); 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 %upper(CompileArry) = '**C'; IsArray = *on; 2e endif; SrcDS.Src63 = %upper(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 = %upper(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; CallpPreArry(*) = *blanks; CallpArry(*) = *blanks; CallpPostArry(*) = *blanks; v1 = 0; v2 = 0; v3 = 0; // extract program name CalledPgmName = *blanks; aa = %scan(qs: SrcDS.Factor2: 2); 1b if aa = 0; //variable program name CalledPgmName = 'v_' + SrcDS.Factor2; 1x else; CalledPgmName = %lower(%subst(SrcDS.Factor2: 2: aa - 2)); 1e endif; // extract CALL SrcDS.Opcode extender CallExtender = *blanks; 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' + %lower(CallExtender); %subst(CallpArry(v2): 36) = 'p_' + %trimr(%upper(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 = %upper(Seek2Src); 2b if not (SrcDS.Asterisk in %list('/':'+':'*')); 2b if CompileArry2 = '** ' or %upper(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 %upper(CompileArry1) = '**C'; LV leavesr; 2e endif; SrcDS.Src63 = %upper(Seek1Src); 2b if not (SrcDS.Asterisk in %list('/':'+':'*')); //--------------------------------------------------------- // 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_' + %lower(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_' + %lower(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 CalledPgmName = *blanks; aa = %scan(qs: SrcDS.Factor2: 2); 1b if aa = 0; //variable program name CalledPgmName = 'v_' + SrcDS.Factor2; SrcCspec = ' //---variable name--------------------------------------'; 1x else; CalledPgmName = %lower(%subst(SrcDS.Factor2: 2: aa - 2)); QusrObjDS = f_QUSROBJD(%upper(CalledPgmName) + '*LIBL':'*PGM'); 2b if ApiErrDS.BytesReturned = 0; QusrObjDS.Text = %trimr(QusrObjDS.Text) + hyphens; 2x else; QusrObjDS.Text = *all'-'; 2e endif; SrcCspec = ' //---' + QusrObjDS.Text + '-'; 1e endif; SrcSeq += .01; except CSPEC; SrcCspec = ' D PR'; %subst(SrcCspec: 8: 15) = 'p_' + %lower(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 = %upper(Seek2Src); 2b if not (SrcDS.Asterisk in %list('/':'+':'*')); 2b if CompileArry2 = '** ' or %upper(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: FieldsArry(*).Name: 1: FieldsArryCnt); 5b if aa = 0; f_SndEscapeMsg('*ERROR* Field definition for ' + %trimr(SrcDS.ResultField) + ' not found.'); 5e endif; FieldsAttrDS = FieldsArry(aa).Attr; SrcCspec = ' D'; %subst(SrcCspec: 30) = %editc(FieldsAttrDS.Length:'4'); %subst(SrcCspec: 40) = %lower(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; ORPGSRC e OutSrc O SrcSeq 6 O 12 '000000' O SrcOut 112 ORPGSRC e CSPEC O SrcSeq 6 O 12 '000000' O SrcCspec 112 ]]> */ /*--------------------------------------------------------------------------*/ 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('Free + 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') ]]> .*-------------------------------------------------------------------- :P.Converts v4 fixed column calculation specs into free format. (while not making a chopped up mess like you may have seen with other conversion tools.) :P.Before running this command, run JCRFREESS side-by-side to indentify what will not convert (regardless of what conversion utility you use). Suggested read A Path to /Free on website. Fix conversion issues in original program before using this utility. :P.Afterwards, use the JCRDHD utility to convert H, F, and D specs to full free.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='JCR5FREE/RPG4MBR'.RPG4 member name - Help :XH3.RPG4 member name (RPG4MBR) :P.Member whose 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 use same member/source file and lib name as Input member!:EHELP. :HELP NAME='JCR5FREE/RPG5SFL'.Source file - Help :XH3.Source file (RPG5SFL) :P.Source file that will contain new source program.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // JCR5FREER - Convert V4 fixed column calc specs into V5 /free format // There is no 100% V4 fixed format to V5 free conversion tool. // Many differences between the two cannot be solved by a utility. // Suggested read Path to /Free on the website. // // This program takes v4 fixed format calc specs that has // been purposely written to cleanly convert into free format. // Use JCRFREESS utility to identify and then fix everything // that cannot be converted, before using this (or any) utility. //--------------------------------------------------------- // Areas that will need manual modification after convert: // lookup opcodes will need to be scrutinized // and tested. %found and %equal bif not set by lookup operation // It is good bet some code will have to be rewritten. // // ForCountxx FOR counter that is created will need a definition. // Be aware, Multiple line IF, WHEN, etc statements that // do not end with AND or OR, are incorrectly flagged as // stand alone statements. After conversion, edit code // to remove unneeded ;. // example // C if a=b // C or c=d // will convert to // if a=b; // or c=d; // will need editing to be correct. // END opcodes will not match newly generated FOR, without JCRNUMB utility. //--------------------------------------------------------- /define ControlStatements /define Constants /define f_GetQual /define f_IsCompileTimeArray /define f_SndCompMsg // *ENTRY /define p_JCR5FREER /COPY JCRCMDS,JCRCMDSCPY dcl-f V4SRC disk(112) extfile(extifile) extmbr(p_inmbr) usropn; dcl-f V5SRC disk(112) usage(*output) extfile(extofile) extmbr(p_outmbr) usropn; dcl-s F2upper like(f2); dcl-s RFupper like(rf); dcl-s SrcOut like(Src112); dcl-s Work like(Src112); dcl-s WorkUpper like(Src112); dcl-s LF2 char(14); dcl-s LineOfCode char(112); dcl-s NewOpCode varchar(10); dcl-s OpCode varchar(10); dcl-s opupsave char(10); dcl-s SrcCspec char(100); dcl-s toOpCode varchar(10) dim(999); dcl-s User char(6); dcl-s zz char(14); dcl-s ii int(10); dcl-s kk int(10); dcl-s SrcDat zoned(6); dcl-s SrcSeq zoned(6: 2); dcl-s LevelsDeep uns(5); dcl-s xx uns(5); dcl-s yy uns(5); dcl-s StartPosition uns(3) inz(10); dcl-s IndentPerLevel uns(3) inz(3); dcl-s DownOneLvl ind; dcl-s IsArray ind; dcl-s IsCalcSpec ind; dcl-s IsCallp ind; dcl-s IsCasxx ind; dcl-s IsContinuation ind; dcl-s IsFree ind; dcl-s IsLastTime ind inz(*on); dcl-s IsOutputSpec ind; dcl-s IsWhenIndent ind; dcl-s UpOneLvl ind; dcl-s IsComment ind; dcl-s IsFirstTime ind; dcl-ds OPup len(10); DoIfWh char(2) pos(1); EndOpcode char(3) pos(1); end-ds; //--*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 //--------------------------------------------------------- extIfile = f_GetQual(p_InFileQual); extOfile = f_GetQual(p_OutFileQual); open v4Src; open v5Src; read v4Src; 1b dow not %eof; 2b if f_IsCompileTimeArray(CompileArry); IsArray = *on; 2e endif; 2b if not IsArray; 3b if not %eof; clear 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 = %lower(OP); // --------- 3b if SpecType = 'C' or SpecType = 'c'; IsCalcSpec = *on; 4b if not IsFirstTime; IsFirstTime = *on; // 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; 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; exsr srCommentLine; IsFree = *off; IsOutputSpec = *on; 5e endif; 4e endif; 3e endif; //--------------------------------------------------------- 2e endif; 2b if IsArray or not IsCalcSpec; 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 = %upper(OP); 4b if Asterisk = '*'; 4x elseif EndOpcode = 'CAS'; IsCasxx = *on; 4x elseif OPup = 'SELECT'; // DownOneLvl = *on; IsWhenIndent = *off; 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 //--------------------------------------------------------- Work = *blanks; LineOfCode = *blanks; 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: 5) = 'DOWNE' or %subst(OPup: 1: 5) = 'DOUNE' 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; Work = *blanks; %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 = %upper(f2); rfupper = %upper(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; zz = *blanks; lf2 = f2; f2upper = %upper(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 and LevelsDeep > 0; 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; LineOfCode = *blanks; 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 = %upper(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 += .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 += .01; SrcDat = 0; except CSPEC; endsr; Ov5Src e writenonC O SrcSeq 6 O SrcDat 12 O SrcOut 112 Ov5Src e CSPEC O SrcSeq 6 O SrcDat 12 O SrcCspec 112 ]]> '); //--------------------------------------------------------- // JCR5FREEV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckObj /define f_IsSameMbr /define f_IsValidSrcType /define f_SndEscapeMsg /define f_SrcFileAddPfm // *ENTRY /define p_JCR5FREER /COPY JCRCMDS,JCRCMDSCPY dcl-s InLib char(10); //--------------------------------------------------------- 1b if not f_IsValidSrcType(p_InFileQual: p_InMbr:'RPGLE':'SQLRPGLE'); f_SndEscapeMsg('Member ' + %trimr(p_InMbr) + ' is not type RPGLE or SQLRPGLE.'); 1e endif; f_CheckObj(p_OutFileQual: '*FILE'); 1b if f_IsSameMbr(p_InFileQual: p_InMbr: p_OutFileQual: p_OutMbr); f_SndEscapeMsg('RPG4 file/lib/mbr cannot + be same as Free file/lib/mbr name.'); 1e endif; f_SrcFileAddPfm(p_OutFileQual: p_OutMbr: ' ': ' ': p_InFileQual: p_InMbr); *inlr = *on; return; ]]> scripting cmd prompts */ /* David George intellectual input */ /* Craig Rutledge < www.jcrcmds.com > */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Generate XML download mbrs') PARM KWD(XMLSCRIPT) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Script member') PARM KWD(SCRIPTSRCF) TYPE(SCRIPTSRCF) + 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) + 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') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&SCRIPTMBR &SCRIPTSFL &XMLTOSFL) DCL VAR(&SCRIPTMBR) TYPE(*CHAR) LEN(10) DCL VAR(&SCRIPTSFL) TYPE(*CHAR) LEN(20) DCL VAR(&SCRIPTSFIL) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&SCRIPTSFL 1) DCL VAR(&SCRIPTSLIB) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&SCRIPTSFL 11) DCL VAR(&XMLTOSFL) TYPE(*CHAR) LEN(20) DCL VAR(&XMLTOSFIL) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&XMLTOSFL 1) DCL VAR(&XMLTOSLIB) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&XMLTOSFL 11) DCL VAR(&TEXT) TYPE(*CHAR) LEN(50) 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 PGM(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 ]]> - CMD */ /* Craig Rutledge < www.jcrcmds.com > */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Script - Command Prompt') PARM KWD(XCMD) TYPE(*CMDSTR) LEN(500) MIN(1) PROMPT('Command to execute') ]]> .*-------------------------------------------------------------------- :P.Generates source file member containing validated, well-formed XML with all information required to recreate source members/objects on installing system. :P.The driver is 'script' member that describes the source members and object types to associate together with this particular application build. :P.Three commands are used to build information in the CLLE script file. :LINES. XMLGENINC specify 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 script source. XMLGENMBR and XMLGENCMD can be mixed in any sequence after that and may be used any number of times. :P.note: if your package includes DDL members, add this line before any DDL creates. :P.XMLGENCMD XCMD(CHGCURLIB CURLIB(&TOLIB)) :P.Also include a DROP TABLE statement in your DDL.:EHELP. .*-------------------------------------------------------------------- :HELP NAME='XMLGEN/XMLSCRIPT'.Script member name - Help :XH3.Script member name (XMLSCRIPT) :P.Member name of script mbr 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 is used. :PT.source-file-name :PD.Enter source file name for script member.:EPARML.:EHELP. :HELP NAME='XMLGEN/SRCTOFILE'.Put Source file - Help :XH3.Put Source file (SRCTOFILE) :P.Source file where XML member is created. :PARML.:PT.:PK def.QXML:EPK.:PD.The default source file, QXML is used. :PT.source-file-name :PD.Enter source file name for XML member.:EPARML.:EHELP.:EPNLGRP. ]]> - CMD */ /* Craig Rutledge < www.jcrcmds.com > */ /*--------------------------------------------------------------------------*/ 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') ]]> 0; //error occurred 2b if ApiErrDS.ErrMsgId = 'CPF9810'; Msgtxt = '0000 Library ' + %trimr(p_UploadSrcLib) + ' was not found.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9812'; Msgtxt = '0000 Source file ' + %trimr(p_UploadSrcFil) + ' was not found in ' + %trimr(p_UploadSrcLib) + '.'; 2x elseif ApiErrDS.ErrMsgId = 'CPF9815'; 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; 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 inputDS; 1b dow not %eof; 2b if IsWrite; 3b if not(xmltag2 = ''); //---------------------------------------------------- // if /copy AND user has selected custom install file, // change statements to find copybooks in new file. //---------------------------------------------------- 4b if %parms = %parmnum(p_OvrSrcFile); UpSlash = %upper(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; SrcOut = xmlcode; SeqNum += .01; write MBRSRC mbrsrcDS; 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; SeqNum = 0; 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 inputDS; bldexc = %trimr(xmlcode); exsr srTolibToken; callp QCMDEXC(bldexc: %len(%trimr(bldexc))); //--------------------------------------------------------- // qcmdexc statement. Build statement from 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 inputDS; 3b dow not(xmltag2 = ''); %subst(bldexc: aa: 100) = xmlcode; aa += 100; read xmlinput inputDS; 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; 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 OF INSTALL PGM HERE /// do not copy past this point *** /// ]]> - CMD */ /* Craig Rutledge < www.jcrcmds.com > */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Script - Source member info') PARM KWD(XMBR) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Member') 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) PROMPT('Object type') PARM KWD(XGENCRT) TYPE(*CHAR) LEN(4) RSTD(*YES) + VALUES(*YES *NO) MIN(1) PROMPT('Generate + compile code for mbr') ]]> '); //--------------------------------------------------------- // XMLGENR - Generate XML source member // Read member script file to generate XML encapsulated data //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f xmlgenins disk(112) extfile('JCRCMDS') usropn extmbr('XMLGENINS'); dcl-ds InstallerDS len(112); InstallerSrc char(100) pos(13); end-ds; dcl-f SCRIPT disk(112) extfile(extifile) usropn extmbr(p_scriptmbr); dcl-ds scriptDS len(112); xScriptSrc char(80) pos(13); end-ds; dcl-f XMLOUTFILE disk(112) usage(*update: *output) extfile(extxmloutfile) usropn extmbr(p_scriptmbr); dcl-ds xmlinDS len(112); XmlDta char(100) pos(13); end-ds; dcl-f MBRSRC disk(112) extfile(extofile) usropn extmbr(xmbr) infds(infds); dcl-ds mbrsrcDS len(112); SrcDta char(100) pos(13); end-ds; //--------------------------------------------------------- /define ApiErrDS /define Infds /define Constants /define f_CrtCmdString /define f_GetQual /define f_Qusrmbrd /define f_SndCompMsg /define SourceOutDS // *ENTRY /define p_XMLGENR /COPY JCRCMDS,JCRCMDSCPY dcl-s InstructArry char(100) dim(22) ctdata perrcd(1); dcl-s Instruction char(100); dcl-s ba char(1) inz('['); dcl-s bc char(1) inz(']'); dcl-s a17 char(17); dcl-s IsAllLoaded ind; dcl-s string varchar(500); dcl-s XmlToFile varchar(30); dcl-s extXmlOutfile char(21); dcl-s CopyFromRec uns(10); dcl-s CopyToRec uns(10); dcl-s RecordCount uns(10); dcl-s ParserLine uns(10); // values extracted from mbr script command dcl-s xMbr char(10); // member name dcl-s xMbratr char(10); // src mbr attr dcl-s xfromSrcf char(10); // copy from Src file dcl-s xfromSrcl char(10); // copy from Src lib dcl-s xtoSrcf char(10); // copy to Src file dcl-s xobjtype char(7); // object type dcl-s xgencrt char(4); // gen compile code? dcl-s xinclude char(4); // gen compile code? // Get source file length and CCSID of source file // from integer to alpha for load into XML. dcl-ds MakeAlpha1; SrcLenA char(5) pos(1); SrcLenD zoned(5) inz pos(1); end-ds; dcl-ds MakeAlpha2; SrcCcsidA char(5) pos(1); SrcCcsidD zoned(5) inz pos(1); end-ds; //--------------------------------------------------------- clear Outds; extIfile = f_GetQual(p_ScriptQual); extXmlOutfile = f_GetQual(p_OutFileQual); open SCRIPT; open XmlOutfile; // generate XML header statement f_Write(''); //--------------------------------------------------------- // Read down in script to get whether or not to include installer. // XMLGENINC XINCLUDE(*YES) *YES, *NO //--------------------------------------------------------- read SCRIPT scriptDS; 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 scriptDS; 1e enddo; //--------------------------------------------------------- // Generate Install instructions and Install program //--------------------------------------------------------- 1b if xinclude = '*YES'; // load '); //--------------------------------------------------------- // load // hex values BA=open BC=close // Load instruction array to outfile. //--------------------------------------------------------- f_Write(' 0; exsr srLoadString; exsr srParseMbrVal; f_Write('* ' + xMbr + ' ' + xMbratr + ' ' + f_GetMbrText(xfromSrcf + xfromSrcl: xMbr)); 3e endif; read SCRIPT scriptDS; 2e enddo; chain 1 SCRIPT scriptDS; // write comment line / closing border line. f_Write('*'); f_Write(InstructArry(1)); // close brackets f_Write(bc+bc+'> '); // load Load RPG Source array to outfile. f_Write(' '); 1x else; f_Write(''); 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 scriptDS; 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 scriptDS; 1e enddo; // generate completed message code. f_Write('' + ' '); f_Write(''); close SCRIPT; //--------------------------------------------------------- // Now that all XML is generated, spin back through // and get the install program record numbers. // Update installation copy instructions with // From and To record numbers. //--------------------------------------------------------- 1b if xinclude = '*YES'; setll 1 XmlOutFile; read XmlOutFile xmlinDS; 2b dow not %eof; RecordCount += 1; 3b if %scan('TOMBR(parser) MBROPT(*REPLACE)':XmlDta) > 0; ParserLine = RecordCount; 3e endif; 3b if %scan('* /// START OF INSTALL PGM HERE ':XmlDta) > 0; CopyFromRec = RecordCount + 1; 3e endif; 3b if %scan('* /// END OF INSTALL PGM HERE ':XmlDta) > 0; CopyToRec = RecordCount - 1; 2v leave; 3e endif; read XmlOutfile xmlinDS; 2e enddo; chain ParserLine XmlOutfile xmlinDS; %subst(XmlDta:41) = 'FROMRCD(' + %char(CopyFromRec) + ') TORCD(' + %char(CopyToRec) + ')'; update XmlOutfile xmlinDS; 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 f_Write('' + ' '); // 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 f_Write(''); f_Write(''); // load member data into text file. f_Write('' + ' '); f_Write(''); // generate object creation code // if flag is set to '*YES' 1b if xgencrt = '*YES'; 2b if xMbratr = 'CMD'; exsr srCrtCmd; 2x else; f_Write('' + ' '); 2e endif; 1e endif; endsr; //--------------------------------------------------------- // Command data was loaded into single string. Break commands // into 100 byte chunks and write to XML. //--------------------------------------------------------- begsr srLoadExc; f_Write(' 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; f_Write(%subst(string: aa: (bb - aa) + 1)); 1x else; // multiline command 2b dou aa > bb; f_Write(%subst(string: aa)); aa += 100; 2e enddo; 1e endif; // close brackets f_Write(bc+bc+'> '); 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 scriptDS; 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; //--------------------------------------------------------- // Write generated code to outfile //--------------------------------------------------------- dcl-proc f_Write; dcl-pi *n; pSrcCod char(100) const; end-pi; OutDS.Src100 = pSrcCod; OutDS.SrcSeq += .01; write XmlOutFile OutDS; return; end-proc; //--------------------------------------------------------- // get member description then xlate out invalid characters dcl-proc f_GetMbrText; dcl-pi *n char(50); p_SrcFile char(20) const; p_SrcMbr char(10); end-pi; QusrmbrdDS = f_Qusrmbrd(p_SrcFile: p_SrcMbr: 'MBRD0100'); return %xlate(qd + qs + '<&%':' ': QusrmbrdDS.Text); end-proc; //--------------------------------------------------------- ** 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 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 are extracted and objects required * for application will be created in your-library-name. * * Members in this install: (to view or manually extract members, scan '); //--------------------------------------------------------- // XMLGENV - Validity checking program for selected script //--------------------------------------------------------- /define ControlStatements /define Constants /define Qcmdchk /define f_CheckMbr /define f_CheckObj /define f_GetQual /define f_SndEscapeMsg /define f_IsSameMbr /define f_SrcFileAddPfm // *ENTRY /define p_XMLGENR /COPY JCRCMDS,JCRCMDSCPY dcl-f SCRIPT disk(112) extfile(extifile) extmbr(p_scriptmbr) usropn; dcl-ds scriptDS len(112); xScriptSrc char(80) pos(13); end-ds; //--------------------------------------------------------- dcl-s InLib char(10); dcl-s bldexc char(500); dcl-s string varchar(500); dcl-s IsAllLoaded ind; // values extracted from mbr script command dcl-s xMbr char(10); dcl-s xMbratr char(10); dcl-s xfromSrcf char(10); dcl-s xfromSrcl char(10); dcl-s xtoSrcf char(10); dcl-s xobjtype char(7); dcl-s xgencrt char(4); //--------------------------------------------------------- // 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'); 1b if f_IsSameMbr(p_ScriptQual: p_ScriptMbr: p_OutFileQual: p_ScriptMbr); f_SndEscapeMsg('Script file/lib/mbr cannot + be same as XML file/lib/mbr name.'); 1e endif; // add outfile member; f_SrcFileAddPfm(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 scriptDS; 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 char(10) member name // xMbratr char(10) source mbr attr // xfromSrcf char(10) copy from Src file // xfromSrcl char(10) copy from Src lib // xtoSrcf char(10) copy to Src file // xobjtype char(7) object type // xgencrt char(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; %len(string) = %len(string) - 2; //drop last) //--------------------------------------------------------- // 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. //--------------------------------------------------------- string = %scanrpl('&TOLIB': 'QUSRSYS': string); aa = %scan('XCMD(': string); bldexc = %subst(string: aa + 5); callp QCMDCHK(bldexc: %len(%trimr(bldexc))); 3e endif; 2e endif; read script scriptDS; 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 scriptDS; 2e endif; 1e enddo; endsr; ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&MBR &SFILEQUAL &USEFILE) DCL VAR(&MBR) TYPE(*CHAR) LEN(10) DCL VAR(&SFILEQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&SFIL) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&SFILEQUAL 1) DCL VAR(&SLIB) TYPE(*CHAR) STG(*DEFINED) LEN(10) + DEFVAR(&SFILEQUAL 11) DCL VAR(&USEFILE) TYPE(*CHAR) LEN(10) DCL VAR(&XMLINSTAL) TYPE(*CHAR) LEN(1) IF COND(&SLIB = '*LIBL') THEN(DO) RTVOBJD OBJ(&SFIL) OBJTYPE(*FILE) RTNLIB(&SLIB) MONMSG MSGID(CPF0000) ENDDO OVRDBF FILE(XMLINPUT) TOFILE(&SLIB/&SFIL) + MBR(&MBR) OVRSCOPE(*JOB) CALL PGM(XMLPREVIER) PARM(&MBR &SFIL + &SLIB &USEFILE &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 COND(&XMLINSTAL = 'Y') THEN(DO) CRTSRCPF FILE(QTEMP/XMLEXTRACT) RCDLEN(112) MONMSG MSGID(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 PGM(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, */ /* (*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. */ /*-----------------------------------------------------------------------*/ SELECT WHEN COND(&USEFILE *EQ '*DEFAULTS') THEN(CALL + PGM(QTEMP/XMLEXTRACT) PARM(&MBR + &SFIL &SLIB)) OTHERWISE CMD(CALL PGM(QTEMP/XMLEXTRACT) PARM(&MBR + &SFIL &SLIB &USEFILE)) ENDSELECT ENDDO ENDPGM ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA10 CA12 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 EDTCDE(Y) 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 58'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(1) SFLSIZ(2) A PROGID SFLPGMQ(10) ]]> .*-------------------------------------------------------------------- :P.Presents a subfile of source member, listing members, and commands to be executed from an uploaded XML source member. Please review before install.: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, is 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, verfiy the uploaded text has no duplicate member names. :EPARML.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // XMLPREVIER - Preview uploaded XML install members // It is recommended to run this program over any // uploaded XMLGEN generated source before installing to list // 1. source members installed. // 2. source files created. // 3. any commands executed during installation. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f XMLINPUT disk(112); dcl-ds inputDS; xmltag1 char(9) pos(13); xmlinstallpgm char(17) pos(13); xmltag2 char(10) pos(18); xmlcode char(100) pos(13); end-ds; dcl-f XMLPREVIED workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); /define FunctionKeys /define Infds /define Dspatr /define Ind /define psds /define Constants /define f_GetDayName /define f_BuildString /define f_RmvSflMsg /COPY JCRCMDS,JCRCMDSCPY dcl-s string varchar(500); dcl-s SequenceNum packed(3); dcl-s IsEnableInst ind; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFil char(10); p_SrcLib char(10); p_UsrsFil char(10); p_Install char(1); end-pi; //--------------------------------------------------------- aInstall = ND; p_Install = 'N'; f_RmvSflMsg(ProgId); scDow = f_GetDayName(); scObjHead = f_BuildString('& & &': P_SrcMbr: p_SrcFil: p_SrcLib); read xmlinput inputDS; 1b dow not %eof; // determine if install_program source is included in text 2b if xmlinstallpgm = ''; IsEnableInst = *on; 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 inputDS; 3b dow not(xmltag2 = ''); %len(string) += 100; %subst(string: aa: 100) = xmlcode; aa += 100; read xmlinput inputDS; 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. //--------------------------------------------------------- string = %scanrpl('&tolib': %trimr(p_SrcLib): string); 3b if not(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 inputDS; 1e enddo; //--------------------------------------------------------- // Show subfile. F3/F12 = Exit F10=Run Install //--------------------------------------------------------- Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; 1b if rrn = 0; snd-msg 'No XMLGEN tags found in source member'; 1x elseif not IsEnableInst; snd-msg '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; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('Preview XML Upload Members') PARM KWD(UPLOADMBR) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Uploaded member') 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')) PROMPT('Output to this + source file') ]]> '); //--------------------------------------------------------- // XMLPREVINR - extract embedded installer code from text. // read XML input member. use tags in text to extract installer source. //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f XMLINPUT disk(112); // uploaded text dcl-ds inputDS; xmltag1 char(17) pos(13); xmltag2 char(18) pos(18); xmlcode char(100) pos(13); end-ds; dcl-f XMLEXTRACT disk(112) usage(*output); // parsed out dcl-ds OutDS len(112); seqNum zoned(6:2) pos(1) inz(0); seqDate zoned(6:0) pos(7) inz(0); SrcOut char(100) pos(13); end-ds; dcl-s IsWrite ind inz(*off); //--------------------------------------------------------- read xmlinput inputDS; 1b dow not %eof; // write records to temp installer source after start is found 2b if IsWrite; 3b if xmltag2 = ''; *inlr = *on; return; 3e endif; seqNum += .01; srcout = xmlcode; write XMLEXTRACT OutDS; // Start of data to copy. 2x elseif xmltag1 = ''; IsWrite = *on; 2e endif; read xmlinput inputDS; 1e enddo; *inlr = *on; return; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('XML Script Member Viewer') PARM KWD(XMLSCRIPT) TYPE(*NAME) LEN(10) MIN(1) + PROMPT('Script member') PARM KWD(SCRIPTSRCF) TYPE(SCRIPTSRCF) + PROMPT('Script source file') SCRIPTSRCF: QUAL TYPE(*NAME) LEN(10) DFT(QXMLGENS) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') ]]> *---------------------------------------------------------------- A DSPSIZ(24 80 *DS3 27 132 *DS4) A INDARA PRINT CA03 CA12 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'XMLSCRIPT' COLOR(BLU) A 1 23'XML Script Member Viewer' A DSPATR(HI) A SCDOW 9A O 1 62COLOR(BLU) A 1 72DATE EDTCDE(Y) 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) ]]> .*-------------------------------------------------------------------- :P.Provides easy review of CL script members 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='XMLSCRIPT/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='XMLSCRIPT/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 is used. :PT.source-file-name :PD.Enter source file name for script member.:EPARML.:EHELP.:EPNLGRP. ]]> '); //--------------------------------------------------------- // XMLSCRIPTR - XML Script Member Viewer //--------------------------------------------------------- ctl-opt dftactgrp(*no) actgrp(*stgmdl) datfmt(*iso) timfmt(*iso) option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR') stgmdl(*teraspace) alloc(*stgmdl); dcl-f XMLSCRIPTD workstn sfile(sbfdta1: rrn) infds(infds) indds(ind); dcl-f SCRIPT disk(112) extfile(extifile) extmbr(p_srcmbr) usropn; dcl-ds inputDS len(112); xScriptSrc char(80) pos(13); end-ds; /define FunctionKeys /define Infds /define Dspatr /define Ind /define Constants /define f_BuildString /define f_GetDayName /define f_Qusrmbrd /define f_GetQual /COPY JCRCMDS,JCRCMDSCPY dcl-s xInclude char(4); dcl-s string varchar(500); dcl-s SequenceNum packed(3); dcl-s IsAllLoaded ind; //--*ENTRY------------------------------------------------- dcl-pi *n; p_SrcMbr char(10); p_SrcFilQual char(20); end-pi; //--------------------------------------------------------- // 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 inputDS; 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 inputDS; 1e enddo; //--------------------------------------------------------- // read through member loading source record to outfile //--------------------------------------------------------- read SCRIPT inputDS; 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 inputDS; 1e enddo; //--------------------------------------------------------- // Show subfile //--------------------------------------------------------- scDow = f_GetDayName(); scObjHead = f_BuildString('& & & Installer: &': QusrmbrdDS.Mbr: QusrmbrdDS.File: QusrmbrdDS.Lib: xinclude); Ind.sfldsp = (rrn > 0); Ind.sfldspctl = *on; write sfooter1; exfmt sbfctl1; *inlr = *on; close SCRIPT; 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 inputDS; 2e endif; 1e enddo; endsr; ]]> */ /*--------------------------------------------------------------------------*/ CMD PROMPT('All mbrs to single XML mbr') PARM KWD(INSRCFIL) TYPE(SOURCE) MIN(1) + PROMPT('Input Source File') PARM KWD(OUTSRCFIL) TYPE(SOURCE) MIN(1) + PROMPT('Source file for XML out member') SOURCE: QUAL TYPE(*NAME) LEN(10) QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) + SPCVAL((*LIBL)) PROMPT('Library') ]]> */ /*--------------------------------------------------------------------------*/ PGM PARM(&INQUAL &OUTQUAL) DCL VAR(&INQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&OUTQUAL) TYPE(*CHAR) LEN(20) DCL VAR(&INFIL) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&INQUAL 1) DCL VAR(&INLIB) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&INQUAL 11) DCL VAR(&OUTFIL) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&OUTQUAL 1) DCL VAR(&OUTLIB) TYPE(*CHAR) STG(*DEFINED) + LEN(10) DEFVAR(&OUTQUAL 11) DCL VAR(&TEXT) TYPE(*CHAR) LEN(50) SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) + MSGDTA('eXtensible Markup Language + generation - in progress') TOPGMQ(*EXT) + MSGTYPE(*STATUS) /* Create/clear out member */ ADDPFM FILE(&OUTLIB/&OUTFIL) MBR(&INFIL) MONMSG MSGID(CPF0000) EXEC(CLRPFM + FILE(&OUTLIB/&OUTFIL) MBR(&INFIL)) CHGVAR VAR(&TEXT) VALUE('Source members for file ' + *CAT &INFIL *TCAT '.') CHGPFM FILE(&OUTLIB/&OUTFIL) MBR(&INFIL) + SRCTYPE(TXT) TEXT(&TEXT) /* Create script member in qtemp */ DLTF FILE(QTEMP/XMLSRCFIL) MONMSG MSGID(CPF0000) CRTSRCPF FILE(QTEMP/XMLSRCFIL) MBR(&INFIL) /* Generate XML */ CALL PGM(XMLSRCFILR) PARM(&INQUAL &OUTQUAL) DLTOVR FILE(*ALL) MONMSG MSGID(CPF0000) /* RMVMSG PGMQ(*PRV) CLEAR(*ALL) */ SNDPGMMSG MSG('Source XML for ' *CAT &INFIL *TCAT ' in + ' *CAT &OUTLIB *TCAT '/' *CAT &OUTFIL + *TCAT ' - completed.') ENDPGM ]]> .*-------------------------------------------------------------------- :P.Adds all members from selected source file into single well-formed XML mbr with all information required to recreate source members on another system. :P.There is maximum of 999,999 records (around 10Meg) 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.:EPNLGRP. ]]> '); //--------------------------------------------------------- // XMLSRCFILR - Generate XML for all members in source file // call XMLGENR to generate XML text. //--------------------------------------------------------- /define ControlStatements /define ApiErrDS /define Quslmbr /define f_BuildString /define f_Quscrtus /define SourceOutDS // *ENTRY /define p_XMLSRCFILR /COPY JCRCMDS,JCRCMDSCPY dcl-f SCRIPT disk(112) usage(*output) extfile('QTEMP/XMLSRCFIL') extmbr(infile) usropn; dcl-s InFile char(10); dcl-s InLib char(10); // Generate XML source member dcl-pr p_XMLGENR extpgm('XMLGENR'); *n char(10); // Script source member *n char(20) const; // Script Src fil lib *n char(20); // Output XML fil lib end-pr; //--------------------------------------------------------- InFile = %subst(p_InFileQual: 1: 10); InLib = %subst(p_InFileQual:11: 10); // load user space with mbr name list for selected files ApiHeadPtr = f_Quscrtus(UserSpaceName); callp QUSLMBR( UserSpaceName: 'MBRL0200': p_InFileQual: '*ALL': '0': ApiErrDS); // Process members in user space, write record to driver file open script; f_Write(' XMLGENINC XINCLUDE(*YES)'); QuslmbrPtr = ApiHeadPtr + ApiHead.OffSetToList; 1b for ForCount = 1 to ApiHead.ListEntryCount; f_Write( f_BuildString(' XMLGENMBR XMBR(&) XMBRATR(&) XFROMSRCF(&) + ': QuslmbrDS.MbrName: QuslmbrDS.MbrType: InFile)); f_Write( f_BuildString(' XFROMSRCL(&) XTOSRCF(&) XOBJTYPE(*N) XGENCRT(*NO)': InLib: InFile)); QuslmbrPtr += ApiHead.ListEntrySize; 1e endfor; //--------------------------------------------------------- // generate outfile close script; callp p_XMLGENR(InFile: 'XMLSRCFIL QTEMP': p_OutFileQual); *inlr = *on; return; //--------------------------------------------------------- // Write generated code to outfile //--------------------------------------------------------- dcl-proc f_Write; dcl-pi *n; pSrcCod char(100) const; end-pi; OutDS.Src100 = pSrcCod; OutDS.SrcSeq += .01; write SCRIPT OutDS; return; end-proc; ]]> '); //--------------------------------------------------------- // XMLSRCFILV - Validity checking program //--------------------------------------------------------- /define ControlStatements /define f_CheckMbr /define f_CheckObj // *ENTRY /define p_XMLSRCFILR /COPY JCRCMDS,JCRCMDSCPY f_CheckMbr(p_InFileQual: '*FIRST'); f_CheckObj(p_OutFileQual: '*FILE'); *inlr = *on; return; ]]>