Skip to content

Instantly share code, notes, and snippets.

@phpdave

phpdave/AphpXMLParser.php

Last active February 23, 2023 22:56
Show Gist options
  • Save phpdave/c23ddf1426eb4f41b9b3999d783bc072 to your computer and use it in GitHub Desktop.
Save phpdave/c23ddf1426eb4f41b9b3999d783bc072 to your computer and use it in GitHub Desktop.
Download ZIP
Raw
AphpXMLParser.php
<?php
$xml = simplexml_load_file('jcrcmds.xml');
$outputdir='./results';
!file_exists($outputdir)?mkdir(outputdir, 0700):"";
foreach ($xml->mbr as $mbr)
{
$filename=$outputdir.'/'.trim($mbr['mbrname']).'.rpg';
$data=(string) $mbr->copysrc;
file_put_contents($filename,$data);
echo $filename.' created.'.PHP_EOL;
}
Raw
jcrcmds.xml
This file has been truncated, but you can view the full file.
<?xml version="1.0" encoding="UTF-8"?>
<upload appname="JCRCMDS" appauthor="Craig Rutledge" appblddate=" 1/06/2017">
<install_instructions><![CDATA[
//---------------------------------------------------------
* 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 <install_program> and end
* tag </install_program> 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(392) TORCD(721)
*
* 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 <mbr)
* JCRANZD CMD Dspf screen layout with field names jcr
* JCRANZDH PNLGRP Dspf screen layout with field names jcr
* JCRANZDP PRTF Dspf screen layout with field names 198 jcr
* JCRANZDR RPGLE Dspf screen layout with field names jcr
* JCRANZO CMD O spec layout with field names jcr
* JCRANZOH PNLGRP O spec layout with field names jcr
* JCRANZOR RPGLE O spec layout with field names jcr
* JCRANZOV RPGLE O spec layout with field names - validity jcr
* JCRANZP CMD Prtf layout with field names jcr
* JCRANZPC CLLE Prtf layout with field names jcr
* JCRANZPH PNLGRP Prtf layout with field names jcr
* JCRANZPR RPGLE Prtf layout with field names jcr
* JCRANZPV RPGLE Prtf layout with field names - validity jcr
* JCRBND CMD Procedure names list jcr
* JCRBNDF DDL Procedure names list - outfile jcr
* JCRBNDH PNLGRP Procedure names list jcr
* JCRBNDP PRTF Procedure names list 198 jcr
* JCRBNDR RPGLE Procedure names list jcr
* JCRBNDV RPGLE Procedure names list - validity jcr
* JCRCALL CMD Command prompt entry parms jcr
* JCRCALLH PNLGRP Command prompt entry parms jcr
* JCRCALLO RPGLE Command prompt entry parms - prompt override jcr
* JCRCALLR RPGLE Command prompt entry parms jcr
* JCRCALLV RPGLE Command prompt entry parms - validity jcr
* JCRCMDSBND BND JCRCMDS binder language jcr
* JCRCMDSCPY RPGLE JCRCMDS copy book repository jcr
* JCRCMDSSRV RPGLE JCRCMDS service program source jcr
* JCRCOMPOST CLLE JCRCMDS recompile library jcr
* JCRCOMPSRV CLLE JCRCMDS recompile service program only jcr
* JCRDBR CMD Data base relations done quicker jcr
* JCRDBRH PNLGRP Data base relations done quicker jcr
* JCRDDL CMD Generate data definition language member jcr
* JCRDDLH PNLGRP Generate data definition language member jcr
* JCRDDLR RPGLE Generate data definition language member jcr
* JCRDDLV RPGLE Generate data definition language member jcr
* JCRDQD CMD Data queue description display jcr
* JCRDQDD DSPF Data queue description display jcr
* JCRDQDH PNLGRP Data queue description display jcr
* JCRDQDR RPGLE Data queue description display jcr
* JCRDQE CMD Data queue entries display jcr
* JCRDQED DSPF Data queue entries display jcr
* JCRDQEH PNLGRP Data queue entries display jcr
* JCRDQER RPGLE Data queue entries display jcr
* JCRDTAARA CMD Dtaara values and rollover distance list jcr
* JCRDTAARAH PNLGRP Dtaara values and rollover distance list jcr
* JCRDTAARAP PRTF Dtaara values and rollover distance list 198 jcr
* JCRDTAARAR RPGLE Dtaara values and rollover distance list jcr
* JCRDUMP CMD Dump count by program jcr
* JCRDUMPD DSPF Dump count by program jcr
* JCRDUMPH PNLGRP Dump count by program jcr
* JCRDUMPP PRTF Dump count by program jcr
* JCRDUMPR SQLRPGLE Dump count by program jcr
* JCRDUPKEY CMD Duplicate keyed logicals list jcr
* JCRDUPKEYH PNLGRP Duplicate keyed logicals list jcr
* JCRDUPKEYP PRTF Duplicate keyed logicals list jcr
* JCRDUPKEYR RPGLE Duplicate keyed logicals list jcr
* JCRFD CMD File descriptions jcr
* JCRFDD DSPF File descriptions jcr
* JCRFDH PNLGRP File descriptions jcr
* JCRFDMBRD DSPF File descriptions - member list jcr
* JCRFDMBRR RPGLE File descriptions - member list jcr
* JCRFDP PRTF File descriptions jcr
* JCRFDR RPGLE File descriptions jcr
* JCRFFD CMD File field descriptions jcr
* JCRFFDD DSPF File field descriptions jcr
* JCRFFDF DDL File field descriptions - outfile jcr
* JCRFFDH PNLGRP File field descriptions jcr
* JCRFFDP PRTF File field descriptions jcr
* JCRFFDR RPGLE File field descriptions jcr
* JCRFFDV RPGLE File field descriptions - validity jcr
* JCRFREESS CMD Free/fixed side-by-side source view jcr
* JCRFREESSH PNLGRP Free/fixed side-by-side source view jcr
* JCRFREESSP PRTF Free/fixed side-by-side source view 198 jcr
* JCRFREESSR RPGLE Free/fixed side-by-side source view jcr
* JCRFSET CMD Scan file set where used jcr
* JCRFSETF DDL Scan file set where used - outfile jcr
* JCRFSETH PNLGRP Scan file set where used jcr
* JCRFSETP PRTF Scan file set where used 198 jcr
* JCRFSETR RPGLE Scan file set where used - scanner jcr
* JCRFSETS RPGLE Scan file set where used - sbmjob jcr
* JCRFSETV RPGLE Scan file set where used - validity jcr
* JCRF7 RPGLE Seu exit program f7 split/combine line jcr
* JCRGAMES CMD Games selection menu jcr
* JCRGAMESC CLLE Games selection menu jcr
* JCRGAMESD DSPF Games selection menu jcr
* JCRGAMESH PNLGRP Games selection menu jcr
* JCRGETCLPR RPGLE Get parm list and attributes from CLx pgms jcr
* JCRGETFILR RPGLE Get file format/file xref from RPG4 source jcr
* JCRGETFLDR RPGLE Get field attributes from RPG4 programs jcr
* JCRGMBLJ RPGLE BlackJack 21 jcr
* JCRGMBLJD DSPF BlackJack 21 jcr
* JCRGMBTL RPGLE BattleShip jcr
* JCRGMBTLD DSPF BattleShip jcr
* JCRGMCRB RPGLE Cribbage jcr
* JCRGMCRBD DSPF Cribbage jcr
* JCRGMMINE RPGLE Erdos Tibor Mine Sweeper
* JCRGMMINED DSPF Erdos Tibor Mine Sweeper
* JCRGMPOK RPGLE Video Poker jcr
* JCRGMPOKD DSPF Video Poker jcr
* JCRGMPYR RPGLE Pyramid Solitaire jcr
* JCRGMPYRD DSPF Pyramid Solitaire jcr
* JCRGMTIC RPGLE Tic/Tac/Toe jcr
* JCRGMTICD DSPF Tic-Tac-Toe jcr
* JCRGMYAT RPGLE Yahtzee jcr
* JCRGMYATD DSPF Yahtzee jcr
* JCRHEXCHR RPGLE Hex/Biton patterns to produce characters jcr
* JCRHEXCHRD DSPF Hex/Biton patterns to produce characters jcr
* JCRHEXD DSPF dec to hex convertor jcr
* JCRHEXR RPGLE hex to dec convertor jcr
* JCRHFD CMD Rpg H,F,D to free jcr
* JCRHFDH PNLGRP Rpg H,F,D to free jcr
* JCRHFDR RPGLE Rpg H,F,D to free jcr
* JCRHFDV RPGLE Rpg H,F,D to free - validity jcr
* JCRIFSCPY CMD Copy from IFS directory jcr
* JCRIFSCPYD DSPF Copy from IFS directory jcr
* JCRIFSCPYH PNLGRP Copy from IFS directory jcr
* JCRIFSCPYR RPGLE Copy from IFS directory jcr
* JCRIFSCPYV RPGLE Copy from IFS directory - validity jcr
* JCRIFSMBR CMD Copy source member to IFS jcr
* JCRIFSMBRH PNLGRP Copy source member to IFS jcr
* JCRIFSMBRR RPGLE Copy source member to IFS jcr
* JCRIFSMBRV RPGLE Copy source member to IFS jcr
* JCRIFSSAV CMD Copy savf to to IFS jcr
* JCRIFSSAVH PNLGRP Copy savf to IFS jcr
* JCRIFSSAVR RPGLE Copy savf to IFS jcr
* JCRIFSSAVV RPGLE Copy savf to IFS jcr
* JCRIND CMD Indicator List jcr
* JCRINDD DSPF Indicator List jcr
* JCRINDH PNLGRP Indicator List jcr
* JCRINDR RPGLE Indicator List jcr
* JCRINDV RPGLE Indicator List jcr
* JCRJOBDL CMD List jobd using selected Library jcr
* JCRJOBDLH PNLGRP List jobd using selected Library jcr
* JCRJOBDLP PRTF List jobd using selected Library jcr
* JCRJOBDLR RPGLE List jobd using selected Library jcr
* JCRJOBDQ CMD List jobd using selected JOBQ jcr
* JCRJOBDQH PNLGRP List jobd using selected JOBQ jcr
* JCRJOBDQP PRTF List jobd using selected JOBQ jcr
* JCRJOBDQR RPGLE List jobd using selected JOBQ jcr
* JCRJOBS CMD Work with selected jobs jcr
* JCRJOBSD DSPF Work with selected jobs jcr
* JCRJOBSH PNLGRP Work with selected jobs jcr
* JCRJOBSIOD DSPF Work with selected jobs - I/O display jcr
* JCRJOBSIOR RPGLE Work with selected jobs - I/O display jcr
* JCRJOBSR RPGLE Work with selected jobs jcr
* JCRLICUSE RPGLE List users with license lock jcr
* JCRLKEY CMD Find desired access path jcr
* JCRLKEYD DSPF Find desired access path jcr
* JCRLKEYH PNLGRP Find desired access path jcr
* JCRLKEYR RPGLE Find desired access path jcr
* JCRLOG CMD Retrieve previously executed commands jcr
* JCRLOGD DSPF Retrieve previously executed commands jcr
* JCRLOGH PNLGRP Retrieve previously executed commands jcr
* JCRLOGR RPGLE Retrieve previously executed commands jcr
* JCRLSRC CMD Source location - Pgm/Mod/Srvpgm info jcr
* JCRLSRCF DDL Source location - Pgm/Mod/Srvpgm - outfile jcr
* JCRLSRCH PNLGRP Source location - Pgm/Mod/Srvpgm info jcr
* JCRLSRCP PRTF Source location - Pgm/Mod/Srvpgm info jcr
* JCRLSRCR RPGLE Source location - Pgm/Mod/Srvpgm info jcr
* JCRLSRCV RPGLE Source location - Pgm/Mod/Srvpgm info valid jcr
* JCRMIKE CMD Show programs procedure location / source jcr
* JCRMIKEH PNLGRP show programs procedure location / source jcr
* JCRMIKEP PRTF show programs procedure location / source jcr
* JCRMIKER RPGLE show programs procedure location / source jcr
* JCRMRBIG CMD Print big 12 row by 13 column characters jcr
* JCRMRBIGH PNLGRP Print big 12 row by 13 column characters jcr
* JCRMRBIGP PRTF Print big 12 row by 13 column characters jcr
* JCRMRBIGR RPGLE Print big 12 row by 13 column characters jcr
* JCRNETFF CMD Send multiple network files to multiple users jcr
* JCRNETFFH PNLGRP Send multiple network files to multiple users jcr
* JCRNETFFR RPGLE Send multiple network files to multiple users jcr
* JCRNETFFV RPGLE Send multiple network files to multiple users jcr
* JCRNETFM CMD Send network file multiple members jcr
* JCRNETFMH PNLGRP Send network file multiple members jcr
* JCRNETFMR RPGLE Send network file multiple members jcr
* JCRNETFMV RPGLE Send network file multiple members jcr
* JCRNETQ CMD Send network file entire outq jcr
* JCRNETQH PNLGRP Send network file entire outq jcr
* JCRNETQR RPGLE Send network file entire outq jcr
* JCRNOTPOP CMD List fields not populated jcr
* JCRNOTPOPC CLLE List fields not populated jcr
* JCRNOTPOPH PNLGRP List fields not populated jcr
* JCRNOTPOPP PRTF List fields not populated jcr
* JCRNOTPOPR RPGLE List fields not populated jcr
* JCRNOTPOPV RPGLE List fields not populated - validity jcr
* JCRNUMB CMD Number logic structures in RPGLE source jcr
* JCRNUMBH PNLGRP Number logic structures in RPGLE source jcr
* JCRNUMBR RPGLE Number logic structures in RPGLE source jcr
* JCROBJD CMD Expanded work with object descriptions jcr
* JCROBJDD DSPF Expanded work with object descriptions jcr
* JCROBJDH PNLGRP Expanded work with object descriptions jcr
* JCROBJDR RPGLE Expanded work with object descriptions jcr
* JCROLCK CMD Object lock list-sndbrkmsg or endjob(*immed) jcr
* JCROLCKD DSPF Object lock list-sndbrkmsg or endjob(*immed) jcr
* JCROLCKH PNLGRP Object lock list-sndbrkmsg or endjob(*immed) jcr
* JCROLCKR RPGLE Object lock list-sndbrkmsg or endjob(*immed) jcr
* JCRPARTI CMD Retrieve partition info for current system jcr
* JCRPARTIH PNLGRP Retrieve partition info for current system jcr
* JCRPARTIR RPGLE Retrieve partition info for current system jcr
* JCRPATTR CMD Crtprtf with attributes from existing PRTF jcr
* JCRPATTRH PNLGRP Crtprtf with attributes from existing PRTF jcr
* JCRPATTRR RPGLE Crtprtf with attributes from existing PRTF jcr
* JCRPATTRV RPGLE Crtprtf with attributes from existing PRTF jcr
* JCRPRGEN CMD Generate callp prototype jcr
* JCRPRGENH PNLGRP Generate callp prototype jcr
* JCRPRGENO RPGLE Command prompt entry parms - prompt override jcr
* JCRPRGENR RPGLE Generate callp prototype jcr
* JCRPRGENV RPGLE Generate callp prototype - validity jcr
* JCRPROTO CMD Convert *entry/call parms to prototypes jcr
* JCRPROTOH PNLGRP Convert *entry/call parms to prototypes jcr
* JCRPROTOR RPGLE Convert *entry/call parms to prototypes jcr
* JCRPROTOV RPGLE Convert *entry/call parms to prototypes jcr
* JCRPRTF CMD Generate external print file from RPG4 Ospecs jcr
* JCRPRTFH PNLGRP Generate external print file from RPG4 Ospecs jcr
* JCRPRTFR RPGLE Generate external print file from RPG4 Ospecs jcr
* JCRPRTFV RPGLE Generate external print file from RPG4 Ospecs jcr
* JCRRECRT CMD Recreate *CMD using existing values jcr
* JCRRECRTH PNLGRP Recreate *CMD using existing values jcr
* JCRRECRTR RPGLE Recreate *CMD using existing values jcr
* JCRRFIL CMD File Record Format xref for RPG source jcr
* JCRRFILD DSPF File Record Format xref for RPG source jcr
* JCRRFILH PNLGRP File Record Format xref for RPG source jcr
* JCRRFILR RPGLE File Record Format xref for RPG source jcr
* JCRRFILV RPGLE File Record Format xref for RPG source jcr
* JCRRFLD CMD Fields in RPG source jcr
* JCRRFLDD DSPF Fields in RPG source jcr
* JCRRFLDF DDL Fields in RPG source - outfile jcr
* JCRRFLDH PNLGRP Fields in RPG source jcr
* JCRRFLDP PRTF Fields in RPG source jcr
* JCRRFLDR RPGLE Fields in RPG source jcr
* JCRRFLDV RPGLE Fields in RPG source - validity jcr
* JCRROUGH CMD Generate rough DDS prtf source from SPLF jcr
* JCRROUGHH PNLGRP Generate rough DDS prtf source from SPLF jcr
* JCRROUGHR RPGLE Generate rough DDS prtf source from SPLF jcr
* JCRROUGHV RPGLE Generate rough DDS prtf source from SPLF jcr
* JCRRTVRPG CMD Retrieve RPGLE source from compiled object jcr
* JCRRTVRPGC CLLE Retrieve RPGLE source from compiled object jcr
* JCRRTVRPGH PNLGRP Retrieve RPGLE source from compiled object jcr
* JCRRTVRPGR RPGLE Retrieve RPGLE source from compiled object jcr
* JCRRTVRPGV RPGLE Retrieve RPGLE source from compiled object jcr
* JCRSBSDP PRTF List subsystem pools and routing ids jcr
* JCRSBSDR RPGLE List subsystem pools and routing ids jcr
* JCRSDENT CMD Show Source Indentation jcr
* JCRSDENTH PNLGRP Show Source Indentation jcr
* JCRSDENTP PRTF Show Source Indentation jcr
* JCRSDENTR RPGLE Show Source Indentation jcr
* JCRSMLT CMD Scan mult source file/mbrs for mult strings jcr
* JCRSMLTCHF PF Scan mult source file/mbrs - preselected list jcr
* JCRSMLTF DDL Scan mult source file/mbrs - outfile jcr
* JCRSMLTH PNLGRP Scan mult source file/mbrs - Help jcr
* JCRSMLTP PRTF Scan mult source file/mbrs - print file 198 jcr
* JCRSMLTR RPGLE Scan mult source file/mbrs - scanner jcr
* JCRSMLTRC RPGLE Scan mult source file/mbrs - choice program jcr
* JCRSMLTRS RPGLE Scan mult source file/mbrs - submit scanner jcr
* JCRSMLTV RPGLE Scan mult source file/mbrs - validity jcr
* JCRSPLF CMD List spool files with Options jcr
* JCRSPLFD DSPF List spool files with Options jcr
* JCRSPLFD2 DSPF List spool files with Options - dup splf jcr
* JCRSPLFH PNLGRP List spool files with Options jcr
* JCRSPLFR RPGLE List spool files with Options jcr
* JCRSPLFR2 RPGLE List spool files with Options - dup splf jcr
* JCRSPLFV RPGLE List spool files with Options - validity jcr
* JCRSSQL CMD Scan strsql sessions for sql statements jcr
* JCRSSQLC CLLE Scan strsql sessions for sql statements jcr
* JCRSSQLD DSPF Scan strsql sessions for sql statements jcr
* JCRSSQLE RPGLE Scan strsql sessions Execute sql statements jcr
* JCRSSQLH PNLGRP Scan strsql sessions for sql statements jcr
* JCRSSQLR RPGLE Scan strsql sessions for sql statements jcr
* JCRSUBR CMD Subroutines List jcr
* JCRSUBRH PNLGRP Subroutines List jcr
* JCRSUBRP PRTF Subroutines List jcr
* JCRSUBRPF PF Subroutines List jcr
* JCRSUBRR1 RPGLE Subroutines List - build work file jcr
* JCRSUBRR2 RPGLE Subroutines List - print report jcr
* JCRSUNDRY CMD Sundry programs selection menu jcr
* JCRSUNDRYC CLLE Sundry programs selection menu jcr
* JCRSUNDRYD DSPF Sundry programs selection menu jcr
* JCRSUNDRYH PNLGRP Sundry programs selection menu jcr
* JCRUFIND CMD Find string in user spaces jcr
* JCRUFINDD DSPF Find string in user spaces jcr
* JCRUFINDF DDL Find string in user spaces - outfile jcr
* JCRUFINDH PNLGRP Find string in user spaces jcr
* JCRUFINDR RPGLE Find string in user spaces jcr
* JCRUFINDV RPGLE Find string in user spaces - validity jcr
* JCRUSPACE CMD User space data display jcr
* JCRUSPACED DSPF User space data display jcr
* JCRUSPACEH PNLGRP User space data display jcr
* JCRUSPACER RPGLE User space data display jcr
* JCRUSPACEV RPGLE User space data display - validity jcr
* JCRUSRAUT CMD User profile class/special authorities list jcr
* JCRUSRAUTH PNLGRP User profile class/special authorities list jcr
* JCRUSRAUTP PRTF User profile class/special authorities list jcr
* JCRUSRAUTR RPGLE User profile class/special authorities list jcr
* JCRUSREMLP PRTF User profile retrieve email address list jcr
* JCRUSREMLR RPGLE User profile retrieve email address list jcr
* JCRUSRJOBD CMD User profile with selected JOBD list jcr
* JCRUSRJOBH PNLGRP User profile with selected JOBD list jcr
* JCRUSRJOBP PRTF User profile with selected JOBD list jcr
* JCRUSRJOBR RPGLE User profile with selected JOBD list jcr
* JCRUSROUTH PNLGRP User profile with selected OUTQ list jcr
* JCRUSROUTP PRTF User profile with selected OUTQ list jcr
* JCRUSROUTQ CMD User profile with selected OUTQ list jcr
* JCRUSROUTR RPGLE User profile with selected OUTQ list jcr
* JCRUSRPRFP PRTF User profile last signon date list jcr
* JCRUSRPRFR RPGLE User profile last signon date list jcr
* JCRVALLIBV RPGLE Validity checker for library name jcr
* JCRVALMBRV RPGLE Validity checker for mbr/file/lib jcr
* JCRVALOBJV RPGLE Validity checker for lib/obj objtype jcr
* JCRXML CMD XML programs selection menu jcr
* JCRXMLC CLLE XML programs selection menu jcr
* JCRXMLD DSPF XML programs selection menu jcr
* JCRXMLH PNLGRP XML programs selection menu jcr
* JCRZANIM0 RPGLE Animation- binary clock jcr
* JCRZANIM0D DSPF Animation- binary Clock jcr
* JCRZANIM3 RPGLE Animation- raise the flag jcr
* JCRZANIM3D DSPF Animation- raise the flag jcr
* JCRZANIM4 RPGLE Animation- I am with stupid jcr
* JCRZANIM4D DSPF Animation- I am with stupid jcr
* JCRZANIM5 RPGLE Animation- to boldly go jcr
* JCRZANIM5D DSPF Animation- to boldly go jcr
* JCRZANIM6 RPGLE Animation- racquetball cutthroat serve rotate jcr
* JCRZANIM6D DSPF Animation- racquetball cutthroat serve rotate jcr
* JCR4MAX CMD Rpg4 source to full rpg4 syntax jcr
* JCR4MAXC CLLE Rpg4 source to full rpg4 syntax jcr
* JCR4MAXH PNLGRP Rpg4 source to full rpg4 syntax jcr
* JCR4MAXR1 RPGLE Rpg4 source to full rpg4 syntax-Logic factor2 jcr
* JCR4MAXR2 RPGLE Rpg4 source to full rpg4 syntax-Eval opcode jcr
* JCR4MAXR3 RPGLE Rpg4 source to full rpg4 syntax-Lower case jcr
* JCR4MAXR4 RPGLE Rpg4 source to full rpg4 syntax-D specs jcr
* JCR4MAXV RPGLE Rpg4 source to full rpg4 syntax - validity jcr
* JCR4PROTO CMD Convert *entry/call parms to fixed format PR jcr
* JCR4PROTOH PNLGRP Convert *entry/call parms to fixed format PR jcr
* JCR4PROTOR RPGLE Convert *entry/call parms to fixed format PR jcr
* JCR5FREE CMD Convert fixed column calcs to /free format jcr
* JCR5FREEH PNLGRP Convert fixed column calcs to /free format jcr
* JCR5FREER RPGLE Convert fixed column calcs to /free format jcr
* JCR5FREEV RPGLE Convert fixed column calcs to /free format v jcr
* XMLGEN CMD Generate XML source member from script member jcr
* XMLGENC CLLE Generate XML source member jcr
* XMLGENCMD CMD Generate XML source member-Command prompt jcr
* XMLGENH PNLGRP Generate XML source member jcr
* XMLGENINC CMD Generate XML source member-Include install jcr
* XMLGENINS RPGLE Generate XML source member-Source install pgm jcr
* XMLGENMBR CMD Generate XML source member-Source member jcr
* XMLGENR RPGLE Generate XML source member jcr
* XMLGENV RPGLE Generate XML source member - validity jcr
* XMLPREVIEC CLLE Preview uploaded XML install members jcr
* XMLPREVIED DSPF Preview uploaded XML install members jcr
* XMLPREVIEH PNLGRP Preview uploaded XML install members jcr
* XMLPREVIER RPGLE Preview uploaded XML install members jcr
* XMLPREVIEW CMD Preview uploaded XML install members jcr
* XMLPREVINR RPGLE Extract embedded installer code from text jcr
* XMLSCRIPT CMD XML Script Member Viewer jcr
* XMLSCRIPTD DSPF XML Script Member Viewer jcr
* XMLSCRIPTH PNLGRP XML Script Member Viewer jcr
* XMLSCRIPTR RPGLE XML Script Member Viewer jcr
* XMLSRCFIL CMD Generate XML for all members in source file jcr
* XMLSRCFILC CLLE Generate XML for all members in source file jcr
* XMLSRCFILH PNLGRP Generate XML for all members in source file jcr
* XMLSRCFILR RPGLE Generate XML for all members in source file jcr
* XMLSRCFILV RPGLE Generate XML for all members in source file jcr
*
//---------------------------------------------------------
]]> </install_instructions>
<install_program><![CDATA[
* /// START OF INSTALL PGM HERE *V7R1********************* ///
//---------------------------------------------------------
// Parse / Install from XML text into source members and objects.
//---------------------------------------------------------
ctl-opt option(*nodebugio: *nounref) dftactgrp(*no) actgrp(*caller);
dcl-f XMLINPUT disk(112) extfile(extIfile) extmbr(p_UploadMbr) usropn;
dcl-ds InputDS;
xmltag1 char(9) pos(13);
xmltag2 char(10) pos(18);
SlashCopy char(5) pos(19);
xmlcode char(100) pos(13);
end-ds;
dcl-f MBRSRC disk(112) usage(*output) extfile(extOfile) extmbr(mbrname)
usropn;
dcl-ds mbrsrcDS 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 extIfile char(21);
dcl-s extOFile char(21);
dcl-s ReceiverVar char(145);
dcl-s Msgid char(7);
dcl-s Msgtxt char(65);
dcl-s Msgq char(10);
dcl-s Msgtyp char(10);
dcl-s mbrname char(10);
dcl-s mbrtype char(10);
dcl-s mbrtext char(50);
dcl-s srcfile char(10);
dcl-s srclen char(5);
dcl-s srcccsid char(5);
dcl-s bldexc char(500);
dcl-s UpSlash char(5);
dcl-s IsWrite ind;
dcl-s aa uns(5);
dcl-s bb uns(5);
dcl-s Start uns(3);
dcl-c qs const(''''); // single quote
dcl-c up const('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
dcl-c lo const('abcdefghijklmnopqrstuvwxyz');
//---------------------------------------------------------
// error return code parm for APIs
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-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;
dcl-pr Qmhsndpm extpgm('QMHSNDPM'); // send program message
*n char(7) const; // message id
*n char(20) const; // file and lib
*n like(Msgtxt); // 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;
dcl-pr qcmdexc extpgm('QCMDEXC'); // CL Command Processor
*n char(500) options(*varsize);
*n packed(15: 5) const;
end-pr;
//--*ENTRY-------------------------------------------------
dcl-pi *n;
p_UploadMbr char(10);
p_UploadSrcFil char(10);
p_UploadSrcLib char(10);
p_OvrSrcFile char(10) options(*nopass);
end-pi;
//---------------------------------------------------------
// validate file, lib, and member exist
callp Qusrmbrd(ReceiverVar: 145:'MBRD0100':
p_UploadSrcFil + p_UploadSrcLib: p_UploadMbr:
'0': ApiErrDS);
// Throw exception message if error occurred
1b if ApiErrDS.BytesReturned > 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 = '</copysrc>');
//----------------------------------------------------
// if /copy AND user has selected custom install file,
// change statements to find copybooks in new file.
//----------------------------------------------------
4b if %parms = %parmnum(p_OvrSrcFile);
UpSlash = %xlate(lo: up: SlashCopy);
5b if UpSlash = '/COPY'
or UpSlash = '/INCL';
Start = 12;
6b if UpSlash = '/INCL';
Start = 15;
6e endif;
aa = %scan(',': xmlcode: Start); //find start of member
6b if aa = 0;
aa = %check(' ': xmlcode: Start) - 1;
6e endif;
xmlcode = %subst(xmlcode: 1: Start) +
%trimr(p_UploadSrcLib) + '/' +
%trimr(p_OvrSrcFile) + ',' + %subst(xmlcode: (aa + 1));
5e endif;
4e endif;
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 = '<copysrc>';
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 = '<compile>';
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 = '<qcmdexc>';
clear bldexc;
aa = 1;
read xmlinput inputDS;
3b dow not(xmltag2 = '</qcmdexc>');
%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 <sendmsg>
// read record and get single line of message text
2x elseif xmltag1 = '<sendmsg ';
Msgid = %subst(xmlcode: 22:7);
Msgtyp = %subst(xmlcode: 46: 10);
read xmlinput inputDS;
Msgq = '*EXT';
3b if Msgtyp = '*COMP';
Msgq = '*PGMBDY';
3e endif;
Msgtxt = xmlcode;
exsr srSndMessage;
2e endif;
read xmlinput inputDS;
1e enddo;
*inlr = *on;
return;
//---------------------------------------------------------
// Replace &tolib (no matter how many times it is in string)
// with whatever library user has selected at run time.
begsr srTolibToken;
bldexc = %scanrpl('&tolib': %trimr(p_UploadSrcLib): bldexc);
// user has selected to override source, reset SRCFILE parm in bldexcs.
1b if %parms = 4; //xmlpreview override
aa = %scan('SRCFILE(': bldexc);
2b if aa > 0;
aa = %scan('/': bldexc: aa);
3b if aa > 0;
bb = %scan(')': bldexc: aa);
bldexc = %replace(%trimr(p_OvrSrcFile):
bldexc: aa + 1: bb-(aa + 1));
3e endif;
2e endif;
1e endif;
endsr;
//---------------------------------------------------------
begsr srSndMessage;
callp QMHSNDPM(
Msgid:
'QCPFMSG *LIBL':
Msgtxt:
%size(Msgtxt):
Msgtyp:
Msgq:
1:
' ':
ApiErrDS);
endsr;
* /// END OF INSTALL PGM HERE /// do not copy past this point *** ///
]]> </install_program>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZD type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZD "
mbrtype = "CMD "
mbrtext = "Dspf screen layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRANZD - DSPF screen layout with field names - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZDH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZDH "
mbrtype = "PNLGRP "
mbrtext = "Dspf screen layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRANZD'.DSPF Field Layout (JCRANZD) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZDP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZDP "
mbrtype = "PRTF "
mbrtext = "Dspf screen layout with field names 198 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRANZDP - DSPF screen layout with field names - PRTF
* note: print file is used by ospec and prtf layout reports
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 198)
A R PRTHEAD SKIPB(1) SPACEA(2)
A SCOBJHEAD 105A 2
A SCDOW 9A O 110
A 120DATE EDTCDE(Y)
*----------------------------------------------------------------
A R PRTLINE SPACEA(1)
A LAYOUT 198A 1
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZDR "
mbrtype = "RPGLE "
mbrtext = "Dspf screen layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 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 = x'06' // hidden
or QDFFFINFds.FieldAttribute = x'07'; // program communication
4x else;
row = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(cc):1:1));
col = f_CvtHexToInt(%subst(QDFFRCTBds.QDFFRCTEds(cc):2:1));
col += 1;
// goofy API
5b if col > MaxCol;
col -= MaxCol;
row += 1;
5e endif;
//---------------------------------------------------------
// If Row number changes, print current buffers and start
// loading buffers for next row
//---------------------------------------------------------
5b if cc = 1;
PrintRow = row;
5e endif;
5b if PrintRow <> row;
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 = x'00'
or QDFFFNAMds.DataType = x'01'; // Alpha
FillChar = *all'X';
7x else;
FillChar = *all'9';
8b if QDFFFDPDds.OffsetToQDFFCOSA > 0
and ProgramLen < 15;
IsEdit = *off;
exsr srCategoryKeys;
9b if IsEdit;
FillChar = ReceiverVar;
9e endif;
8e endif;
7e endif;
7b if col < 133;
%subst(Layout:Col) =
%subst(FillChar:1:QDFFFITBds.DisplayLength);
8b if FieldNam > *blanks;
exsr srStagger;
8e endif;
7e endif;
6e endif;
5e endif;
4e endif;
4b if cc < QDFFRINFds.NumFields;
QDFWFLDIptr += QDFWFLDIds.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 rr = 1 to 6;
2b if FldNameRowArry(rr) > *blanks;
LayOut = FldNameRowArry(rr);
write PrtLine;
2e endif;
1e endfor;
Layout = *blanks;
FldNameRowArry(*) = *blanks;
endsr;
//---------------------------------------------------------
// Stagger field names if short length fields
// 9 99 666
// Fieldname1
// Fieldname2
// Fieldname3
//---------------------------------------------------------
begsr srStagger;
NameSpace = col; // no contiguous names Field1Field2
1b if col = 1;
NameSpace = 2;
1e endif;
1b for rr = 1 to 6;
2b if %subst(FldNameRowArry(rr): NameSpace - 1: 1) = *blanks;
%subst(FldNameRowArry(rr): col) = FieldNam;
1v leave;
2e endif;
1e endfor;
endsr;
//---------------------------------------------------------
begsr srCategoryKeys;
1b if QDFFFDPDds.OffsetToQDFFCOSA > 0; // has keywords
// Get Keyword Category Displacement String (QDFFCOSA)
QDFFCOSAptr = QDFFFINFptr + QDFFFDPDds.OffsetToQDFFCOSA;
QDFFCCOAptr = QDFFCOSAptr + 2;
2b for zz = 1 to QDFFCOSAds.NumberEntries;
// Get editing for field
3b if QDFFCCOAds.Category = x'24';
IsEdit = *on;
QDFKEDTRptr =
QDFFFINFptr + QDFFCCOAds.OffsetToCategory;
QDFKEDTPptr = QDFKEDTRptr + 2;
ZeroSuppress = QDFKEDTPds.ZeroSuppress;
EditMaskLen = QDFKEDTPds.LenEditMask;
EditMask = %subst(QDFKEDTPds.EditMask:1:EditMaskLen);
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZO type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZO "
mbrtype = "CMD "
mbrtext = "O spec layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRANZO - O spec layout with field names print - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZOH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZOH "
mbrtype = "PNLGRP "
mbrtext = "O spec layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRANZO'.O SPEC Layout Print (JCRANZO) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZOR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZOR "
mbrtype = "RPGLE "
mbrtext = "O spec layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 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 SrcDS.SpecType = 'P'
or SrcDS.SpecType = 'p';
1v leave;
2e endif;
SrcDS.oAndOr = %xlate(lo: up: SrcDS.oAndOr);
2b if (SrcDS.SpecType = 'O'
or SrcDS.SpecType = 'o')
and
(not(SrcDS.Asterisk = '*' or SrcDS.Asterisk = '/'))
and
(not(SrcDS.oAndOr = 'OR' or SrcDS.oAndOr = 'AND'));
IsFoundOspec = *on;
//---------------------------------------------------------
// First, print field data for previous line.
// Spaces are loaded with '_' then is loaded into printing array.
//---------------------------------------------------------
3b if SrcDS.oLineType > *blanks;
4b if FirstTime = 'NO';
write prtLine;
5b if p_ShowNames = '*YES';
6b for cc = 1 to StaggerDepth;
LayOut = StaggerNam(cc);
write PrtLine;
6e endfor;
5e endif;
Layout = *blanks;
StaggerDepth = 0;
StaggerNam(*) = *blanks;
EndPosX = 0;
LastEndPos = 0;
4e endif;
FirstTime = 'NO';
//---------------------------------------------------------
// Take Record Format line and replace
// the spaces with underscores for printing asthetics
//---------------------------------------------------------
LayOut = *blanks;
4b if p_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';
2b for cc = 1 to StaggerDepth;
LayOut = StaggerNam(cc);
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 = %xlate(lo: up: 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 = %xlate(lo: up: SrcDS.oEditCode);
2e endif;
// Create edit mask required to apply edit code
callp QECCVTEC(
ReceiverVar:
EditMaskLen:
ReceiverVarLen:
' ':
SrcDS.oEditCode:
' ':
30:
9:
ApiErrDS);
EditMask = ReceiverVar;
//---------------------------------------------------------
// Apply edit mask generated by edit code
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZOV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZOV "
mbrtype = "RPGLE "
mbrtext = "O spec layout with field names - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 = %xlate(lo: up: 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZP type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZP "
mbrtype = "CMD "
mbrtext = "Prtf layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRANZP - PRTF layout with field names print - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZPC type CLLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZPC "
mbrtype = "CLLE "
mbrtext = "Prtf layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRANZPC - PRTF layout with field names print - CMDPGM */
/* Target prtf is compiled to get expanded listing. */
/* Listing is copied to data file and read to generate report layout. */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZPH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZPH "
mbrtype = "PNLGRP "
mbrtext = "Prtf layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRANZP'.PRTF Field Layout Print (JCRANZP) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZPR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZPR "
mbrtype = "RPGLE "
mbrtext = "Prtf layout with field names jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 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) pos(2);
aNameType char(1) pos(26);
sRcdFmtName char(12) pos(26);
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 int(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-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 = 'PAGNBR'
or BlocDta = 'DATE'
or BlocDta = 'DATE(*SYS)'
or BlocDta = 'DATE(*JOB)'
or BlocDta = 'DATE(*YY)'
or BlocDta = 'DATE(*Y)'
or BlocDta = 'DATE(*SYS)'
or BlocDta = 'TIME';
BlocDta = %trimr(BlocDta) + ' ' + aConstant;
5x else;
BlocDta = %trimr(BlocDta) + aConstant;
5e endif;
4e endif;
3e endif;
2e endif;
read ddslist 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';
3b for cc = 1 to StaggerDepth;
LayOut = StaggerNam(cc);
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 = 'L'
or FieldsAttrDS.DataType = 'T'
or FieldsAttrDS.DataType = '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(' +
%trimr(f_BuildEditWord(blocdta: 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';
3b for cc = 1 to StaggerDepth;
LayOut = StaggerNam(cc);
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 xg = 1 to 40;
2b if (EditedDS.EditedArry(xg) > ' '
and EditedDS.EditedArry(xg) <> '0');
3b if (DecimalPos = 0
and EditedDS.EditedArry(xg) = '.');
3x else;
EndPosX += 1;
4b if EndPosX > 198;
EndPosX = 198;
4e endif;
4b if LoadNamFlg = 'Start FldNam';
exsr srLoadFieldName;
4e endif;
4b if EndPosX > 0 and EndPosX < 199;
%subst(Layout: EndPosx:1) = EditedDS.EditedArry(xg);
4e endif;
3e endif;
2e endif;
1e endfor;
endsr;
//---------------------------------------------------------
// Process numeric fields 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 EndPosX < 1 or EndPosX > 198;
1v leave;
2e endif;
%subst(Layout: EndPosx:1) = 'X';
1e endfor;
endsr;
//---------------------------------------------------------
// Load field names under data representations
begsr srLoadFieldName;
xh = EndPosX - 1;
1b if xh <= 0;
xh = 1;
1e endif;
xf = EndPosX;
exsr srStagger;
LoadNamFlg = *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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRANZPV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRANZPV "
mbrtype = "RPGLE "
mbrtext = "Prtf layout with field names - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBND type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBND "
mbrtype = "CMD "
mbrtext = "Procedure names list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRBND - Procedure names list - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBNDF type DDL - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBNDF "
mbrtype = "DDL "
mbrtext = "Procedure names list - outfile jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
-- ----------------------------------------------------------------
-- JCRBNDF - Procedure names list - DDL
-- Craig Rutledge < www.jcrcmds.com >
-- ----------------------------------------------------------------
-- 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 ;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBNDH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBNDH "
mbrtype = "PNLGRP "
mbrtext = "Procedure names list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRBND'.Procedure Names List (JCRBND) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBNDP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBNDP "
mbrtype = "PRTF "
mbrtext = "Procedure names list 198 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRBNDP - Procedure names list - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 198) CPI(15)
A R PRTHEAD SKIPB(1) SPACEA(1)
A 2'JCRBNDR'
A 22'Procedure Names List'
A SCDOW 9A O 110
A 120DATE 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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBNDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBNDR "
mbrtype = "RPGLE "
mbrtext = "Procedure names list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 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_System
/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 = '*PRINT'
or p_Output = '*';
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 system API to get bind directory
// entries. (Please IBM!) Anyway,
// 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);
dcl-s CmdString varchar(160);
CmdString = 'DSPBNDDIR BNDDIR(' +
f_GetQual(p_ObjName + p_ObjLib) +
') OUTPUT(*OUTFILE) ' +
' OUTFILE(JCRBNDFB) OUTMBR(*FIRST *REPLACE)';
f_System(CmdString);
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_System('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 = '*PRINT' or p_Output = '*';
2b if QusrObjDS.Type = '*BNDDIR';
DetailVar = jcrBndDir + ' ' +
jcrSrvPgm + ' ' +
jcrSrvPgmL + ' ' +
jcrModule + ' ' +
jcrModuleL + ' ' +
jcrProc;
2x elseif QusrObjDS.Type = '*SRVPGM' or QusrObjDS.Type = '*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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRBNDV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRBNDV "
mbrtype = "RPGLE "
mbrtext = "Procedure names list - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCALL type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCALL "
mbrtype = "CMD "
mbrtext = "Command prompt entry parms jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRCALL - Command prompt entry parms - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCALLH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCALLH "
mbrtype = "PNLGRP "
mbrtext = "Command prompt entry parms jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRCALL'.Command Prompt Entry Parms (JCRCALL) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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 calledd 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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCALLO type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCALLO "
mbrtype = "RPGLE "
mbrtext = "Command prompt entry parms - prompt override jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCALLR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCALLR "
mbrtype = "RPGLE "
mbrtext = "Command prompt entry parms jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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_System
/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 = 'RPGLE'
or p_Pgmatr = 'SQLRPGLE';
exsr srRPG;
1x elseif p_Pgmatr = 'CLLE'
or p_Pgmatr = '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 = %xlate(lo: up: 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_System('DLTF FILE(QTEMP/CMDSRC)');
f_System('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_System('DLTCMD CMD(QTEMP/JCRCALLX)');
f_System('CRTCMD CMD(QTEMP/JCRCALLX) ' +
'PGM(' + f_GetQual(p_CPPname + p_Lib) +
') SRCFILE(QTEMP/CMDSRC) SRCMBR(JCRCALLX)');
1b if ApiErrDS.BytesReturned > 0;
f_SndEscapeMsg('CrtCmd Failed. Check source JCRCALLX +
in QTEMP/CMDSRC.');
1e endif;
f_System('?QTEMP/JCRCALLX');
f_SndCompMsg('JCRCALL parm processing for ' +
f_GetQual(p_CPPname + p_Lib) + ' - completed');
endsr;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCALLV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCALLV "
mbrtype = "RPGLE "
mbrtext = "Command prompt entry parms - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 = 'RPGLE' or
p_Pgmatr = 'SQLRPGLE' or
p_Pgmatr = 'CLP' or
p_Pgmatr = 'CLLE');
f_SndEscapeMsg('Program type ' + %trimr(p_Pgmatr) +
' is not type RPGLE, SQLRPGLE, CLP, or CLLE.');
1e endif;
*inlr = *on;
return;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCMDSBND type BND - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCMDSBND"
mbrtype = "BND "
mbrtext = "JCRCMDS binder language jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRCMDSBND - Binder source for JCRCMDSSRV service program */
/*--------------------------------------------------------------------------*/
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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_DecodeApiTimeStamp)
EXPORT SYMBOL(f_DisplayLastSplf)
EXPORT SYMBOL(f_DltOvr)
EXPORT SYMBOL(f_DupFileToQtemp)
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_OutFileAddPfm)
EXPORT SYMBOL(f_OutFileCrtDupObj)
EXPORT SYMBOL(f_OvrPrtf)
EXPORT SYMBOL(f_ParmListCount)
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_SndSflMsg)
EXPORT SYMBOL(f_SndStatMsg)
EXPORT SYMBOL(f_System)
EXPORT SYMBOL(f_ZipIFS)
ENDPGMEXP
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCMDSCPY type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCMDSCPY"
mbrtype = "RPGLE "
mbrtext = "JCRCMDS copy book repository jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/If defined(Title)
//---------------------------------------------------------
// This program is free software, you can redistribute it and/or modify it
// under the terms of the GNU General Public License as published by
// the Free Software Foundation. See GNU General Public License for detail.
// Craig Rutledge < www.jcrcmds.com >
//---------------------------------------------------------
// 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(*TERASPACE);
/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(Atoi)
//---------------------------------------------------------
// C String to Integer
dcl-pr atoi int(10) extproc(*dclcase);
*n pointer value options(*string);
end-pr;
/endif
/If defined(Ceegsi)
//---------------------------------------------------------
// Get String Information
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);
/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
dcl-c up const('ABCDEFGHIJKLMNOPQRSTUVWXYZ');
dcl-c lo const('abcdefghijklmnopqrstuvwxyz');
/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) overlay(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) pos(21);
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) pos(11);
ToField char(10) pos(17);
ToNumber int(5) pos(27);
end-ds;
// physical file attributes
dcl-ds PfAttrDS based(PfAttrPtr) qualified;
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(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(Qusdltus)
//---------------------------------------------------------
// Delete User Space
dcl-pr Qusdltus extpgm('QUSDLTUS');
*n char(20); // user space
*n like(ApiErrDS);
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;
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) overlay(SpecialAuth:1) dim(8);
InitialPgm char(10) pos(169);
InitialPgmLib char(10) pos(179);
JobdQual char(20) pos(290);
OutqQual char(20) pos(361);
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);
AliasName char(10) pos(223);
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(Qwdrjobd)
//---------------------------------------------------------
// 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;
/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(Sds)
//---------------------------------------------------------
dcl-ds *n PSDS;
progid char(10) pos(1);
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) pos(48);
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) pos(57);
ddsField4 char(4) pos(57);
ddsField5 char(5) pos(57);
ddsField6 char(6) pos(57);
ddsField7 char(7) pos(57);
ddsField9 char(9) pos(57);
ddsField10 char(10) pos(57);
end-ds;
/endif
/If defined(System)
//---------------------------------------------------------
// C Command Processor
dcl-pr system int(10) extproc(*dclcase);
*n pointer value options(*string);
end-pr;
/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(QtocLstNetIfc)
//---------------------------------------------------------
// 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;
/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_BuildString)
//---------------------------------------------------------
dcl-pr f_BuildString char(2048) opdesc;
*n char(2048) const options(*varsize);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*trim);
*n char(100) const options(*nopass:*varsize:*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_DupFileToQtemp)
//---------------------------------------------------------
dcl-pr f_DupFileToQtemp;
*n char(10) const; // file name
*n char(10) const; // library name
*n char(1) const options(*nopass); // override (Y N)
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) opdesc;
*n char(288) options(*varsize); // date/time format
*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_OutFileAddPfm)
//---------------------------------------------------------
dcl-pr f_OutFileAddPfm;
*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_ParmListCount)
//---------------------------------------------------------
dcl-pr f_ParmListCount uns(5);
*n char(2);
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;
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_System)
//---------------------------------------------------------
dcl-pr f_System opdesc; // cl command processor
*n char(2048) const options(*varsize);
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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_JCRSMLTRS)
//---------------------------------------------------------
dcl-pi *n;
p_ScanStrings char(272);
p_Case char(4);
p_IfContains char(7);
p_SrcFiles char(398);
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);
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
dcl-pi *n;
p_IfsDir char(50);
end-pi;
/endif
/If defined(p_JCRIFSMBRR)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
dcl-pi *n;
p_SrcMbrs char(92);
end-pi;
/endif
/If defined(p_JCRPRTFR)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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-pi *n;
p_Lib char(10);
p_FileList char(102);
p_UsrList char(120);
end-pi;
/endif
/If defined(p_JCRNETFMR)
//---------------------------------------------------------
dcl-pi *n;
p_FileQual char(20);
p_UsrList char(120);
p_MbrList char(242);
end-pi;
/endif
/If defined(p_JCRPATTRR)
//---------------------------------------------------------
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)
//---------------------------------------------------------
dcl-pi *n;
p_SrcMbr char(10);
p_SrcFilQual char(20);
end-pi;
/endif
/If defined(p_JCRSPLFR)
//---------------------------------------------------------
dcl-pi *n;
p_SplfName char(10);
p_UsrDta char(10);
p_OutqQual char(20);
p_Usrprf char(10);
p_Formtyp char(10);
end-pi;
/endif
/If defined(p_JCRUFINDR)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
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)
//---------------------------------------------------------
dcl-pi *n;
p_ScriptMbr char(10);
p_ScriptQual char(20);
p_OutFileQual char(20);
end-pi;
/endif
/If defined(p_XMLSRCFILR)
//---------------------------------------------------------
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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCMDSSRV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCMDSSRV"
mbrtype = "RPGLE "
mbrtext = "JCRCMDS service program source jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// JCRCMDSSRV - Service program for JCRCMDS
//---------------------------------------------------------
// Functions:
// 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_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 and send send spooled file message
// f_DupFileToQtemp - create duplicate file into Qtemp library with override
// 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 if DBU, WRKDBF, or STRDFU is data base utility
// 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_OutFileAddPfm - addpfm to select lib/file
// f_OutFileCrtDupObj - validity check / create OutFiles
// f_OvrPrtf - override prtf with outq and/or usrdta
// f_ParmListCount - number entries in cmd list
// f_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_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_RunFileUtil - execute DBU, WRKDBF, or STRDFU depending on what is installed
// 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_System - execute system (Qcmdexc replacement) with error monitoring
// 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
// f_IsInEllipsis
//---------------------------------------------------------
ctl-opt nomain datfmt(*iso) timfmt(*iso) expropts(*resdecpos)
option(*nounref: *nodebugio) bnddir('QSYS/QUSAPIBD')
STGMDL(*TERASPACE);
//--*COPY DEFINES------------------------------------------
/define Ceegsi
/define DspAtr
/define Qdbrtvfd
/define Qmhsndpm
/define Quslfld
/define Qusptrus
/define System
/define f_Qusrmbrd
/define f_Qusrobjd
/define f_Quscrtus
/define Constants
/define OpenCloseDir
/define CEEDAYS
/define Qbnlpgmi
/define Qclrpgmi
/COPY JCRCMDS,JCRCMDSCPY
//--*DATA STRUCTURES global--------------------------------
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;
// Import C/C++ global variable
dcl-s EXCP_MSGID char(7) import('_EXCP_MSGID');
// 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);
// Attr like(FieldsAttrDS);
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 char(2048) opdesc;
pString char(2048) const options(*varsize);
pParm01 char(100) const options(*nopass:*varsize:*trim);
pParm02 char(100) const options(*nopass:*varsize:*trim);
pParm03 char(100) const options(*nopass:*varsize:*trim);
pParm04 char(100) const options(*nopass:*varsize:*trim);
pParm05 char(100) const options(*nopass:*varsize:*trim);
pParm06 char(100) const options(*nopass:*varsize:*trim);
pParm07 char(100) const options(*nopass:*varsize:*trim);
pParm08 char(100) const options(*nopass:*varsize:*trim);
pParm09 char(100) const options(*nopass:*varsize:*trim);
pParm10 char(100) const options(*nopass:*varsize:*trim);
pParm11 char(100) const options(*nopass:*varsize:*trim);
pParm12 char(100) const options(*nopass:*varsize:*trim);
pParm13 char(100) const options(*nopass:*varsize:*trim);
pParm14 char(100) const options(*nopass:*varsize:*trim);
pParm15 char(100) const options(*nopass:*varsize:*trim);
pParm16 char(100) const options(*nopass:*varsize:*trim);
pParm17 char(100) const options(*nopass:*varsize:*trim);
pParm18 char(100) const options(*nopass:*varsize:*trim);
pParm19 char(100) const options(*nopass:*varsize:*trim);
pParm20 char(100) const options(*nopass:*varsize:*trim);
pParm21 char(100) const options(*nopass:*varsize:*trim);
pParm22 char(100) const options(*nopass:*varsize:*trim);
pParm23 char(100) const options(*nopass:*varsize:*trim);
pParm24 char(100) const options(*nopass:*varsize:*trim);
pParm25 char(100) const options(*nopass:*varsize:*trim);
pParm26 char(100) const options(*nopass:*varsize:*trim);
pParm27 char(100) const options(*nopass:*varsize:*trim);
pParm28 char(100) const options(*nopass:*varsize:*trim);
pParm29 char(100) const options(*nopass:*varsize:*trim);
pParm30 char(100) const options(*nopass:*varsize:*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);
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
// use ceegsi to get actual length of parms
//---------------------------------------------------------
cc = %scan('&': string);
1b for xx = 1 to ReplaceCount;
CEEGSI(xx + 1: DataType: ParmLen: MaxLen: *omit);
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 = ' ' or
nextchar = '(' or
nextchar = '/' or
nextchar = '-' or
nextchar = '&';
isfirst = *on;
2e endif;
2b if xx = 1 or isfirst;
3b if not (nextchar = ' ' or
nextchar = '(' or
nextchar = '/' or
nextchar = '-' or
nextchar = '&');
isfirst = *off;
nextchar = %xlate(lo:up:nextchar);
3e endif;
2x else;
nextchar = %xlate(up:lo: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);
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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// 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 = 'DCL-DS'
or Opcode = 'DCL-PI'
or Opcode = '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;
//---------------------------------------------------------
// 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 = *blanks or qcdrcmdiDS.VPGM = '*NONE');
string += ' ??VLDCKR(' +
f_GetQual(qcdrcmdiDS.VPGM + qcdrcmdiDS.VLIB) + ')';
1e endif;
1b if not(qcdrcmdiDS.PMFIL = *blanks or qcdrcmdiDS.PMFIL = '*NONE');
string += ' ??PMTFILE(' +
f_GetQual(qcdrcmdiDS.PMFIL + qcdrcmdiDS.PMLIB) + ')';
1e endif;
1b if not(qcdrcmdiDS.HLPNL = *blanks or qcdrcmdiDS.HLPNL = '*NONE');
string += ' ??HLPPNLGRP(' +
f_GetQual(qcdrcmdiDS.HLPNL + qcdrcmdiDS.HLIB) + ')';
1e endif;
1b if not(qcdrcmdiDS.OVPGM = *blanks or qcdrcmdiDS.OVPGM = '*NONE');
string += ' ??PMTOVRPGM(' +
f_GetQual(qcdrcmdiDS.OVPGM + qcdrcmdiDS.OVLIB) + ')';
1e endif;
string += ' ??TEXT(*SRCMBRTXT)';
return string;
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;
//---------------------------------------------------------
// 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_System('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;
system('DLTOVR FILE(' + p_SplfName + ') LVL(*JOB)');
return;
end-proc;
//---------------------------------------------------------
// Create duplicate file into Qtemp library with override
//---------------------------------------------------------
dcl-proc f_DupFileToQtemp export;
dcl-pi *n;
p_File char(10) const;
p_Lib char(10) const;
p_OvrDbf char(1) const options(*nopass);
end-pi;
dcl-s IsOvrDbf ind;
ApiErrDS.BytesReturned = 0;
1b if not f_IsValidMbr(p_File + p_Lib);
return;
1x elseif f_IsValidMbr(p_File + 'QTEMP');
system('CLRPFM QTEMP/' + p_File);
return;
1x else;
f_System(
f_BuildString('CRTDUPOBJ OBJ(&) FROMLIB(&) +
OBJTYPE(*FILE) TOLIB(QTEMP) DATA(*NO) CST(*NO) TRG(*NO)':
p_File: p_Lib));
2b if ApiErrDS.BytesReturned > 0;
f_SndEscapeMsg(ApiErrDS.ErrMsgId +
': Error occurred on CRTPF');
2e endif;
IsOvrDbf = *on;
2b if %parms = %parmnum(p_OvrDbf)
and p_OvrDbf = 'N';
IsOvrDbf = *off;
2e endif;
2b if IsOvrDbf;
system('OVRDBF FILE(' +
%trimr(p_File) + ') TOFILE(QTEMP/' +
%trimr(p_File) + ') OVRSCOPE(*JOB)');
2e endif;
1e endif;
return;
end-proc;
//------------------------------------------------------------------
// must check ... is not between ( ) like 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) opdesc;
p_String char(288) options(*varsize);
p_DateType char(1) const;
end-pi;
dcl-s string varchar(288);
1b if p_DateType = 'Z';
return qs + ' - - - . . . ' + qs;
1x elseif p_DateType = 'T';
CEEGSI(1: DataType: ParmLen: MaxLen: *omit);
string = %xlate(lo: up: %subst(p_String: 1: ParmLen));
2b if string = 'TIMFMT(*USA)'
or string = '*USA';
return qs + ' . XM' + qs;
2x elseif string = 'TIMFMT(*HMS)'
or string = 'TIMFMT(*JIS)'
or string = '*HMS'
or string = '*JIS';
return qs + ' : : ' + qs;
2x elseif string = 'TIMFMT(*ISO)'
or string = 'TIMFMT(*EUR)'
or string = '*ISO'
or string = '*EUR';
return qs + ' . . ' + qs;
2x else;
return qs + ' : : ' + qs;
2e endif;
1x elseif p_DateType = 'L'
or p_DateType = 'D';
CEEGSI(1: DataType: ParmLen: MaxLen: *omit);
string = %xlate(lo: up: %subst(p_String: 1: ParmLen));
2b if string = 'DATFMT(*MDY)'
or string = 'DATFMT(*YMD)'
or string = 'DATFMT(*DMY)'
or string = '*MDY'
or string = '*YMD'
or string = '*DMY';
return qs + ' / / ' + qs;
2x elseif string = 'DATFMT(*JUL)'
or string = '*JUL';
return qs + ' / ' + qs;
2x elseif string = 'DATFMT(*ISO)'
or string = 'DATFMT(*JIS)'
or string = '*ISO'
or string = '*JIS';
return qs + ' - - ' + qs;
2x elseif string = 'DATFMT(*USA)'
or string = '*USA'
or string = ' ';
return qs + ' / / ' + qs;
2x elseif string = 'DATFMT(*EUR)'
or string = '*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) = ' '
or %subst(p_DateTime: 8: 1) = 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) = ' '
or %subst(p_DateTime: 1: 1) = 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 color attribute for card
//---------------------------------------------------------
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 passed in
//---------------------------------------------------------
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' // rpg 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 + ';';
// 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 = '&'; // data structures return len() (see jcrhfdr)
keyword = 'len(';
1e endif;
1b if decimals = ' ' or decimals = ' 0' or decimals = '00';
KeyWord = %trimr(KeyWord) + %char(length) + ');';
1x else;
KeyWord = %trimr(KeyWord) + %char(length) +
': ' + %trim(decimals) + ');';
1e endif;
return keyword;
end-proc;
//---------------------------------------------------------
// return day name from date field. If no date is passed,
// function will return name of today date (right justified).
//---------------------------------------------------------
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;
//---------------------------------------------------------
// return screen field for type data base utility installed
// If neither DBU or WRKDBF is installed, default to STRDFU
//---------------------------------------------------------
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('WRKDBF': '*LIBL': '*CMD');
return 'WRKDBF';
1x else;
return 'STRDFU';
1e endif;
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':%xlate(lo: up: 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 InputDS.SpecType = 'P'
or 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 prname = 'b'
or prname = 'B'
or prname = 'e'
or prname ='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 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(
%trimr(%subst(p_String: 11: 10)) +
'/' + %subst(p_String: 1: 10));
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;
//---------------------------------------------------------
// 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-ds CsrRowColDS;
CsrRow zoned(3);
CsrCol zoned(3);
end-ds;
1b if not(p_File = PreviousFile and p_Lib = PreviousLib);
PreviousFile = p_File;
PreviousLib = p_Lib;
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 if compile array is found at source line
//---------------------------------------------------------
dcl-proc f_IsCompileTimeArray export;
dcl-pi *n ind;
SrcPos13 char(3);
end-pi;
1b if SrcPos13 = '** '
or SrcPos13 = '**C'
or SrcPos13 = '**c';
return *on;
1e endif;
return *off;
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) = '*' or %subst(string:1:1) = '/';
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 *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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// Add member to existing file
//---------------------------------------------------------
dcl-proc f_OutFileAddPfm 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_system(f_BuildString('ADDPFM FILE(&) MBR(&) +
SRCTYPE(&) TEXT(&q&&q)':
f_GetQual(p_NewFileQual):
p_NewMbr:
QusrmbrdDS.MbrType:
QusrmbrdDS.Text));
1x else;
f_System(f_BuildString(
'CHGPFM FILE(&) MBR(&) SRCTYPE(&) TEXT(&q&&q)':
f_GetQual(p_NewFileQual):
p_NewMbr:
QusrmbrdDS.MbrType:
QusrmbrdDS.Text));
f_system(f_BuildString('CLRPFM FILE(&) MBR(&)':
f_GetQual(p_NewFileQual):p_NewMbr));
1e endif;
return;
end-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_system(
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
f_system(
f_BuildString('RNMM FILE(&/&) MBR(&) NEWMBR(&)':
OutLib:
OutFile:
p_FromObj:
OutFile));
2e endif;
// if File exists but member does not,
// make sure member can be added to File.
1x elseif ApiErrDS.ErrMsgId = 'CPF9815';
exsr srAddPfm;
1x elseif ApiErrDS.ErrMsgId > *blanks;
f_SndEscapeMsg(ApiErrDS.ErrMsgId + ': ' +
%trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId: ApiErrDS.MsgReplaceVal)));
1e endif;
1b if OutMbrOpt = '*REPLACE';
f_system(
f_BuildString('CLRPFM FILE(&/&) MBR(&)':
OutLib:
OutFile:
RealMbr));
1e endif;
// compare record format ID for level check issues
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_system(f_BuildString('ADDPFM &/& &':
OutLib: OutFile: realMbr));
1b if (ApiErrDS.ErrMsgId = 'CPF7306');
f_SndEscapeMsg('Members for OutFile more than MAX allowed.');
1e endif;
endsr;
end-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;
//---------------------------------------------------------
// 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_System('OVRPRTF FILE(' + %trimr(p_SplfName) +
') OUTQ(' + %trimr(soutq) +
') USRDTA(' + p_UsrDta + ') OVRSCOPE(*JOB)');
return;
end-proc;
//---------------------------------------------------------
// return number of elements passed in parameter list
//---------------------------------------------------------
dcl-proc f_ParmListCount export;
dcl-pi *n uns(5);
p_ListParm char(2);
end-pi;
dcl-ds ExtractDS qualified;
Bin uns(5);
end-ds;
ApiErrDS.BytesReturned = 0;
ExtractDS = p_ListParm;
return ExtractDS.bin;
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;
//---------------------------------------------------------
// 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 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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
//---------------------------------------------------------
dcl-proc f_RemoveHexColorCodes export;
dcl-pi *n char(94) opdesc;
string char(94) options(*varsize);
end-pi;
dcl-c Hex21 const(x'21');
dcl-c Hex3F const(x'3F');
dcl-s xx uns(3);
CEEGSI(1: DataType: ParmLen: MaxLen: *omit);
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;
//---------------------------------------------------------
//---------------------------------------------------------
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;
//---------------------------------------------------------
//---------------------------------------------------------
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);
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);
1e endif;
1b if QuotePos2 > 0 and TestPos > QuotePos1 and TestPos < QuotePos2;
return 0;
1x else;
return TestPos;
1e endif;
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;
//---------------------------------------------------------
// 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 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;
//---------------------------------------------------------
// execute DBU, WRKDBF, or STRDFU depending on what is installed
//---------------------------------------------------------
dcl-proc f_RunFileUtil;
dcl-pi *n;
p_FileQual char(21);
p_Mbr char(10) const;
end-pi;
1b if f_GetFileUtil() = 'DBU';
f_System('DBU FILE(' + %trimr(p_FileQual) +
') MBR(' + %trimr(p_Mbr) + ')');
1x elseif f_GetFileUtil() = 'WRKDBF';
f_System('WRKDBF ' + p_FileQual);
1x else;
f_System('STRDFU OPTION(5) FILE(' +
p_FileQual + ') MBR(' + %trimr(p_Mbr) + ')');
1e endif;
return;
end-proc;
//---------------------------------------------------------
// Execute system command depending on option
//---------------------------------------------------------
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);
p_FileQual = f_GetQual(p_File + p_Lib);
1b if p_Option = 1;
f_System(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;
f_RunFileUtil(p_FileQual: p_Mbr);
msg = %trimr(f_GetFileUtil()) +
' for ' + %trimr(p_FileQual) + ' - completed';
2e endif;
1x elseif p_Option = 3;
f_System('JCRFD ' + p_FileQual);
msg = 'File Description for ' +
%trimr(p_FileQual) + ' - completed';
1x elseif p_Option = 4;
f_System(f_BuildString('RMVM FILE(&) MBR(&)':
p_FileQual: p_Mbr));
msg = 'Member ' + %trimr(p_mbr) + ' has been removed';
1x elseif p_Option = 5;
f_System(f_BuildString('WRKMBRPDM FILE(&) MBR(&)':
p_FileQual: p_Mbr));
msg = 'Work with member ' + %trimr(p_mbr) + ' - completed';
1x elseif p_Option = 7;
f_System('WRKOBJ *ALL/' + p_File + 'OBJTYPE(*FILE)');
msg = 'Wrkobj *all/' + %trimr(p_file) + ' - completed';
1x elseif p_Option = 9;
f_System(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;
f_SndSflMsg(p_ProgId: msg);
return;
end-proc;
//---------------------------------------------------------
// Execute system command depending on option
//---------------------------------------------------------
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_System('?CHGJOB ' + JobString);
msg = 'Chgjob for ' + %trimr(p_JobName) + ' - completed';
1x elseif p_Option = 3;
f_System('STRSRVJOB ' + JobString);
msg = 'Strsrvjob for ' + %trimr(p_JobName) + ' - completed';
1x elseif p_Option = 4;
f_System('ENDJOB ' + JobString + ' OPTION(*IMMED)');
msg = 'Endjob for ' + %trimr(p_JobName) + ' - completed';
1x elseif p_Option = 5;
f_System('DSPJOB ' + JobString);
msg = 'Dspjob for ' + %trimr(p_JobName) + ' - completed';
1x elseif p_Option = 8;
f_System('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_system('?STRDBG');
msg = 'STRDBG for ' + %trimr(p_JobName) + ' - started';
1x elseif p_Option = 15;
f_system('ENDSRVJOB');
msg = 'ENDSRVJOB for ' + %trimr(p_JobName) + ' - completed';
1x elseif p_Option = 20;
f_system('ENDDBG');
msg = 'ENDDBG ' + %trimr(p_JobName) + ' - completed';
1x else;
msg = 'Option ' + %char(p_Option) + ' is not available.';
1e endif;
f_SndSflMsg(p_ProgId: msg);
return;
end-proc;
//---------------------------------------------------------
// Execute system command depending on option
//---------------------------------------------------------
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_System('?SNDNETSPLF ' + SpoolString + ' ??TOUSRID(( ))');
2b if ApiErrDS.BytesReturned = 0;
msg = 'Sndnetsplf ' + %trimr(p_SplfName) + ' - completed';
2x else;
3b if ApiErrDS.ErrMsgId = 'CPF6801'; // no replace value returned
ApiErrDS.MsgReplaceVal = 'F3 ';
3e endif;
msg = %trimr(f_RtvMsgApi(ApiErrDS.ErrMsgId:
ApiErrDS.MsgReplaceVal));
2e endif;
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_System('?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_System('?ESEND/ESNDMAIL ' + SpoolString);
2b if ApiErrDS.BytesReturned = 0;
msg = 'Esend ' + %trimr(p_SplfName) + ' - completed';
2x else;
msg = 'Esend ' + %trimr(p_SplfName) + ' - Canceled';
2e endif;
1x elseif p_Option = '2';
f_System('?CHGSPLFA ' + SpoolString);
2b if ApiErrDS.BytesReturned = 0;
msg = 'Change ' + %trimr(p_SplfName) + ' - completed';
2x else;
msg = 'Change ' + %trimr(p_SplfName) + ' - Canceled';
2e endif;
1x elseif p_Option = '3';
f_System('HLDSPLF ' + SpoolString);
msg = 'Hold Spooled File '
+ %trimr(p_SplfName) + ' - completed';
1x elseif p_Option = '4';
f_System('DLTSPLF ' + SpoolString);
msg = 'Delete Spooled File '
+ %trimr(p_SplfName) + ' - completed';
1x elseif p_Option = '5';
f_System('DSPSPLF ' + SpoolString);
msg = 'Display Spooled File '
+ %trimr(p_SplfName) + ' - completed';
1x elseif p_Option = '6';
f_System('RLSSPLF ' + SpoolString);
msg = 'Release Spooled File '
+ %trimr(p_SplfName) + ' - completed';
1x elseif p_Option = '8';
f_System('WRKSPLFA ' + SpoolString);
msg = 'Work Spooled File Attributes '
+ %trimr(p_SplfName) + ' - completed';
1x elseif p_Option = '9';
f_System('?CPYSPLF ' + SpoolString + ' ??TOFILE( )');
2b if ApiErrDS.BytesReturned = 0;
msg = 'Copy ' + %trimr(p_SplfName) + ' - completed';
2x else;
msg = 'Copy ' + %trimr(p_SplfName) + ' - Canceled';
2e endif;
1x elseif p_Option = 'H';
f_System('?SPLF2HTML ' + SpoolString +
' ??TODOC(' + qs + '/kpiReports/' + qs +
') STMFOPT(*REPLACE) FONTSIZE(2)');
2b if ApiErrDS.BytesReturned = 0;
msg = 'SPLF2HTML ' + %trimr(p_SplfName) + ' - completed';
2x else;
msg = 'SPLF2HTML ' + %trimr(p_SplfName) + ' - Canceled';
2e endif;
1x else;
msg = 'Invalid Option Selected.';
1e endif;
f_SndSflMsg(p_ProgId: msg);
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 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;
//---------------------------------------------------------
// 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);
return;
end-proc;
//---------------------------------------------------------
// Send message to error message subfile
//---------------------------------------------------------
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-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;
//---------------------------------------------------------
// 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;
//---------------------------------------------------------
// Execute C function system using global exception variable
//---------------------------------------------------------
dcl-proc f_System export;
dcl-pi *n opdesc;
p_String char(2048) const options(*varsize);
end-pi;
CEEGSI(1: DataType: ParmLen: MaxLen: *omit);
EXCP_MSGID = *blanks;
1b if system(%subst(p_String: 1: ParmLen)) = 1
and EXCP_MSGID > *blanks;
ApiErrDS.ErrMsgId = EXCP_MSGID;
2b if ApiErrDS.ErrMsgId = 'CPFA097'; // object not copied
2x elseif ApiErrDS.ErrMsgId = 'CPF6801'; //f3 or f12 pressed
ApiErrDS.MsgReplaceVal = 'F3';
2x else;
ApiErrDS.MsgReplaceVal = *blanks;
2e endif;
ApiErrDS.BytesReturned = 7;
1x else;
ApiErrDS.BytesReturned = 0;
1e endif;
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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCOMPOST type CLLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCOMPOST"
mbrtype = "CLLE "
mbrtext = "JCRCMDS recompile library jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRCOMPOST - recompile JCRCMDS utilities */
/* CALL JCRCOMPOST PARM(library where source is located) */
/* Run this program after all members are extracted to */
/* source file mylib/JCRCMDS to compile all objects. */
/*--------------------------------------------------------------------------*/
/* For cl program JCRSSQLC to compile, you must be authorized to */
/* use the DMPSYSOBJ command. If you are not authorized to that command, */
/* answer the run-time message with 'I'. */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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 */
OVRDBF FILE(JCRSUBRLF) TOFILE(JCRSUBRPF) +
OVRSCOPE(*JOB)
/*-------------------------------------------------------------------*/
/* delete / recreate all ILE components of library */
/*-------------------------------------------------------------------*/
DLTMOD MODULE(&L/JCRCMDSSRV)
MONMSG MSGID(CPF0000)
DLTSRVPGM SRVPGM(&L/JCRCMDSSRV)
MONMSG MSGID(CPF0000)
DLTBNDDIR BNDDIR(&L/JCRCMDSDIR)
MONMSG MSGID(CPF0000)
CRTRPGMOD MODULE(&L/JCRCMDSSRV) SRCFILE(&L/&F) +
DBGVIEW(*ALL) 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(*ALL)
ENDDO
ENDDO
WHEN COND(&MBRTYPE = 'RPGLE') THEN(CRTBNDRPG +
PGM(&L/&N) SRCFILE(&L/&F) SRCMBR(&N) +
DBGVIEW(*ALL))
/*------------------------------------------------------------------------*/
/* 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/JCRVALMBRV) +
HLPPNLGRP(*LIBL/JCRFDH) HLPID(*CMD)
CRTCMD CMD(&L/JCRDBR) PGM(*LIBL/JCRFDR) +
SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) +
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/JCRJOBDL) PGM(*LIBL/JCRJOBDLR) +
SRCFILE(&L/&F) +
HLPPNLGRP(*LIBL/JCRJOBDLH) HLPID(*CMD)
CRTCMD CMD(&L/JCRJOBDQ) PGM(*LIBL/JCRJOBDQR) +
SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) +
MODE(*ALL) ALLOW(*ALL) ALWLMTUSR(*NO) +
HLPPNLGRP(*LIBL/JCRJOBDQH) 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/JCRVALMBRV) +
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/JCRVALMBRV) +
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/JCRSUBR) PGM(*LIBL/JCRSUBRR1) +
SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALMBRV) +
HLPPNLGRP(*LIBL/JCRSUBRH) 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/JCRUSRAUT) PGM(*LIBL/JCRUSRAUTR) +
SRCFILE(&L/&F) +
HLPPNLGRP(*LIBL/JCRUSRAUTH) HLPID(*CMD)
CRTCMD CMD(&L/JCRUSROUTQ) PGM(*LIBL/JCRUSROUTR) +
SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) +
HLPPNLGRP(*LIBL/JCRUSROUTH) HLPID(*CMD)
CRTCMD CMD(&L/JCRUSRJOBD) PGM(*LIBL/JCRUSRJOBR) +
SRCFILE(&L/&F) VLDCKR(*LIBL/JCRVALOBJV) +
MODE(*ALL) ALLOW(*ALL) +
HLPPNLGRP(*LIBL/JCRUSRJOBH) 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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRCOMPSRV type CLLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRCOMPSRV"
mbrtype = "CLLE "
mbrtext = "JCRCMDS recompile service program only jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRCOMPSRV - recompile the JCRCMDS service program */
/* CALL JCRCOMSRV PARM(mylib) */
/* you must log off and back on to run new service program */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDBR type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDBR "
mbrtype = "CMD "
mbrtext = "Data base relations done quicker jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDBR - Data base relations done quicker - CMD */
/* Front-ends the JCRFDR program going straight to DBR */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
CMD PROMPT('Expanded Data Base Relations')
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(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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDBRH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDBRH "
mbrtype = "PNLGRP "
mbrtext = "Data base relations done quicker jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDBR'.Expanded Data Base Relations (JCRDBR) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDDL type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDDL "
mbrtype = "CMD "
mbrtext = "Generate data definition language member jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDDL - Generate data definition language member - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDDLH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDDLH "
mbrtype = "PNLGRP "
mbrtext = "Generate data definition language member jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDDL'.Generate data definition member (JCRDDL) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDDLR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDDLR "
mbrtype = "RPGLE "
mbrtext = "Generate data definition language member jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDDLV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDDLV "
mbrtype = "RPGLE "
mbrtext = "Generate data definition language member jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// JCRDDLV - Validity checking program for lib/file/member
//---------------------------------------------------------
/define ControlStatements
/define ApiErrDS
/define f_Qusrobjd
/define f_RtvMsgAPI
/define f_SndEscapeMsg
/define f_OutFileAddPfm
/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_OutFileAddPfm(p_OutFileQual: p_OutMbr: 'DDL': QusrObjDS.Text);
*inlr = *on;
return;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQD type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQD "
mbrtype = "CMD "
mbrtext = "Data queue description display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDQD - Data queue description display - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQDD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQDD "
mbrtype = "DSPF "
mbrtext = "Data queue description display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDQDD - Data queue description display - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQDH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQDH "
mbrtype = "PNLGRP "
mbrtext = "Data queue description display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDQD'.Data Queue Description Display (JCRDQD) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQDR "
mbrtype = "RPGLE "
mbrtext = "Data queue description display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 dou 1 = 2;
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 = f03 or InfdsFkey = 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQE type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQE "
mbrtype = "CMD "
mbrtext = "Data queue entries display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDQE - Data queue entries display - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQED type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQED "
mbrtype = "DSPF "
mbrtext = "Data queue entries display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDQED - Data Queue Entries Display - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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*----------------------------------------------------------------
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*----------------------------------------------------------------
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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQEH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQEH "
mbrtype = "PNLGRP "
mbrtext = "Data queue entries display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDQE'.Data Queue Entries Display (JCRDQE) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDQER type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDQER "
mbrtype = "RPGLE "
mbrtext = "Data queue entries display jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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(*TERASPACE);
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 dou 1 = 2;
xx = ofs + 1;
2b dow xx > 100;
xx -= 100;
2e enddo;
2b if IsHexMode;
scRuler = %subst(cRuler2: (xx*2) - 1);
2x else;
scRuler = %subst(cRuler1: xx);
2e endif;
2b if ofs = 0;
%subst(scRuler: 1: 1) = '*';
2e endif;
ind.sfldsp = (rrn > 0);
ind.sfldspctl = *on;
ind.IsactivateF14 = (QmhqrdqdDS.Sequence = 'K');
write sheader;
exfmt sbfctl1;
ind.sfldrop = vSflMode;
// exit / cancel
2b if InfdsFkey = f03 or InfdsFkey = 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDTAARA type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDTAARA "
mbrtype = "CMD "
mbrtext = "Dtaara values and rollover distance list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDTAARA - Dtaara values and rollover distance list - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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) SPCVAL((*ALL *ALL) +
(*ALLUSR *ALLUSR)) PROMPT('Library')
PARM KWD(OUTPUT) TYPE(*CHAR) LEN(8) RSTD(*YES) +
DFT(*PRINT) VALUES(* *PRINT) PROMPT('Output')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDTAARAH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDTAARAH"
mbrtype = "PNLGRP "
mbrtext = "Dtaara values and rollover distance list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDTAARA'.List Dtaara *DEC Values (JCRDTAARA)
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDTAARAP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDTAARAP"
mbrtype = "PRTF "
mbrtext = "Dtaara values and rollover distance list 198 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDTAARAP - Dtaara values and rollover distance list - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- 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 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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDTAARAR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDTAARAR"
mbrtype = "RPGLE "
mbrtext = "Dtaara values and rollover distance list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// JCRDTAARAR - Dtaara values and rollover distance list - print
//---------------------------------------------------------
/define ControlStatements
/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;
write PrtHead;
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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUMP type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUMP "
mbrtype = "CMD "
mbrtext = "Dump count by program jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDUMP - Dump count by program - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUMPD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUMPD "
mbrtype = "DSPF "
mbrtext = "Dump count by program jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDUMPD - Dump count by program - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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 7 3
A SPGMNAM 10A O 7 6
A SPGMLIB 10A O 7 17
A SUSERNAM 10A O 7 28
A SJOBNAM 10A O 7 39
A SJOBNBR 6A O 7 51
A SSDATE L O 7 59DATFMT(*ISO)
A SSTIME T O 7 70TIMFMT(*HMS)
*----------------------------------------------------------------
A R SBFCTL1 SFLCTL(SBFDTA1) OVERLAY
A *DS3 SFLPAG(15) SFLSIZ(30)
A *DS4 SFLPAG(15) SFLSIZ(30)
A 31 SFLDSP
A 32 SFLDSPCTL
A N32 SFLCLR
A N34 SFLEND(*MORE)
A 1 3'JCRDUMPR3' COLOR(BLU)
A 1 23'Dump Spooled File Viewer'
A DSPATR(HI)
A SCDOW 9A O 1 62COLOR(BLU)
A 1 72DATE EDTCDE(Y) COLOR(BLU)
A 2 72SYSNAME COLOR(BLU)
A 3 2'Type options, press Enter.'
A COLOR(BLU)
A 4 4'1=SndNet' COLOR(BLU)
A 4 15'2=Change Outq' COLOR(BLU)
A 4 31'5=Display' COLOR(BLU)
A 6 2'Opt' DSPATR(HI UL)
A 6 6'Program ' DSPATR(HI UL)
A 6 17'Lib ' DSPATR(HI UL)
A 6 28'User ' DSPATR(HI UL)
A 6 39'Job ' DSPATR(HI UL)
A 6 51'Number' DSPATR(HI UL)
A 6 59'Date ' DSPATR(HI UL)
A 6 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUMPH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUMPH "
mbrtype = "PNLGRP "
mbrtext = "Dump count by program jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDUMP'.Dump Count by Program (JCRDUMP) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUMPP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUMPP "
mbrtype = "PRTF "
mbrtext = "Dump count by program jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDUMPP - Dump count by program - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 132)
A R PRTHEAD
A 2'JCRDUMP'
A SKIPB(01)
A 30'Dump count by program'
A SCDOW 9 77
A 88DATE EDTCDE(Y)
A 108'Page'
A PAGE1 4 0 114EDTCDE(4)
A SPACEA(2)
A 5'Dump Date'
A 23'Program Name Library'
A 49'Number of Dumps'
A 69'Program Status Message'
A SPACEA(1)
*----------------------------------------------------------------
A R PRTL1
A 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUMPR type SQLRPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUMPR "
mbrtype = "SQLRPGLE "
mbrtext = "Dump count by program jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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(*TERASPACE);
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 Sds
/define f_RunOptionSplf
/define f_RmvSflMsg
/define f_SndSflMsg
/define f_GetDayName
/define f_DupFileToQtemp
/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) pos(1) 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);
KeyReturned 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;
// f_DupFileToQtemp('JCRDUMPF': '*LIBL': 'N');
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.KeyReturned = 0201;
pSplfNam = splf0200DS.KeyData;
4x elseif splf0200DS.KeyReturned = 0202;
PJobNam = splf0200DS.KeyData;
4x elseif splf0200DS.KeyReturned = 0203;
pUserNam = splf0200DS.KeyData;
4x elseif splf0200DS.KeyReturned = 0204;
PJobNbr = splf0200DS.KeyData;
4x elseif splf0200DS.KeyReturned = 0205;
cvt.Alpha4 = splf0200DS.KeyData;
evalr pSplfNbr = '000000' + %char(cvt.Binary4);
4x elseif splf0200DS.KeyReturned = 0216;
pSdate = %date(%subst(splf0200DS.KeyData: 2: 6): *ymd0);
4x elseif splf0200DS.KeyReturned = 0217;
pStime = %time(%subst(splf0200DS.KeyData: 1: 6): *hms0);
4x elseif splf0200DS.KeyReturned = 0218;
IntJobID = splf0200DS.KeyData;
4x elseif splf0200DS.KeyReturned = 0219;
InternalSplfID = splf0200DS.KeyData;
4e endif;
splf0200Ptr += splf0200DS.LenghtOfInfo;
3e endfor;
// use internal identifiers to open spooled file
3b if SelectAll = '*YES'
or ip_isoDate = 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;
write PrtL1;
LRCnt += L1Cnt;
2b if IsOverFlow;
write PrtHead;
IsOverFlow = *off;
2e endif;
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';
f_SndSflMsg(ProgId:
'No dump spooled files found for dates');
2x else;
f_SndSflMsg(ProgId:
'No dump spooled files found for program ' + %trimr(pPgm) +
' in ' + %trimr(pLib));
2e endif;
1e endif;
Ind.sfldspctl = *on;
1b dou 1 = 2;
write msgctl;
write sfooter1;
exfmt sbfctl1;
2b if InfdsFkey = f03 or InfdsFkey = 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;
f_SndSflMsg(ProgId: '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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUPKEY type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUPKEY "
mbrtype = "CMD "
mbrtext = "Duplicate keyed logicals list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRDUPKEY - Duplicate keyed logicals list - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUPKEYH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUPKEYH"
mbrtype = "PNLGRP "
mbrtext = "Duplicate keyed logicals list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRDUPKEY'.Duplicate Keyed Logicals List (JCRDUPKEY) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUPKEYP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUPKEYP"
mbrtype = "PRTF "
mbrtext = "Duplicate keyed logicals list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRDUPKEYP - Duplicate Keyed Logicals List - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 132)
A R PRTHEAD SKIPB(1) SPACEA(1)
A 2'JCRDUPKEY'
A 20'Duplicate Keyed Logicals List'
A SCDOW 9A O 82
A 92DATE EDTCDE(Y)
A 104'Page'
A +1PAGNBR EDTCDE(4) SPACEA(1)
*---
A 2'File:'
A SCOBJHEAD 75A 8SPACEA(2)
*---
A 1'File'
A 13'Library'
A 25'Keys'
*----------------------------------------------------------------
A R PRTLINE SPACEA(1)
A PRTFILE 10A O 1
A PRTLIB 10A O 13
A PRTKEYS 104A 25
*----------------------------------------------------------------
A R PRTDIVIDER SPACEA(1)
A 1'---------'
A 13'----------'
A 25'-----------------------------------
A ------------------------------------
A -----------------------------------'
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRDUPKEYR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRDUPKEYR"
mbrtype = "RPGLE "
mbrtext = "Duplicate keyed logicals list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// JCRDUPKEYR - Duplicate Keyed Logicals List - print
// List files with same leading keys and select/omit statements
//---------------------------------------------------------
/define ControlStatements
/define ApiErrDS
/define Constants
/define BitMask
/define f_OvrPrtf
/define f_DltOvr
/define f_Quscrtus
/define Qdbrtvfd
/define Qdbldbr
/define f_DisplayLastSplf
/define f_System
/define f_SndCompMsg
/define f_GetDayName
/define f_BuildString
/define Qlgsort
/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 IsSendMessage ind;
dcl-s IsAllEQual ind;
dcl-s IsAllSelect ind;
dcl-s IsPrintOnce ind;
// setup sort pointer
dcl-s SortOverlay char(200) based(sortptr);
dcl-s SortPtr pointer inz(%addr(ds1));
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(30);
PrtKeys char(104) pos(24);
SelOmtArry char(50) dim(30);
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;
//---------------------------------------------------------
// If file is logical, based-on-physical name is extracted
// processing continues.
//---------------------------------------------------------
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;
//---------------------------------------------------------
// Idea is start with smallest number of keys and spin through entire list
// looking for files with keys in same positions and same select omits
//
// Sort driver arry ascending by number of keys,
// and the compare arry descending by number of keys.
//---------------------------------------------------------
ds2(*) = ds1(*);
qlgsortDS.RecordLength = %len(ds1(1));
qlgsortDS.RecordCount = DbrCnt;
qlgsortDS.NumOfKeys = 1;
qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1:1:9:1); // ascend
qlgsortDS.BlockLength = %len(%trimr(qlgsortDS));
callp QLGSORT(
qlgsortDS:
SortOverlay:
SortOverlay:
qlgsortDS.RecordLength * qlgsortDS.RecordCount:
qlgsortDS.RecordLength * qlgsortDS.RecordCount:
ApiErrDS);
SortPtr = %addr(DS2);
qlgSortDS = %subst(qlgSortDS: 1: 80);
qlgsortDS = %trimr(qlgsortDS) + f_AddSortKey(1:1:9:2); // descend
callp QLGSORT(
qlgsortDS:
SortOverlay:
SortOverlay:
qlgsortDS.RecordLength * qlgsortDS.RecordCount:
qlgsortDS.RecordLength * qlgsortDS.RecordCount:
ApiErrDS);
//---------------------------------------------------------
//---------------------------------------------------------
1b for aa = 1 to DbrCnt;
2b if ds1(aa).File > *blanks;
IsPrintOnce = *on;
3b for cc = 1 to DbrCnt;
4b if ds2(cc).File > *blanks
and ds2(cc).File <> ds1(aa).File
and ds2(cc).FormatCnt = ds1(aa).FormatCnt;
IsAllSelect = *on;
5b for bb = 1 to %elem(ds1.SelOmtArry);
6b if ds2(cc).SelOmtArry(bb) <> ds1(aa).SelOmtArry(bb);
IsAllSelect = *off;
5v leave;
6e endif;
5e endfor;
5b if IsAllSelect;
IsAllEQual = (ds1(aa).NumbKeys > 0);
6b for bb = 1 to ds1(aa).NumbKeys;
7b if ds2(cc).KeysArry(bb) <> ds1(aa).KeysArry(bb);
IsAllEQual = *off;
6v leave;
7e endif;
6e endfor;
6b if IsAllEQual = *on;
IsSendMessage = *on;
7b if IsPrintOnce;
PrtFile = ds1(aa).File;
PrtLib = ds1(aa).Lib;
PrtKeys = ds1(aa).PrtKeys;
write PrtLine;
IsPrintOnce = *off;
7e endif;
PrtFile = ds2(cc).File;
PrtLib = ds2(cc).Lib;
PrtKeys = ds2(cc).PrtKeys;
write PrtLine;
// remove found file from driver array
7b for bb = 1 to DbrCnt;
8b if ds2(cc).File = ds1(bb).File;
ds1(bb) = *blanks;
8e endif;
7e endfor;
ds2(cc) = *blanks;
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;
cc = FileScopeArry.OffsKeySpecs + 1;
// if 1st bit of KeySequenBits = 1, key is descend sequence
ds1(DbrCnt).KeysArry(*) = *blanks;
ds1(DbrCnt).SelOmtArry(*) = *blanks;
ds1(DbrCnt).NumbKeys = FileScopeArry.NumOfKeys;
KeySpecsPtr = Fild0100ptr + FileScopeArry.OffsKeySpecs;
2b for yy = 1 to FileScopeArry.NumOfKeys;
ds1(DbrCnt).KeysArry(yy) = %trimr(KeySpecsDS.KeyFieldName);
// check for descending keys
3b if %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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFD type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFD "
mbrtype = "CMD "
mbrtext = "File descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRFD - File descriptions driver - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
CMD PROMPT('File Descriptions')
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(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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDD "
mbrtype = "DSPF "
mbrtext = "File descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFDD - File description driver - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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 62COLOR(BLU)
A 1 72DATE EDTCDE(Y) COLOR(BLU)
A 2 2'File:' DSPATR(HI)
A SCOBJHEAD 63A O 2 8
A 2 72SYSNAME 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDH "
mbrtype = "PNLGRP "
mbrtext = "File descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRFD'.File Descriptions (JCRFD) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.File whose description is to be retrieved.:EHELP.
:HELP NAME='JCRFD/VIEW'.View - Help :XH3.View (VIEW)
:P.Initial information presented by command.
:PARML.:PT.*:PD.Initial presentation is basic file information.
:PT.:PK def.*MBR:EPK.:PD.Display subfile of all members in the file.
:PT.:PK def.*DBR:EPK.:PD.Display subfile of data base relations.:EPARML.:EHELP.:EPNLGRP.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDMBRD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDMBRD "
mbrtype = "DSPF "
mbrtext = "File descriptions - member list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFDMBRD - File descriptions member list - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDMBRR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDMBRR "
mbrtype = "RPGLE "
mbrtext = "File descriptions - member list jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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(*TERASPACE);
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 Sds
/define f_RunOptionFile
/define f_GetQual
/define f_Quscrtus
/define f_RmvSflMsg
/define f_SndSflMsg
/define f_SndStatMsg
/define f_GetFileUtil
/define f_GetDayName
/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-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 dou 1 = 2;
Ind.sfldsp = (rrn > 0);
Ind.sfldspctl = *on;
2b if (not Ind.sfldsp);
f_RmvSflMsg(ProgId);
f_SndSflMsg(ProgId: 'No members were found');
2e endif;
write msgctl;
write sfooter1;
exfmt sbfctl1;
2b if InfdsFkey = f03 or InfdsFkey = f12;
*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 = f13
or InfdsFkey = f14;
3b if InfdsFkey = f13;
SortSequence = 'Ascend';
3e endif;
3b if InfdsFkey = f14;
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 = 1
or sbfOption = 2
or sbfOption = 4
or sbfOption = 5
or sbfOption = 9;
f_RunOptionFile(
sbfOption:
HeaderObj:
HeaderLib:
'*FIRST':
scmbr:
ProgId);
// Update subfile to reflect changes
5b if sbfOption = 4;
DeleteCount += 1;
5x else;
sbfOption = 0;
SflRcdNbr = rrn;
update sbfdta1;
5e endif;
4e endif;
readc sbfdta1;
3e enddo;
3b if DeleteCount > 0;
exsr srSortAndReload;
DeleteCount = 0;
3e endif;
2e endif;
1e enddo;
//---------------------------------------------------------
// 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 = '*ALL'
or QuslmbrDS.MbrType = p_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;
f_SndSflMsg(ProgId: '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;
f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) +
' by Member Type');
//----------------------------
2x elseif KeyFld = 'SCCHGTIME' or KeyFld = 'SCCHGDATE';
3b if SortSequence = 'Descend';
sorta(d) %subarr(Sortds(*).ChgDate: 1: MbrCnt);
3x else;
sorta(a) %subarr(Sortds(*).ChgDate: 1: MbrCnt);
3e endif;
f_SndSflMsg(ProgId: '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;
f_SndSflMsg(ProgId: '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;
f_SndSflMsg(ProgId: '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;
f_SndSflMsg(ProgId: '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;
f_SndSflMsg(ProgId: 'Sort ' + %trimr(SortSequence) +
' by Text');
2e endif;
2b if MbrCnt >= 9999;
f_RmvSflMsg(ProgId);
f_SndSflMsg(ProgId: '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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDP "
mbrtype = "PRTF "
mbrtext = "File descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFDP - File descriptions driver - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 132)
A R PRTHEAD SKIPB(1) SPACEA(2)
A SCTITLE 36A O 23
A SCDOW 9A O 62
A 72DATE EDTCDE(Y)
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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFDR "
mbrtype = "RPGLE "
mbrtext = "File descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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.
//---------------------------------------------------------
ctl-opt dftactgrp(*no) actgrp(*STGMDL) datfmt(*iso) timfmt(*iso)
option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR')
STGMDL(*TERASPACE) ALLOC(*TERASPACE);
dcl-f JCRFDD workstn sfile(sbfdta1: rrn) infds(infds)
sfile(windta3: rrn3) indds(ind);
dcl-f JCRFDP printer oflind(IsOverFlow) usropn;
/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_SndSflMsg
/define f_SndCompMsg
/define f_BuildString
/define Ind
/define Sds
/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(14);
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;
//--*ENTRY-------------------------------------------------
dcl-pi *n;
p_Mbr char(10);
p_FileQual char(20);
p_ObjTyp char(10);
p_CallingCmd char(10);
p_InitialView char(4);
p_LeadingKeys char(101);
p_MbrType char(10);
end-pi;
//---------------------------------------------------------
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 dou 1 = 2;
Ind.sfldsp = (rrn > 0);
Ind.sfldspctl = *on;
PrtRrn = Rrn;
2b if p_CallingCmd = 'JCRLKEY';
3b if rrn = 1;
LeadingKeysDS.IsFoundKey = *off;
IsExitPgm = *on;
LV leavesr;
3x else;
LeadingKeysDS.IsFoundkey = *on;
3e endif;
2e endif;
2b if rrn = 1;
SflRcdNbr = 1;
2e endif;
//-----------------------------------------------
write 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');
//f_SndSflMsg(ProgId: 'Member List for ' +
//%trimr(f_GetQual(p_FileQual)) + ' - completed');
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 = f13
or InfdsFKey = f15;
3b if InfdsFKey = f13;
FileOption = 1; // Field descriptions
3x elseif InfdsFKey = f15;
FileOption = 2; // Data base utility
3e endif;
f_RunOptionFile(FileOption:
sFileName: sLibname: '*FIRST': '*FIRST': ProgId);
//---------------------------------------------------------
2x elseif InfdsFkey = f14;
callp p_JCRFDMBRR(p_FileQual: '*ALL');
f_SndSflMsg(ProgId: '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 = 1 or sbfSelect = 2 or sbfSelect = 7);
f_RunOptionFile(
sbfSelect:
sbfFileHid:
sbfLibHid:
'*FIRST':
'*FIRST':
ProgId);
4e endif;
IsOption3 = *off;
SflRcdNbr = rrn; //STAY ON SCREEN
sbfSelect = 0;
sbfSelAtr = UL;
update sbfdta1;
sbfSelAtr = %bitor(ND: PR);
3e endif;
readc sbfdta1;
2e enddo;
1e enddo;
endsr;
//---------------------------------------------------------
// load bottom of screen with 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';
3x 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:68) = 'Members';
3e endif;
%subst(sbfRow:45:7) = 'Records';
%subst(sbfRow:59:7) = 'Deleted';
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 > 1;
4b if Fild0100ds.NumMbrs <= 9999999;
evalr %subst(sbfrow:66:7) = ' ' +
%char(Fild0100ds.NumMbrs);
4e endif;
3e endif;
2e endif;
rrn += 1;
write sbfDta1;
//--ROW 6--------------------------------------------------
exsr srLineRow;
exsr srRow7andRow8;
//--ROW 10-------------------------------------------------
// Spin through 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 = 'Program';
%subst(sbfrow:12) = 'Library';
%subst(sbfrow:24) = 'Event';
%subst(sbfrow:34) = 'Time';
rrn += 1;
write sbfDta1;
sbfRowAtr = Green;
3b for ForCount7 = 1 to PfAttrDS.NumOfTriggers;
sbfrow = TriggerDS.TPrgNam;
%subst(sbfrow:12) = TriggerDS.TPrgLib;
4b if TriggerDS.TEvent = '1';
%subst(sbfrow:24) = 'INSERT';
4x elseif TriggerDS.TEvent = '2';
%subst(sbfrow:24) = 'DELETE';
4x elseif TriggerDS.TEvent = '3';
%subst(sbfrow:24) = 'UPDATE';
4e endif;
4b if TriggerDS.TTime = '1';
%subst(sbfrow:34) = 'AFTER';
4x else;
%subst(sbfrow:34) = 'BEFORE';
4e endif;
rrn += 1;
write sbfdta1;
TriggerPtr += 48;
3e endfor;
2e endif;
1e endif;
endsr;
//--ROW 7--------------------------------------------------
// Record Formats:
// Either load rows 7 & 8 with record format information for File
// description screen, or load window for option 3 on data base relations screen.
//---------------------------------------------------------
begsr srRow7andRow8;
1b if IsOption3;
sbfRowAtr3 = White;
1x else;
sbfRowAtr = White;
1e endif;
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 = %xlate(up: lo: 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 = *blanks or WorkFileQual = '*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'
or Fild0100ds.AccessType='EV';
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;
3b If IsLowerCase;
kwork = %trimr(%xlate(up:lo:KeySpecsDS.KeyFieldName));
3x else;
kwork = %trimr(KeySpecsDS.KeyFieldName);
3e endif;
// check for descending keys
3b if %bitand(bit0: KeySpecsDS.KeySequenBits) = bit0;
kwork = kwork + '(D)';
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) + 2) > %size(KeyList))
or ((not isDbrView)
and %len(%trimr(sbfRow)) + (%len(kwork) + 2) > %size(sbfRow));
4b if IsDbrView;
%subst(sbfrow:26) = KeyList;
4e endif;
rrn += 1;
write sbfDta1;
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');
f_SndSflMsg(ProgId: f_qmhrcvpm(3));
endsr;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFD type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFD "
mbrtype = "CMD "
mbrtext = "File field descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRFFD - File Field Descriptions - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDD "
mbrtype = "DSPF "
mbrtext = "File field descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFFDD - File Field Descriptions - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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 5 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 R SBFCTL1 SFLCTL(SBFDTA1)
A SFLSIZ(0306)
A SFLPAG(0018)
A OVERLAY
A CA04 CA06 CA07 CA08
A CA09 CA10 CA11 CA15
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 70A O 3 8
A 4 2'RcdFmt:'
A COLOR(WHT)
A SCRCDFMT 10A O 4 10
A MULTIFMTS 25A O 4 21COLOR(BLU)
A 4 52'RecLen:'
A COLOR(WHT)
A RECORDLEN 5Y 0O 4 60EDTCDE(4)
A 4 67'Fields:'
A COLOR(WHT)
A FIELDCOUNT 4Y 0O 4 75EDTCDE(4)
A 5 2'Search:'
A 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 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 11'F6=Print'
A COLOR(BLU)
A 26 21'F9=By Field'
A COLOR(BLU)
A 26 34'F10=By Pos'
A COLOR(BLU)
A 26 46'F11=Show'
A COLOR(BLU)
A F11SHOW 6A O 26 55COLOR(BLU)
A DBUTILITY 10A O 26 62COLOR(BLU)
A 26 74'F4=Record Formats'
A DSPATR(&AF4KEY)
A 26 92'F7=Select/Omit'
A DSPATR(&AF7KEY)
A 26107'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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDF type DDL - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDF "
mbrtype = "DDL "
mbrtext = "File field descriptions - outfile jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
-- ----------------------------------------------------------------
-- JCRFFDF - File field descriptions - DDL
-- Craig Rutledge < www.jcrcmds.com >
-- ----------------------------------------------------------------
-- 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)
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' ,
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 ;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDH "
mbrtype = "PNLGRP "
mbrtext = "File field descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRFFD'.File Field Descriptions (JCRFFD) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDP "
mbrtype = "PRTF "
mbrtext = "File field descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFFDP - File Field Descriptions - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 132)
A INDARA
A R PRTHEAD1 SKIPB(1) SPACEA(1)
A 2'JCRFFD'
A 19'File Field Descriptions'
A 09 45'**** UNPACKED FORMAT ****'
A SCDOW 9A O 72
A 82DATE EDTCDE(Y)
A 92TIME
A 104'Page'
A +1PAGNBR EDTCDE(4) SPACEA(2)
*---
A 2'Format:'
A SCRCDFMT 10A O 10
A 22'File:'
A SCOBJHEAD 63A O 28SPACEA(1)
*----------------------------------------------------------------
A R PRTKEYS SPACEA(1)
A 2'Keys :'
A KEYLIST 70A O 10
*----------------------------------------------------------------
A R PRTHEAD2 SPACEA(2)
A 3'File Type'
A 20'Record Length'
A 43'Number of Keys'
A 62'Number of Fields' SPACEA(1)
*---
A FILETYPE4 4A O 5
A 09 20'*UNPACK CALC'
A N09 RECORDLEN 5 0O 24EDTCDE(4)
A NUMBOFKEYS 4S 0O 47EDTCDE(4)
A FIELDCOUNT 4 0O 67EDTCDE(4)
*----------------------------------------------------------------
A R PRTSELOMT SPACEA(1)
A PRINTSO 4A O 5
A SOTYPE 7A O 12
A SOFLD 10A O 20
A SOCOMP 2A O 31
A SOVALU 32A O 34
*----------------------------------------------------------------
A R PRTHEAD3 SPACEB(1) SPACEA(1)
A 3'Text'
A 50'Key'
A FLDORALIAS 9A 55
A 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' '
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDR "
mbrtype = "RPGLE "
mbrtext = "File field descriptions jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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.
//---------------------------------------------------------
ctl-opt dftactgrp(*no) actgrp(*STGMDL) datfmt(*iso) timfmt(*iso)
option(*nounref: *nodebugio) expropts(*resdecpos) bnddir('JCRCMDSDIR')
STGMDL(*TERASPACE) ALLOC(*TERASPACE);
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 Sds
/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
/define f_SndSflMsg
// *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 ScreenFieldDS extname('JCRFFDF') inz end-ds;
//---------------------------------------------------------
f_RmvSflMsg(ProgId);
ApiHeadPtr = f_Quscrtus(UserSpaceName);
f11Show = 'Keys';
// 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 dou 1=2;
Ind.sfldsp = rrn1 > 0;
Ind.sfldspctl = *on;
write msgctl;
write sfooter1;
exfmt sbfctl1;
IsSearch = *off;
f_RmvSflMsg(ProgId);
2b if InfdsFkey = f03 or InfdsFkey = f12;
LV leavesr;
2x elseif InfdsFkey = f04
and Fild0100ds.NumRcdFmts > 1;
exsr srPromptRcdFmt;
2x elseif InfdsFkey = F06;
exsr srPrintScreen;
f_SndSflMsg(ProgId: '** 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 %fields(FldAlias: sbField);
3e endfor;
2x elseif InfdsFkey = f09;
f_SndSflMsg(ProgId: 'Sort by Field Name');
f11Show = 'Keys';
SortByFld = 'SBFIELD';
exsr srResequence;
2x elseif InfdsFkey = f10;
f_SndSflMsg(ProgId: '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 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.AliasName;
2b if QuslfldDS.AliasName > *blanks;
aF8Key = Blue;
2e endif;
2b if FldText50 = *blanks
and FldAlias > *blanks; // show alias if no text
FldText50 = FldAlias;
2e endif;
// Determine if field Key field and A or Descending
aa = %lookup(sbField: KeyFldsArry: 1: KeyCount);
2b if aa > 0;
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.
//---------------------------------------------------------
4b if QuslfldDS.Digits > 0; // numeric
unsignedlength = QuslfldDS.Digits;
DecimalPos = %triml(%editc(QuslfldDS.DecimalPos:'3'));
4x else;
unsignedlength = QuslfldDS.FieldLengthA;
DecimalPos = *blanks;
4e 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;
// write to output type
//-----------------------------------------------------------------
// use a particulary 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;
write PrtPageBrk;
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;
write PrtPageBrk;
IsOverFlow = *off;
2e endif;
1e endfor;
close JCRFFDP;
f_Dltovr('JCRFFDP');
endsr;
//---------------------------------------------------------
// Sort user space then reload subfile
//---------------------------------------------------------
begsr srResequence;
rrn1 = 0;
PrtRrn = 0;
ind = *off;
write sbfctl1;
1b if IsSearch;
2b if SearchFld > *blanks;
SortByFld = 'SBFIELD';
2x elseif SearchTxt > *blanks;
SortByFld = 'SBTEXT';
2x elseif SearchKey > *blanks;
SortByFld = 'SBKEY';
2e endif;
1e endif;
qlgSortDS = %subst(qlgSortDS: 1: 80); //drop off keys
qlgsortDS.RecordLength = 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):
%xlate(lo: up: 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFFDV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFFDV "
mbrtype = "RPGLE "
mbrtext = "File field descriptions - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFREESS type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFREESS "
mbrtype = "CMD "
mbrtext = "Free/fixed side-by-side source view jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRFREESS - Free/fixed side-by-side source view - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFREESSH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFREESSH"
mbrtype = "PNLGRP "
mbrtext = "Free/fixed side-by-side source view jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRFREESS'.Free/Fixed Side-by-Side View (JCRFREESS) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
: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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFREESSP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFREESSP"
mbrtype = "PRTF "
mbrtext = "Free/fixed side-by-side source view 198 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFREESSP - Free/fixed side-by-side source view - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- 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 100
A 110DATE EDTCDE(Y) SPACEA(1)
*---
A 2'Mbr:'
A SCOBJHEAD 105A O 7SPACEA(2)
*---
A 1'Seqno'
A 10'Factor 1'
A 25'Opcode'
A 36'Factor 2'
A 51'Result Field'
A 65'RI'
A 75'Free 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFREESSR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFREESSR"
mbrtype = "RPGLE "
mbrtext = "Free/fixed side-by-side source view jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 SrcDS
/define Constants
/define f_DisplayLastSplf
/define f_GetQual
/define f_IsCompileTimeArray
/define f_GetDayName
/define f_BuildString
/define f_System
/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 OpUp len(10);
DoIfWh char(2) pos(1);
EndOpcode char(3) pos(1);
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_System('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 SrcDS.SpecType = 'P'
or SrcDS.SpecType = 'p';
1v leave;
2e endif;
// see if inside /free
2b if SrcDS.Asterisk = '/';
SrcDS.FreeForm = %xlate(lo: up: SrcDS.FreeForm);
3b if SrcDS.FreeForm = '/FREE';
IsFree = *on;
IsCalcSpec = *on;
3x elseif SrcDS.FreeForm = '/END-FREE';
IsFree = *off;
3e endif;
3b if SrcDS.FreeForm = '/EXEC SQL';
IsSQL = *on;
IsCalcSpec = *on;
3x elseif SrcDS.FreeForm = '/END-EXEC';
IsSQL = *off;
3e endif;
2e endif;
2b if SrcDS.SpecType = 'C'
or SrcDS.SpecType = 'c';
IsCalcSpec = *on;
2e endif;
2b if SrcDS.SpecType = 'O'
or SrcDS.SpecType = 'o'
or SrcDS.SpecType = 'D'
or SrcDS.SpecType = 'd'
or SrcDS.SpecType = 'F'
or SrcDS.SpecType = 'f';
IsCalcSpec = *off;
2e endif;
2b if IsCalcSpec;
DownOneLevel = *off;
UpOneLevel = *off;
3b if not(SrcDS.Asterisk = '+' or SrcDS.Asterisk = '/');
4b if SrcDS.OpCode > *blanks;
IsCallp = *off;
4e endif;
OpUp = %xlate(lo: up: SrcDS.OpCode);
4b if SrcDS.Asterisk = '*';
4x elseif EndOpcode = 'CAS';
IsCasxx = *on;
4x elseif DoIfWh = 'DO'
or DoIfWh = 'IF'
or OpUp = 'SELECT'
or OpUp = 'BEGSR'
or OpUp = 'FOR'
or OpUp = 'MONITOR'
or %subst(OpUp: 1: 4) = 'FOR(';
DownOneLevel = *on;
// Set Flag if END is found
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 SrcDS.SlashComment = '/E' or
SrcDS.SlashComment = '/e';
Work = *blanks;
//---------------------------------------------------------
// All DO statements must be converted to FOR opcodes
// There are 5 variations of on DO
// DO = FOR JCRCNT = 1 to 1
// DO xx = FOR JCRCNT = 1 to xx
// DO xx yy = FOR yy = 1 to xx
// aa DO xx = FOR JCRCNT = aa to xx
// aa DO xx yy = FOR yy = aa to xx
// Counter field JCRCNT is provided to make FOR work
//---------------------------------------------------------
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 %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 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 = 'EXCEPT '
or OpUp = 'EXFMT'
or OpUp = 'EXSR'
or OpUp = 'ELSE'
or OpUp = 'ELSEIF'
or OpUp = 'FORCE'
or OpUp = 'ITER'
or OpUp = 'LEAVE'
or OpUp = 'LEAVESR'
or OpUp = 'OTHER '
or %subst(OpUp: 1: 5) = 'CLOSE'
or %subst(OpUp: 1: 4) = 'OPEN'
or %subst(OpUp: 1: 5) = 'READ '
or %subst(OpUp: 1: 5) = 'READ('
or %subst(OpUp: 1: 5) = 'READC'
or %subst(OpUp: 1: 5) = 'READP'
or OpUp = 'SELECT '
or OpUp = 'SORTA '
or %subst(OpUp: 1: 6) = 'UPDATE'
or %subst(OpUp: 1: 5) = 'WRITE'
or %subst(OpUp: 1: 4) = 'FEOD';
Work = %trimr(SrcDS.OpCode) +
' ' +
%trimr(SrcDS.Factor2) +
' ' +
SrcDS.ResultField;
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 = %xlate(lo: up: SrcDS.Factor2);
rfupper = %xlate(lo: up: SrcDS.ResultField);
Work = 'eval';
1b if OpUp = 'ADDDUR(E)'
or OpUp = 'SUBDUR(E)';
Work = 'eval(e)';
1e endif;
xx = %scan(':': SrcDS.Factor2);
1b if xx > 0;
Work = %trimr(Work) +
' ' +
%trimr(SrcDS.ResultField) + ' =';
2b if SrcDS.Factor1 = *blank;
Work = %trimr(Work) + ' ' + SrcDS.ResultField;
2x else;
Work = %trimr(Work) + ' ' + SrcDS.Factor1;
2e endif;
2b if %subst(OpUp: 1: 6) = 'ADDDUR';
Work = %trimr(Work) + ' + ';
2x else;
Work = %trimr(Work) + ' - ';
2e endif;
xx = %scan(':': SrcDS.Factor2);
2b if %subst(F2upper: xx + 1) = '*MSECONDS'
or %subst(F2upper: xx + 1) = '*MS';
Work = %trimr(Work) + ' %mseconds(';
2x elseif %subst(F2upper: xx + 1) = '*SECONDS'
or %subst(F2upper: xx + 1) = '*S';
Work = %trimr(Work) + ' %seconds(';
2x elseif %subst(F2upper: xx + 1) = '*MINUTES'
or %subst(F2upper: xx + 1) = '*MN';
Work = %trimr(Work) + ' %minutes(';
2x elseif %subst(F2upper: xx + 1) = '*HOURS'
or %subst(F2upper: xx + 1) = '*H';
Work = %trimr(Work) + ' %hours(';
2x elseif %subst(F2upper: xx + 1) = '*DAYS'
or %subst(F2upper: xx + 1) = '*D';
Work = %trimr(Work) + ' %days(';
2x elseif %subst(F2upper: xx + 1) = '*MONTHS'
or %subst(F2upper: xx + 1) = '*M';
Work = %trimr(Work) + ' %months(';
2x elseif %subst(F2upper: xx + 1) = '*YEARS'
or %subst(F2upper: xx + 1) = '*Y';
Work = %trimr(Work) + ' %year(';
2e endif;
Work = %trimr(Work) +
%subst(SrcDS.Factor2: 1: xx - 1) +
')';
1x else;
//---------------------------------------------------------
// Process DIFF statements
// first extract field from RF
xx = %scan(':': SrcDS.ResultField);
Work = %trimr(Work) +
' ' +
%subst(SrcDS.ResultField: 1: xx - 1) +
' = %diff(' +
%trimr(SrcDS.Factor1) +
':' +
%trimr(SrcDS.Factor2) + ':' +
%trimr(%subst(SrcDS.ResultField: xx + 1)) + ')';
1e endif;
endsr;
//---------------------------------------------------------
begsr srLOOKUP;
zz = *blanks;
lf2 = SrcDS.Factor2;
f2upper = %xlate(lo: up: SrcDS.Factor2);
Work = 'eval';
1b if %subst(F2upper: 1: 3) = 'TAB';
Work = 'eval *in' +
%trim(SrcDS.ResultingInd) + ' = %tlookup';
1x else;
xx = %scan('(': SrcDS.Factor2);
2b if xx = 0;
3b if (SrcDS.ResultingInd) > *blanks;
Work = 'eval *in' +
%trim(SrcDS.ResultingInd) + ' = %lookup';
3x else;
Work = 'eval JCRInt = %lookup';
3e endif;
2x else;
yy = %scan(')': SrcDS.Factor2: xx);
lf2 = %subst(SrcDS.Factor2: 1: xx - 1);
zz = %subst(SrcDS.Factor2: xx + 1: yy - (xx + 1));
Work = 'eval ' +
%trimr(zz) + ' = %lookup';
2e endif;
1e endif;
// Now look at indicators assigned and tack on type lookup
1b if SrcDS.EQind > *blanks
and SrcDS.HIind = *blanks
and SrcDS.LOind = *blanks;
Work = %trimr(Work) + 'EQ(';
1x elseif SrcDS.EQind = *blanks
and SrcDS.HIind > *blanks
and SrcDS.LOind = *blanks;
Work = %trimr(Work) + 'GT(';
1x elseif SrcDS.EQind = *blanks
and SrcDS.HIind = *blanks
and SrcDS.LOind > *blanks;
Work = %trimr(Work) + 'LT(';
1x elseif SrcDS.EQind > *blanks
and SrcDS.HIind > *blanks
and SrcDS.LOind = *blanks;
Work = %trimr(Work) + 'GE(';
1x elseif SrcDS.EQind > *blanks
and SrcDS.HIind = *blanks
and SrcDS.LOind > *blanks;
Work = %trimr(Work) + 'LE(';
1x else;
Work = %trimr(Work) + '??(';
1e endif;
Work = %trimr(Work) + %trimr(SrcDS.Factor1) + ':' +
%trimr(lf2);
1b if 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 = %xlate(lo: up: Work);
aa = %checkr(' ': WorkUpper);
1b if LineOfCode > *blanks
and (aa > 3
and (not IsComment)
and (not IsSQL)
and not(%subst(WorkUpper: aa: 1) = '+'
or %subst(WorkUpper: aa: 1) = ':'
or %subst(WorkUpper: aa: 1) = '<'
or %subst(WorkUpper: aa: 1) = '>'
or %subst(WorkUpper: aa: 1) = '='
or %subst(WorkUpper: aa: 1) = '('
or %subst(WorkUpper: aa - 3: 4) = ' AND'
or %subst(WorkUpper: aa - 2: 3) = ' OR'));
LineOfCode = %trimr(LineOfCode) + ';';
1e endif;
// Tack on comment field
1b if SrcDS.SrcComment > *blanks
and not IsComment;
2b if %subst(LineOfCode: 91: 2) = ' '; //leave comments as is
%subst(LineOfCode: 91: 2) = '//';
%subst(LineOfCode: 93: 20) = SrcDS.SrcComment;
2x else;
LineOfCode = %trimr(LineOfCode) + ' // ' + SrcDS.SrcComment;
2e endif;
1e endif;
1b if DownOneLevel; //INDENT?
LevelsDeep += 1;
1e endif;
1b if SrcDS.SlashComment > *blanks and not
(%subst(SrcDS.SlashComment: 1: 1) = '/'
or %subst(SrcDS.SlashComment: 1: 1) = '+'
or %subst(SrcDS.SlashComment: 1: 1) = '*');
LineOfCode = '??' +
SrcDS.SlashComment +
'??????? ' +
LineOfCode;
OpUpsave = OpUp;
OpUp = 'LevelInd';
exsr srLoadError;
OpUp = OpUpsave;
1e endif;
1b if SrcDS.Conditioning > *blanks and not
(%subst(SrcDS.SlashComment: 1: 1) = '/'
or %subst(SrcDS.SlashComment: 1: 1) = '+'
or %subst(SrcDS.SlashComment: 1: 1) = '*');
LineOfCode = '??' +
SrcDS.Conditioning +
'??????? ' +
LineOfCode;
OpUpsave = OpUp;
OpUp = 'ConditInd';
exsr srLoadError;
OpUp = OpUpsave;
1e endif;
1b if OpUp = 'KLIST' or OpUp = 'KFLD';
LineOfCode = SrcDS.Src112;
1e endif;
write PrtCspec;
endsr;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSET type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSET "
mbrtype = "CMD "
mbrtext = "Scan file set where used jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRFSET - Scan File Set Where Used - CMD */
/* added special values to SRCFILE parm so groups of */
/* files can be searched if value is selected. Add records to */
/* file JCRSMLTCHF to select many source files with single keyword. */
/* NOTE: CHOICEKEY MUST START WITH * . */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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,RPG,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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETF type DDL - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETF "
mbrtype = "DDL "
mbrtext = "Scan file set where used - outfile jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
-- ----------------------------------------------------------------
-- JCRFSETF - Scan File Set Where Used outfile support - DDL
-- Craig Rutledge < www.jcrcmds.com >
-- ----------------------------------------------------------------
-- 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 ;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETH "
mbrtype = "PNLGRP "
mbrtext = "Scan file set where used jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRFSET'.Scan File Set Where Used (JCRFSET) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
:P.Scans selected 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.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETP type PRTF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETP "
mbrtype = "PRTF "
mbrtext = "Scan file set where used 198 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRFSETP - Scan File Set Where Used - PRTF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
*--- PAGESIZE(66 198) CPI(15)
A INDARA
A R PRTHEAD SKIPB(1) SPACEA(1)
A 2'JCRFSET'
A 20'Scan File Set Where Used'
A SCDOW 9A O 82
A 92DATE EDTCDE(Y)
A 109'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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETR "
mbrtype = "RPGLE "
mbrtext = "Scan file set where used - scanner jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 rpg 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(*TERASPACE);
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 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_System
/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_System(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 = %xlate(lo: up: SrcDS.Src112);
2b if %scan('DCLF':SrcDS.Src112) > 0;
SrcDS.Src112 = f_BlankCommentsCL(SrcDS.Src112);
cc = %scan('DCLF':SrcDS.Src112);
3b if cc > 0;
//---------------------------------------------------------
// check and see if PF is used first
//---------------------------------------------------------
// if 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETS type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETS "
mbrtype = "RPGLE "
mbrtext = "Scan file set where used - sbmjob jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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_system
/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_system('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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRFSETV type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRFSETV "
mbrtype = "RPGLE "
mbrtext = "Scan file set where used - validity jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRF7 type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRF7 "
mbrtype = "RPGLE "
mbrtext = "Seu exit program f7 split/combine line jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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) expropts(*resdecpos)
datfmt(*iso) timfmt(*iso) option(*nodebugio: *nounref)
STGMDL(*TERASPACE) ALLOC(*TERASPACE);
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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGAMES type CMD - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGAMES "
mbrtype = "CMD "
mbrtext = "Games selection menu jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRGAMES - Games selection menu - CMD */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
CMD PROMPT('JCR Games Selection Menu')
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGAMESC type CLLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGAMESC "
mbrtype = "CLLE "
mbrtext = "Games selection menu jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
/*--------------------------------------------------------------------------*/
/* JCRGAMESC - Games selection menu - CMDPGM */
/* Craig Rutledge < www.jcrcmds.com > */
/*--------------------------------------------------------------------------*/
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
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGAMESD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGAMESD "
mbrtype = "DSPF "
mbrtext = "Games selection menu jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRGAMESD- JCR games selection menu - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
A DSPSIZ(24 80 *DS3 27 132 *DS4)
A PRINT CA03(03) CA12(12)
A R SCREEN OVERLAY
A *DS3 WINDOW(&SCLIN &SCPOS 13 31)
A *DS4 WINDOW(&SCLIN &SCPOS 14 31)
A SCLIN 2S 0P
A SCPOS 2S 0P
A 1 2'JCRGAMES' 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGAMESH type PNLGRP - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGAMESH "
mbrtype = "PNLGRP "
mbrtext = "Games selection menu jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
:PNLGRP.:HELP NAME='JCRGAMES'.Games Selection Menu (JCRGAMES) - Help
.*--------------------------------------------------------------------
.* Craig Rutledge < www.jcrcmds.com >
.*--------------------------------------------------------------------
:P.Pop-up window to select educational games program.:EHELP.:EPNLGRP.
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGETCLPR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGETCLPR"
mbrtype = "RPGLE "
mbrtext = "Get parm list and attributes from CLx pgms jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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_System
/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) pos(2);
iDeclaredVar char(18) pos(2);
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_system('CLRPFM QTEMP/JCRGETCLPF');
1x else;
f_System('CRTPF FILE(QTEMP/JCRGETCLPF) RCDLEN(132)');
1e endif;
f_system('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)');
QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100');
1b if QusrmbrdDS.MbrType = 'CLP';
f_system('CRTCLPGM PGM(QTEMP/' + p_SrcMbr +
') SRCFILE(' + f_GetQual(p_SrcFilQual) +
') OPTION(*SOURCE *XREF *NOGEN)');
1x else;
f_system('CRTBNDCL PGM(QTEMP/' + p_SrcMbr +
') SRCFILE(' + f_GetQual(p_SrcFilQual) +
') OPTION(*XREF) OUTPUT(*PRINT)');
f_system('DLTPGM PGM(QTEMP/' + p_SrcMbr + ')');
1e endif;
f_system('CPYSPLF FILE(' + p_SrcMbr +
') TOFILE(QTEMP/JCRGETCLPF) SPLNBR(*LAST)');
f_system('DLTOVR FILE(' + p_SrcMbr + ')');
//---------------------------------------------------------
// read listing
aa = 0;
cc = 0;
CountClParms = 0;
open JCRGETCLPF;
read JCRGETCLPF inputDS;
1b dow not %eof;
%subst(iSourceCode:95) = *blanks;
iSourceCode = f_BlankCommentsCL(iSourceCode);
iSourceCode = %xlate(lo: up: iSourceCode);
// get to the PGM command
2b if (not IsPgm) and
(%subst(iSourceCode: 1: 4) = 'PGM ' or
%scan(' PGM ': iSourceCode) > 0);
IsPgm = *on;
2e endif;
// Now extract anything with a & in front up to a space or )
2b if IsPgm;
3b if %scan(' DCL ': iSourceCode) > 0
or %scan(' DCLF ': iSourceCode) > 0
or %subst(iSourceCode: 1: 4) = 'DCL '
or %subst(iSourceCode: 1: 4) = 'DCLF'
or iEndOfSource = 'E N D O F S O U R C E';
1v leave;
3e endif;
IsFoundVar = *off;
3b for aa = 1 to %len(iSourceCode);
4b if %subst(iSourceCode:aa:1) = '&';
IsFoundVar = *on;
CountClParms += 1;
cc = 0;
4e endif;
4b if IsFoundVar;
5b if %subst(iSourceCode:aa:1) = ' '
or %subst(iSourceCode:aa:1) = ')';
IsFoundVar = *off;
5x else;
cc += 1;
%subst(ArryOfClParms(CountClParms) :cc :1) =
%subst(iSourceCode: aa: 1);
5e endif;
4e endif;
3e endfor;
2e endif;
read JCRGETCLPF 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGETFILR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGETFILR"
mbrtype = "RPGLE "
mbrtext = "Get file format/file xref from RPG4 source jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 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-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) pos(19);
Src74 char(74) pos(19);
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 char(187) dim(256); // JCRRFILR
p_FspecArry char(512) dim(256); // JCRHFDR & JCRANZOV
p_CommentArry char(20) dim(256); // JCRHFDR 1 to 1 with FspecArry
p_PrNameArry char(74) dim(256); // JCRHFDR 1 to 1 with FspecArry
p_DeleteArry char(1) 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 = %xlate(lo: up: p_FspecArry(ff));
// no free format for primary, secondary, table.
2b if FspecDS.FileType = 'U'
and
(FspecDS.Designation = ' '
or FspecDS.Designation = 'F')
and (
FspecDS.RecordAddressType = ' '
or FspecDS.RecordAddressType = 'A'
or FspecDS.RecordAddressType = '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 = %xlate(lo: up: 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 = %xlate(lo: up: 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);
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
// 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) = ' ' or %subst(fstring:bb:1) = ';';
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);
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 = %xlate(lo: up: InputDS.SpecType);
// get delete statements as they roll by
1b if UpSpec = 'C' and
%xlate(lo:up:InputDS.OpCode) = 'DELETE';
DeleteCnt += 1;
DeleteStatements(DeleteCnt).PrName = dxname;
DeleteStatements(DeleteCnt).FileOrRcdfmt =
%xlate(lo: up: 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 = %xlate(lo: up: dxname);
1x elseif InputDS.SpecType = *blanks
and InputDS.Asterisk = *blanks;
string = %xlate(lo: up: 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 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 dou 1 = 2;
read RPGSRC InputDS;
2b if %eof;
1v leave;
2e endif;
2b if not f_IsComment;
3b if f_StartNewFspec
or not(InputDS.SpecType = 'F' or InputDS.SpecType = 'f');
readp RPGSRC InputDS;
1v leave;
3e endif;
3b if (InputDS.SpecType = 'F' or 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);
bb = %scan('/': fstring: QuoteStart + 1);
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
//---------------------------------------------------------
begsr srLoadRenamed;
NextRename = 0;
1b dou 1 = 2;
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 : .
// Idea here is 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).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).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 = %xlate(up: lo: 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 = %xlate(lo:up: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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGETFLDR type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGETFLDR"
mbrtype = "RPGLE "
mbrtext = "Get field attributes from RPG4 programs jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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_System
/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_system('CLRPFM QTEMP/JCRGETFLDF');
1x else;
f_System('CRTPF FILE(QTEMP/JCRGETFLDF) RCDLEN(132) SIZE(*NOMAX)');
1e endif;
f_system('OVRPRTF FILE(' + p_SrcMbr + ') HOLD(*YES)');
QusrmbrdDS = f_Qusrmbrd(p_SrcFilQual: p_SrcMbr: 'MBRD0100');
1b if QusrmbrdDS.MbrType = 'SQLRPGLE';
f_system(f_BuildString('+
CRTSQLRPGI OBJ(QTEMP/&) SRCFILE(&) OPTION(*NOXREF *GEN) +
OUTPUT(*PRINT) COMPILEOPT(&QDFTACTGRP(*NO)&Q)':
p_SrcMbr:
f_GetQual(p_SrcFilQual)));
f_system('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_system(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_system('CPYSPLF FILE(' + p_SrcMbr +
') TOFILE(QTEMP/JCRGETFLDF) SPLNBR(*LAST)');
f_system('DLTOVR FILE(' + p_SrcMbr + ')');
f_system('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_system('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 = ' A('
or iGlobAttr3 = ' B('
or iGlobAttr3 = ' F('
or iGlobAttr3 = ' G('
or iGlobAttr3 = ' I('
or iGlobAttr3 = ' N('
or iGlobAttr3 = ' P('
or iGlobAttr3 = ' S('
or iGlobAttr3 = ' D('
or iGlobAttr3 = ' T('
or iGlobAttr3 = ' U('
or iGlobAttr3 = ' Z('
or iGlobAttr3 = ' *('
or iGlobAttr3 = ' DS'
or iGlobAttr3 = ' CO';
IsUnReferenced = *off;
//---------------------------------------------------------
// Extract the field name for these attributes.
// The field name could be on the same line
// RULER1ARRY(19) A(10)
// or read backwards a line
// 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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGMBLJ type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGMBLJ "
mbrtype = "RPGLE "
mbrtext = "BlackJack 21 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 Hand dim(2) qualified based(ptr);
Card dim(6) likeds(CardDS);
end-ds;
dcl-ds CardDS qualified;
row dim(3) likeds(ColumnDS);
end-ds;
dcl-ds ColumnDS qualified;
col char(1) dim(3);
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 = 1 or Card = 5;
Color = %bitor(RED: RI);
3x elseif Card = 2 or Card = 6;
Color = %bitor(WHITE: RI);
3x elseif Card = 3;
Color = %bitor(YELLOW: RI);
3x elseif Card = 4;
Color = %bitor(BLUE: RI);
3e endif;
BorderA(hh).Card(Card) = Color;
3b for row = 1 to 3;
HandA(hh).Card(Card).Row(row).Col(*) = Color;
3e endfor;
2e endfor;
1e endfor;
DealerShow = 21;
PlayerHas = 21;
//---------------------------------------------------------
// Play the game.
1b dou 1 = 2;
2b if DealerShow > 0;
exsr srShowBigTot;
2e endif;
exfmt screen;
2b if InfdsFkey = f03 or InfdsFkey = 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;
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;
//---------------------------------------------------------
// Idea here, is to show card values in large characters
//---------------------------------------------------------
begsr srShowBigTot;
evalr yyAlpha = '000' + %char(DealerShow);
yy = %dec(%subst(yyAlpha:3:1) :1 :0);
exsr srColorBig;
Deal1s(*) = Big(*);
Deal1sA(*) = BigA(*);
yy = %dec(%subst(yyAlpha:2:1) :1 :0);
1b if yy = 0; // zero suppress
2b for yy = 1 to 7;
Deal10s(yy).col(*) = *blanks;
Deal10sA(yy).col(*) = ND;
2e endfor;
1x else;
exsr srColorBig;
Deal10s(*) = Big(*);
Deal10sA(*) = BigA(*);
1e endif;
evalr yyAlpha = '000' + %char(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 = 3;
Line(1) = '333 ';
Line(2) = ' 3';
Line(3) = ' 3';
Line(4) = ' 333';
Line(5) = ' 3';
Line(6) = ' 3';
Line(7) = '333 ';
1x elseif pBaseNum = 2;
Line(1) = '222 ';
Line(2) = ' 2';
Line(3) = ' 2';
Line(4) = ' 22 ';
Line(5) = '2 ';
Line(6) = '2 ';
Line(7) = '2222';
1x elseif pBaseNum = 1;
Line(*) = ' 1 ';
Line(1) = ' 11 ';
Line(7) = ' 111';
1x elseif pBaseNum = 0;
Line(*) = '0 0';
Line(1) = ' 00 ';
Line(7) = ' 00 ';
1x elseif pBaseNum = 9;
Line(1) = '9999';
Line(2) = '9 9';
Line(3) = '9 9';
Line(4) = '9999';
Line(5) = ' 9';
Line(6) = ' 9';
Line(7) = '9999';
1x elseif pBaseNum = 8;
Line(1) = '8888';
Line(2) = '8 8';
Line(3) = '8 8';
Line(4) = '8888';
Line(5) = '8 8';
Line(6) = '8 8';
Line(7) = '8888';
1x elseif pBaseNum = 7;
Line(1) = '7777';
Line(2) = ' 7';
Line(3) = ' 7';
Line(4) = ' 7 ';
Line(5) = ' 7 ';
Line(6) = '7 ';
Line(7) = '7 ';
1x elseif pBaseNum = 6;
Line(1) = '6666';
Line(2) = '6 ';
Line(3) = '6 ';
Line(4) = '6666';
Line(5) = '6 6';
Line(6) = '6 6';
Line(7) = '6666';
1x elseif pBaseNum = 5;
Line(1) = '5555';
Line(2) = '5 ';
Line(3) = '5 ';
Line(4) = '5555';
Line(5) = ' 5';
Line(6) = ' 5';
Line(7) = '5555';
1x elseif pBaseNum = 4;
Line(1) = ' 44';
Line(2) = ' 4 4';
Line(3) = '4 4';
Line(4) = '4444';
Line(5) = ' 4';
Line(6) = ' 4';
Line(7) = ' 4';
1e endif;
return Line;
end-proc;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGMBLJD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGMBLJD "
mbrtype = "DSPF "
mbrtext = "BlackJack 21 jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRGMBLJD - Black Jack - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGMBTL type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGMBTL "
mbrtype = "RPGLE "
mbrtext = "BattleShip jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// 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 dou 1 = 2;
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 = f03 or InfdsFkey = 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) = 'm'
or Defend(row).Col(col) = 'H'
or Defend(row).Col(col) = 'S');
5b if %rem(row + col: 2) = 0;
yy += 1;
HashRow(yy) = row;
HashCol(yy) = col;
5e endif;
4e endif;
3e endfor;
2e endfor;
2b if yy > 0;
xx = f_GetRandom(yy);
f_DropBombOnX(HashRow(xx): HashCol(xx));
2e endif;
1e endif;
endsr;
//---------------------------------------------------------
// Let user set up right side ship locations
begsr srSetupUserShips;
csrRow = 5;
cSrCol = 8;
BlueRi = %bitor(WHITE: RI);
RedRi = %bitor(RED: RI);
Attack(*) = *all' ';
AttackA(*) = *allx'00';
Deployed(*) = *all' ';
// load big F5 to grid so player knows what button to hit
Defend(1) = 'FFFF 55555';
Defend(2) = 'FFFF 55555';
Defend(3) = 'FF 55 ';
Defend(4) = 'FF 55 ';
Defend(5) = 'FFF 555 ';
Defend(6) = 'FFF 555 ';
Defend(7) = 'FF 55';
Defend(8) = 'FF 55';
Defend(9) = 'FF 5555 ';
Defend(10) = 'FF 555 ';
1b for row = 1 to 10;
2b for col = 1 to 10;
3b if Defend(row).Col(col) = ' ';
Defend(row).Col(col) = '.';
DefendA(row).Col(col) = Blue;
3x else;
DefendA(row).Col(col) = %bitor(Blue: RI);
3e endif;
2e endfor;
1e endfor;
TimesHit2 = 0;
TimesHit3 = 0;
TimesHit4 = 0;
TimesHit5 = 0;
Udspatr2 = x'00';
Udspatr3 = x'00';
Udspatr4 = x'00';
Udspatr5 = x'00';
UserxHit2 = 0;
UserxHit3 = 0;
UserxHit4 = 0;
UserxHit5 = 0;
edspatr2 = x'00';
edspatr3 = x'00';
edspatr4 = x'00';
edspatr5 = x'00';
GameOver = *blanks;
aGameover = ND;
aDeployMsg = ND;
IsDeployed = *off;
1b dou 1 = 2;
exfmt screen1;
2b if InfdsFkey = f03 or InfdsFkey = f12;
*inlr = *on;
return;
2e endif;
aDeployMsg = ND;
//---------------------------------------------------------
// Computer generate defense grid layout
2b if InfdsFkey = f05;
f_GenerateDeployment();
Defend(*) = Deployed(*);
BlueRi = %bitor(Blue: RI);
RedRi = %bitor(Blue: RI);
3b for row = 1 to 10;
4b for col = 1 to 10;
5b if Defend(row).Col(col) = ' ';
Defend(row).Col(col) = '.';
DefendA(row).Col(col) = BLUE;
5x else;
6b if Defend(row).Col(col) = '2';
DefendA(row).Col(col) = %bitor(Turq: RI);
6x elseif Defend(row).Col(col) = '3';
DefendA(row).Col(col) = %bitor(Yellow: RI);
6x elseif Defend(row).Col(col) = '4';
DefendA(row).Col(col) = %bitor(PINK: RI);
6x elseif Defend(row).Col(col) = '5';
DefendA(row).Col(col) = %bitor(RED: RI);
6e endif;
5e endif;
4e endfor;
3e endfor;
IsDeployed = *on;
1i iter;
2x else;
//---------------------------------------------------------
// Let battle begin. turn all ships reverse image green for stealth
3b if IsDeployed;
4b for row = 1 to 10;
5b for col = 1 to 10;
6b if 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;
dcl-pi *n end-pi;
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 = 9
and TimesHit3 = 9
and TimesHit4 = 9
and TimesHit5 = 9;
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;
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGMBTLD type DSPF - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGMBTLD "
mbrtype = "DSPF "
mbrtext = "BattleShip jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
*----------------------------------------------------------------
* JCRGMBTLD - Battleship - DSPF
* Craig Rutledge < www.jcrcmds.com >
*----------------------------------------------------------------
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 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 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)
]]> </copysrc>
</mbr>
<sendmsg sendmsgid="CPF9897" sendmsgtype = "*STATUS "><![CDATA[
Extracting JCRGMCRB type RPGLE - in progress.
]]> </sendmsg>
<!-- START OF MEMBER -->
<mbr
mbrname = "JCRGMCRB "
mbrtype = "RPGLE "
mbrtext = "Cribbage jcr "
srcfile = "JCRCMDS "
srclib = "selected "
srclen = "00112"
srcccsid= "00037">
<copysrc><![CDATA[
//---------------------------------------------------------
ctl-opt copyright('This program is free software, you can redistribute +
it and/or modify it under the terms of the GNU General Public License +
as published by the Free Software Foundation. See GNU General Public +
License for detail. Craig Rutledge < www.jcrcmds.com > ');
//---------------------------------------------------------
// JCRGMCRB - Cribbage
//---------------------------------------------------------
/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 Face dim(4) qualified based(ptr1);
row likeds(RowDsx) dim(3);
end-ds;
dcl-ds RowDsx qualified;
col char(2) dim(4);
end-ds;
dcl-s ptr1 pointer inz(%addr(chand11));
// screen field attributes 3d array
dcl-ds Attr dim(4) qualified based(ptr2);
row likeds(RowDsy) dim(3);
end-ds;
dcl-ds RowDsy qualified;
col char(1) dim(4);
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;
1b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
1e endif;
// 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 dou 1 = 2;
2b if NextStepFlg = 'Craig Plays a Card'
or NextStepFlg = 'Play Craig 1st card';
2x else;
exfmt screen;
2e endif;
2b if InfdsFkey = f03 or InfdsFkey = 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')) + ' .' +
' Press Enter to Play again.';
ind.Play1stCard = *off;
ind.Play2ndCard = *off;
ind.Play3rdCard = *off;
ind.Play4thCard = *off;
ind.Play5thCard = *off;
ind.Play6thCard = *off;
usermsga = *blanks;
usermsg = *blanks;
exfmt screen;
exsr srExitPgm;
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 to start card.
ind.Play5thCard = *off;
ind.Play6thCard = *off;
Deck1 = f_GetCardFace(NewCard(13));
Deck1a = %bitor(WHITE: PR: UL);
Deck2a = f_GetCardColor(NewSuite(13));
Deck3a = f_GetCardColor(NewSuite(13));
//---------------------------------------------------------
// Load two user discards into crib .
// Load four 'keepers' into users Play array.
//---------------------------------------------------------
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;
2b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
2e endif;
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;
2b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
2e endif;
IsLoadGraph = *on;
exsr srMoveBarGraph;
1e endif;
ShowScoreSbf = 'NO';
endsr;
//---------------------------------------------------------
// Load subfile for Craigs scores
//---------------------------------------------------------
begsr srScoreCraig;
ind.BorderRed = *on;
ind.BorderBlue = *off;
SavDeck(2) = cPlay4(1);
SavDeck(3) = cPlay4(2);
SavDeck(4) = cPlay4(3);
SavDeck(5) = cPlay4(4);
TstDeck = SavDeck;
scoremsg = ' Craig' + QuoteMark + 's Hand';
WhoPlayed = 'Craig';
IsLoadGraph = *off;
exsr srScoreHand;
// check for flush
IsFlush = *off;
1b if csuite4(1) = csuite4(2)
and csuite4(1) = csuite4(3)
and csuite4(1) = csuite4(4);
IsFlush = *on;
HandScore += 4;
sbfTotal = HandScore;
// -- write flush record ----
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;
1b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
1e endif;
IsLoadGraph = *on;
exsr srMoveBarGraph;
endsr;
//---------------------------------------------------------
// Load subfile for users scores
//---------------------------------------------------------
begsr srScoreUser;
ind.BorderRed = *off;
ind.BorderBlue = *on;
SavDeck(2) = uPlay4(1);
SavDeck(3) = uPlay4(2);
SavDeck(4) = uPlay4(3);
SavDeck(5) = uPlay4(4);
TstDeck = SavDeck;
scoremsg = ' Your Hand';
WhoPlayed = 'You';
IsLoadGraph = *off;
exsr srScoreHand;
// check for user flush
IsFlush = *off;
1b if usuite4(1) = usuite4(2)
and usuite4(1) = usuite4(3)
and usuite4(1) = usuite4(4);
IsFlush = *on;
HandScore += 4;
sbfTotal = HandScore;
// -- write flush record ----
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;
1b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
1e endif;
IsLoadGraph = *on;
exsr srMoveBarGraph;
endsr;
//---------------------------------------------------------
// Check for Nobs. Any hand that has Jack of
// same suite as start card gets 1 point.
//---------------------------------------------------------
begsr srScoreNobs;
1b for ax = 2 to 5;
2b if SavCard(ax) = 11
and SavSuite(ax) = NewSuite(13);
HandScore += 1;
sbfTotal = HandScore;
// write nobs sbf record
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) = f_GetCardColor(CribSuite(ax));
1e endfor;
endsr;
//---------------------------------------------------------
// Deal next hand
//---------------------------------------------------------
begsr srNextHand;
Face(*) = *all' ';
Attr(*) = *allx'00';
PlayCraig(*) = *all' ';
PlayCraigA(*) = *allx'00';
PlayUser(*) = *all' ';
PlayUserA(*) = *allx'00';
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.
// users hand = 3ah
//---------------------------------------------------------
sorta uDealt;
Attr(3).Row(1).Col(*) = %bitor(WHITE: PR: UL);
Attr(3).Row(3).Col(*) = x'00';
1b for ax = 1 to 4;
Face(3).Row(1).Col(ax) = f_GetCardFace(uFace(ax));
Attr(3).Row(2).Col(ax) = f_GetCardColor(uSuite(ax));
1e endfor;
uHand15 = f_GetCardFace(uface(5));
uhand16 = f_GetCardFace(uface(6));
uhand15a = %bitor(WHITE: PR: UL);
uhand16a = %bitor(WHITE: PR: UL);
uhand25a = f_GetCardColor(uSuite(5));
uhand26a = f_GetCardColor(uSuite(6));
uhand35a = x'00';
uhand36a = x'00';
exsr srLoadCraigHand;
endsr;
//---------------------------------------------------------
// Load scoring cards and colors into subfile
//---------------------------------------------------------
begsr srLoadSbfRec;
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;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3e endif;
3b if sRunOf7s > 0;
HandScore = 7;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Run of 7 for 7. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sRunOf6s > 0;
HandScore = 6;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Run of 6 for 6. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sRunOf5s > 0;
HandScore = 5;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Run of 5 for 5. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sFourOfKind > 0;
HandScore = 12;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored 4 of a kind for 12. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sRunOf4s > 0;
HandScore = 4;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Run of 4 for 4. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sThreeOfKind > 0;
HandScore = 6;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored 3 of a kind for 6. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sRunOf3s > 0;
HandScore = 3;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Run of 3 for 3. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3x elseif sPairs > 0;
HandScore = 2;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Pair for 2. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
3e endif;
3b if RunningTot = 31;
ind.CraigSaysGo = *off;
ind.UserSaysGo = *off;
HandScore = 1;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored 31 for 1. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
4b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
4e endif;
exsr srResetPlay;
3e endif;
2x else;
//---------------------------------------------------------
// Process Go scoring here
//---------------------------------------------------------
HandScore = 1;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored GO for 1. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
3b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
3e endif;
exsr srResetPlay;
2e endif;
//---------------------------------------------------------
// Process last Card played scoring
// score 1 if count <> 31
// score 1 regardless
// score 1 if count <> 31 score 2 if count = 31, etc.
//---------------------------------------------------------
exsr srChkAllPlayd;
2b if IsUserOut
and IsCraigOut;
HandScore = 1;
ind.PlayMsg = *on;
PlayMsg = %trimr(WhoPlayed) +
' scored Last Card for 1. Press Enter';
exsr srMoveBarGraph;
exfmt screen;
3b if InfdsFkey = f03 or InfdsFkey = f12;
exsr srExitPgm;
3e endif;
// If all cards played, pop up score window for each hand
exsr srShowCrib;
exsr srScoreWindow;
exsr srNextHand;
exsr srUserDealt;
2e endif;
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 (yeah, just maybe possible)
//---------------------------------------------------------
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 for 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 now.
// 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.
// If a larger number run, supersedes any smaller run.
// ie 1234=1 run of 4 NOT 2 runs of three
// RunDeck. Use it to drop cards from.
//---------------------------------------------------------
TstDeck = SavDeck;
sorta TstCard;
RunDeck = TstDeck;
RemainingCnt = CardsToScore;
//---------------------------------------------------------
// run of 7 (yeah, 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;
T
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment