Last active
February 23, 2023 22:56
-
-
Save phpdave/c23ddf1426eb4f41b9b3999d783bc072 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| <?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; | |
| } |
This file has been truncated, but you can view the full file.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| <?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