ecki/IBM-i-RPG-Free-CLP-Code
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Source on IFS & Local Development

Browse Source
This commit is contained in:
SJLennon
2024-04-10 16:16:48 -04:00
parent 57c4efd0aa
commit a2d8f9c33c
83 changed files with 5807 additions and 4011 deletions
Download Patch File Download Diff File Expand all files Collapse all files
5250_Subfile/CRTDTAARA.clle
+9
View File
@@ -0,0 +1,9 @@
/* Convenience pgm that creates CUSTNEXT data area in *CUURLIB */
/* This is a really high number that I don't expect in test data */
/* Strictly it should be set to CUSTMAST COUNT(*) + 1 */
PGM
DLTDTAARA DTAARA(CUSTNEXT)
MONMSG MSGID(CPF0000)
CRTDTAARA DTAARA(CUSTNEXT) TYPE(*CHAR) LEN(4) +
VALUE('EEEE') TEXT('Next alpha-numeric customer number')
ENDPGM
5250_Subfile/CRTMSGF.CLLE
+7 -2
View File
@@ -1,8 +1,13 @@
PGM
DLTMSGF MSGF(LENNONS1/CUSTMSGF)
/* === Set your target library here ================ */
DCL VAR(&TGT_LIB) TYPE(*CHAR) LEN(10) +
VALUE('LENNONS1')
/* ================================================= */
DLTMSGF MSGF(&TGT_LIB/CUSTMSGF)
MONMSG MSGID(CPF0000)
CRTMSGF MSGF(LENNONS1/CUSTMSGF) TEXT('Customer +
CRTMSGF MSGF(&TGT_LIB/CUSTMSGF) TEXT('Customer +
Related Messages')
ADDMSGD MSGID(DEM0000) MSGF(CUSTMSGF) MSG('Press Enter to +
update. F12 to Cancel.')
5250_Subfile/Custmast.sql
+27 -13
View File
@@ -1,23 +1,29 @@
-- Create CUSTMAST & Indexs and load 300 records -----------
-- Program LOADCUST submits this to batch.
set schema lennons1;
-- 02/2024 Change CustID to char to allow alpha/numeric keys
set schema lennons1; -- <<<<< Change to your library <<<<<<
DROP TABLE custmast;
-- 02/2024 Change CUSTID to char to allow alpha-numeric key
CREATE TABLE custmast (
CustID numeric(4,0) not NULL,
Name char(40) not null,
Addr char(40) not NULL,
City char(20) not null,
State char(2) not NULL,
Zip char(10) not NULL,
CorpPhone char (20) default ' ',
AcctMgr char(40) default ' ',
AcctPhone char(20) default ' ',
Active char(1) default 'Y',
PRIMARY KEY (Custid)
CustID CHAR(4) NOT NULL
,Name CHAR(40) NOT NULL
,Addr CHAR(40) NOT NULL
,City CHAR(20) NOT NULL
,State CHAR(2) NOT NULL
,Zip CHAR(10) NOT NULL
,CorpPhone CHAR(20) DEFAULT ' '
,AcctMgr CHAR(40) DEFAULT ' '
,AcctPhone CHAR(20) DEFAULT ' '
,Active CHAR(1) DEFAULT 'Y'
,PRIMARY KEY (Custid)
)
RCDFMT CUSTMASTF;
-- Insert some data --
INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (1, 'Aliquet Nec Imperdiet Limited', 'Ap #766-3317 Penatibus St.', 'Des Moines', 'IA', '90911-1234', '(925)276-2778', 'Simon, Gannon D.', '(118)850-9146', 'N');
INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (2, 'Nam Porttitor LLP', '802-7392 Elit, Rd.', 'Rockville', 'MD', '60342-2222', '(734)960-9274', 'Kirk, Hamish U.', '(435)357-0265', 'N');
INSERT INTO custmast (CustID, Name, Addr, City, State, Zip, CorpPhone, AcctMgr, AcctPhone, Active) VALUES (3, 'Nibh Dolor Company', 'P.O. Box 103, 9218 Vivamus Avenue', 'Auburn', 'ME', '15762-0001', '(714)825-5082', 'Norman, Abbot R.', '(757)158-0941', 'Y');
@@ -330,3 +336,11 @@ ADD COLUMN ChgTime TIMESTAMP not null DEFAULT CURRENT_TIMESTAMP
ADD column ChgUser varchar(18) not null DEFAULT USER;
update custmast set chguser = '*SYSTEM*';
-- Indexes --
drop index if exists custmast_name;
create index custmast_name on custmast(name);
drop index if exists custmast_city;
create index custmast_city on custmast(city);
drop index if exists custmast_state;
create index custmast_state on custmast(state);
5250_Subfile/Custmast2.sql
+31
View File
@@ -0,0 +1,31 @@
-- Creates CUSTMAST and Indexes -------------------------------
-- Can then "CALL LOADCUST2 nnn" to load nnn random records.
-- 02/2024 Change CustID to char to allow alpha/numeric keys
set schema lennons1; -- <<<<< Change to your library <<<<<<
DROP TABLE custmast;
CREATE TABLE custmast (
CustID CHAR(4) NOT NULL
,Name CHAR(40) NOT NULL
,Addr CHAR(40) NOT NULL
,City CHAR(20) NOT NULL
,State CHAR(2) NOT NULL
,Zip CHAR(10) NOT NULL
,CorpPhone CHAR(20) DEFAULT ' '
,AcctMgr CHAR(40) DEFAULT ' '
,AcctPhone CHAR(20) DEFAULT ' '
,Active CHAR(1) DEFAULT 'Y'
,ChgTime TIMESTAMP not null DEFAULT CURRENT_TIMESTAMP
,ChgUser varchar(18) not null DEFAULT USER
,PRIMARY KEY (Custid)
)
RCDFMT CUSTMASTF;
-- Indexes --
drop index if exists custmast_name;
create index custmast_name on custmast(name);
drop index if exists custmast_city;
create index custmast_city on custmast(city);
drop index if exists custmast_state;
create index custmast_state on custmast(state);
5250_Subfile/LOADCUST.CLLE
+20
View File
@@ -0,0 +1,20 @@
/*=== Creates CUSTMAST & Indexes and 300 records ===*/
PGM
CHKOBJ OBJ(CUSTMAST) OBJTYPE(*FILE)
MONMSG MSGID(CPF9801) EXEC(GOTO CMDLBL(SUBMIT))
ALCOBJ OBJ((CUSTMAST *FILE *EXCLRD)) WAIT(5) +
CONFLICT(*RQSRLS)
MONMSG MSGID(CPF1002) EXEC(DO)
SNDMSG MSG('Cannot allocate CUSTMAST') +
TOUSR(*REQUESTER)
RETURN
ENDDO
DLCOBJ OBJ((CUSTMAST *FILE *EXCLRD))
SUBMIT: SBMJOB CMD(RUNSQLSTM +
SRCSTMF('/home/LENNONS/IBMi_IFS_DEV/5250_Subfile/+
custmast.sql') +
COMMIT(*NONE) ERRLVL(40) DECMPT(*PERIOD)) +
JOB(LOADCUST)
ENDPGM
5250_Subfile/LOADCUST2.CLLE
+19
View File
@@ -0,0 +1,19 @@
/* === Loads CUSTMAST with as many random records as specified === */
/* Submits job to batch */
PGM PARM(&NUM)
DCL VAR(&NUM) TYPE(*DEC) LEN(15 5)
CHKOBJ OBJ(CUSTMAST) OBJTYPE(*FILE)
MONMSG MSGID(CPF9801) EXEC(GOTO CMDLBL(SUBMIT))
ALCOBJ OBJ((CUSTMAST *FILE *EXCLRD)) WAIT(5) +
CONFLICT(*RQSRLS)
MONMSG MSGID(CPF1002) EXEC(DO)
SNDMSG MSG('Cannot allocate CUSTMAST') +
TOUSR(*REQUESTER)
RETURN
ENDDO
DLCOBJ OBJ((CUSTMAST *FILE *EXCLRD))
SUBMIT: SBMJOB CMD(CALL PGM(LOADCUSTR) PARM((&NUM))) JOB(LOADCUST2)
ENDPGM
5250_Subfile/LOADCUSTR.SQLRPGLE
+256
View File
@@ -0,0 +1,256 @@
**free
// === Program to create "n" records of test data in CUSTMAST =====
// === Assumes CUSTMAST is exists and will clear it first.
// === City name, state and zip are generated from USPS data,
// file CSZ, created from upload from USPS.COM with iACS.
// See https://www.unitedstateszipcodes.org/zip-code-database/
// Rest of the data i randomly generated.
// This was an experimental program to use randomn number and
// variable sized arrays. But it was fun to write...
ctl-opt DftActGrp(*no) ActGrp('QILE') BndDir('UTIL_BND':'SQL_BND':'SRV_BASE36');
ctl-opt Option(*nounref: *nodebugio: *srcstmt);
ctl-opt ExprOpts(*ResDecPos) ExtBinInt( *Yes );
ctl-opt Debug(*constants : *retval);
ctl-opt Indent('| ');
/COPY ../Copy_Mbrs/SRV_SQL_P.RPGLE
/COPY ../Copy_Mbrs/SRV_RAND_P.RPGLE
/COPY ../Copy_Mbrs/BASE36_P.RPGLE
// === Program Parameter =======================================
dcl-pi *n;
parm_recds packed(15 : 5); // Number of records to create
end-pi;
dcl-s p_recds int(10);
dcl-ds Fld ExtName('CUSTMAST') Qualified;
end-ds;
// === SQL State Constants =====================================
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
dcl-c SQLNOMOREDATA '02000';
dcl-c SQLNOTJOURNALED '01567';
dcl-s companyType varchar(10) dim(*auto : 30);
dcl-s streetType varchar(10) dim(*auto : 30);
dcl-s varCUSTID varchar(4);
// === City/state/zip record ===
dcl-ds csz qualified;
zip int(10);
ziptype char(10);
city char(20);
st char(2);
end-ds;
// === Arrary of City, State and Zip records ===
dcl-ds csz_a likeds(csz) dim(*auto : 50000) ;
dcl-s cszCount int(10);
dcl-s MaxL int(10);
dcl-s csz_I int(10);
dcl-s j int(10);
// dcl-s t int(10);
DCL-S adrX int(10);
dcl-s nRecds int(10);
dcl-s wk10 char(10);
dcl-s wkStr varchar(50);
// === Build array of Company types ===
companyType(1) = 'INC';
companyType(*next) = 'LLC';
companyType(*next) = 'LLP';
companyType(*next) = 'COMPANY';
companyType(*next) = '& SONS';
companyType(*next) = 'ET FILS';
companyType(*next) = 'PLC';
companyType(*next) = 'CORP';
companyType(*next) = 'LTD';
companyType(*next) = 'SOLE';
companyType(*next) = 'PARTNERS';
companyType(*next) = 'ASSOC';
// === Build array of street types ===
streetType(1) = 'STREET';
streetType(*next) = 'ST';
streetType(*next) = 'ROAD';
streetType(*next) = 'RD';
streetType(*next) = 'AVENUE';
streetType(*next) = 'AVE';
streetType(*next) = 'PLACE';
streetType(*next) = 'CIRCLE';
streetType(*next) = 'SQUARE';
streetType(*next) = 'HWY';
streetType(*next) = 'VISTA';
streetType(*next) = 'CALLE';
streetType(*next) = 'RANCH';
streetType(*next) = 'CRESCENT';
streetType(*next) = 'COURT';
streetType(*next) = 'WAY';
exec sql set option datfmt=*iso,
commit=*none,
closqlcsr=*endmod;
// === Clear Custmast file ===
exec sql truncate lennons1.custmast;
if (SQLSTT <> SQLSUCCESS and SQLSTT <> SQLNODATA);
SQLProblem('truncate custmast');
endif;
// === Size the City/State/Zip array ===
exec sql select count(*) into :cszCount
from lennons1.csz
where length(trim(city)) <= 20;
if (SQLSTT <> SQLSUCCESS);
SQLProblem('select count(*)');
endif;
%elem(csz_a : *alloc) = cszCount + 1;
// === Populate csz_a ===
exec sql declare csz_cur cursor for
select zip, type, upper(city), trim(state)
from lennons1.csz
where length(trim(city)) <= 20;
exec sql open csz_cur;
if (SQLSTT <> SQLSUCCESS );
SQLProblem('Open csz_cur');
endif;
j=1;
dow (1=1);
exec sql fetch from csz_cur into :csz;
if SQLSTT = SQLNOMOREDATA;
leave;
endif;
if SQLSTT <> SQLSUCCESS;
SQLProblem('fetch fron csz_cur');
endif;
csz_a(j) = csz;
j += 1;
enddo;
// === Build CUSTMAST records =================================
p_recds = parm_recds;
varCUSTID = '1001';
for nRecds = 1 to p_recds;
clear Fld;
Fld.CUSTID = varCUSTID;
varCUSTID = BASE36ADD(varCUSTID); // Alpha-numeric key
Fld.ACTIVE = 'Y';
if (%rem(nRecds : 7) = 0);
Fld.ACTIVE = 'N';
endif;
// === City/State Zip ===
csz_I = Rand_Int(1:%elem(csz_a));
Fld.STATE = csz_a(csz_I).st;
Fld.CITY = csz_a(csz_I).city;
wk10 = %editc(csz_a(csz_I).zip:'X');
Fld.ZIP = %subst(wk10 :6 :5);
// === Company Name ===
clear wkStr;
// Specify a random name length leaving space for
// a company6y type suffix.
MaxL = Rand_Int(5 : %len(Fld.Name) - 12);
wkStr = wkStr + genWord(5:11) + ' ';
dow %len(wkStr) <= MaxL;
wkStr = wkStr + genWord(5:11) + ' ';
enddo;
// Add company "types" to some records
j = Rand_Int(1:(%elem(companyType) * 1.8));
if j <= %elem(companyType);
wkStr = %trim(wkStr) + ' ' + companyType(j);
endif;
Fld.NAME = wkStr;
// === Address ===
clear wkStr;
adrX = %rem(nRecds :4);
MaxL = Rand_Int(5 : %len(Fld.ADDR) - 12);
if adrX <> 0; //Add street number to most
wkStr = %trim(%editc(Rand_Int(1:5000) : '3')) + ' ';
endif;
wkStr = wkStr + genWord(5:11) + ' ';
dow %len(wkStr) <= MaxL;
wkStr = wkStr + genWord(5:11) + ' ';
enddo;
// Add street "types" to some records
j = Rand_Int(1:(%elem(streetType) * 1.75));
if j <= %elem(streetType);
wkStr = %trim(wkStr) + ' ' + streetType(j);
endif;
Fld.ADDR = wkStr;
// === Phone numbers ===
Fld.CORPPHONE = genPhone();
Fld.ACCTPHONE = genPhone();
// === Account Manager ===
if %rem(nRecds :3) = 0;
wkStr = genWord(1:1) + ' ';
wkStr += genWord(1:1) + ' ';
wkStr += genWord(4:10);
else;
wkStr = genWord(3:6) + ' ';
wkStr += genWord(5:9);
endif;
Fld.ACCTMGR = wkStr;
Fld.CHGUSER = '*SYSTEM*';
// === Write out a record ======================================
exec sql insert into lennons1.custmast values(:Fld);
if (SQLSTT <> SQLSUCCESS);
SQLProblem('Insert into custmast');
endif;
endfor;
// === All finished ============================================
*inlr = *on;
return;
// === Generate a word =========================================
dcl-proc genWord;
dcl-pi genWord varchar(30);
MinL int(10) const;
MaxL int(10) const;
end-pi;
// Straight alphabetic
dcl-s Alpha varchar(50)
inz('ABCDEFGHIIJKLMNOPQRSTUVWXYZZ');
// Biased towards vowels
dcl-s vAlpha varchar(50)
inz('AAAAABCDEEEEEFGHIIIIIJKLMNOOOOOPQRSTUUUVWXYZZ');
dcl-s wk30 varchar(30) inz;
dcl-s TgtL int(10);
dcl-s j int(10);
wk30 = %subst(Alpha : Rand_Int(1 : %len(Alpha)) : 1);
if (MinL<> 1 and MaxL <> 1);
wk30 += %subst(vAlpha : Rand_Int(1 : %len(vAlpha)) : 1);
endif;
TgtL = Rand_Int(MinL:MaxL) - 2;
for j=1 by 2 to TgtL;
wk30 += %subst(Alpha : Rand_Int(1 : %len(Alpha)) : 1);
wk30 += %subst(vAlpha : Rand_Int(1 : %len(vAlpha)) : 1);
endfor;
return wk30;
end-proc;
// === Generate a phone like (800) 231-1876 ====================
dcl-proc genPhone;
dcl-pi genPhone varchar(20);
end-pi;
dcl-s wkret varchar(20);
dcl-s wk3 char(3);
dcl-s wk4 char(4);
wk3 = %editc(%dec(Rand_Int(100:900):3 :0) : 'X');
wkret = '(' + wk3 + ') ';
wk3 = %editc(%dec(Rand_Int(1:998) :3 :0) : 'X');
wkret += wk3 + '-';
wk4 = (%editc(%dec(Rand_Int(1:9900) :4 :0) : 'X'));
wkret += wk4;
return wkret;
end-proc;
5250_Subfile/MTNCUSTD.DSPF
+193
View File
@@ -0,0 +1,193 @@
A*===============================================================
A* Window to display or update Customer Master
A*===============================================================
A* CRTDSPF FILE(MTNCUSTD) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Details Fields begin with SD_
A* -- Screen footer: Fields begin with SFT_
A*===============================================================
A* Indicator usage:
A* 01-20 Are not routinely cleared after an EXFMT. Some
A* of these are used in subfile & subfile control for
A* highlighting, etc., which does not change unless
A* explicitly requested.
A* 21-99 Are routinely cleared after an EXFMT.
A* 80-89 Subfile record
A* 90 Nessage Subfile end
A* 91-99 Subfile Control Record
A* Note: INDARA is specified here and in the program and this
A* means that the display file indicators are in a
A* means that the display file indicators are in a
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
a* Note: DSPATR HI and RI at the same time = non-display. Thus
a* when we turn on RI were turn of HI,
A*===============================================================
A*%%EC
A DSPSIZ(24 80 *DS3)
A PRINT
A INDARA
A ALTHELP
A CF04
A CA05
A CA12
A HELP
A*===============================================================
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A OVERLAY
A TEXT('Screen Header')
A WDWBORDER((*COLOR PNK))
A WINDOW(*DFT 17 54)
A SH_PGM 10A O 1 1
A 1 21'Customer Master'
A 1 47DATE
A EDTCDE(Y)
A 2 1USER
A SH_FUNCT 25A O 2 16DSPATR(HI)
A 2 47TIME
A*===============================================================
A*=== Data Details - Fields begin with SD_ ======================
A R DETAILS
A OVERLAY
A WINDOW(SH_HDR)
A CHGINPDFT
A RTNCSRLOC(&SD_PMT_RCD &SD_PMT_FLD)
A*---------------------------------------------------------------
A 5 1'Customer Id'
A SD_CUSTID 4 5 14DSPATR(HI)
A 5 20'Active Status'
A SD_ACTIVE 1 B 5 35
A N40 DSPATR(HI)
A 40 DSPATR(RI)
A 41 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 6 1'Name'
A SD_NAME 40 B 6 9
A N42 DSPATR(HI)
A 42 DSPATR(RI)
A 43 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 7 1'Address'
A SD_ADDR 40 B 7 9
A N44 DSPATR(HI)
A 44 DSPATR(RI)
A 45 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 8 1'City'
A SD_CITY 20 B 8 9
A N46 DSPATR(HI)
A 46 DSPATR(RI)
A 47 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 8 32'ST+'
A SD_STATE 2 B 8 36
A N48 DSPATR(HI)
A 48 DSPATR(RI)
A 49 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 8 39'ZIP'
A SD_ZIP 10 B 8 43
A N50 DSPATR(HI)
A 50 DSPATR(RI)
A 51 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 9 1'Account Manager'
A 10 5'Phone'
A SD_ACCTPH 20 B 10 15
A N52 DSPATR(HI)
A 52 DSPATR(RI)
A 53 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 11 5'Name'
A SD_ACCTMGR 40 B 11 15
A N54 DSPATR(HI)
A 54 DSPATR(RI)
A 55 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 12 1'Corporate Phone'
A SD_CORPPH 20 B 12 17
A N56 DSPATR(HI)
A 56 DSPATR(RI)
A 57 DSPATR(PC)
A 10 DSPATR(PR)
A N10 DSPATR(UL)
A 13 1'Last Change'
A N61 DSPATR(ND)
A SD_CHGTIME 23 13 13
A N61 DSPATR(ND)
A 13 37'by'
A N61 DSPATR(ND)
A SD_CHGUSER 15 13 40
A N61 DSPATR(ND)
A SD_PMT_RCD 10A H
A SD_PMT_FLD 10A H
A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A TEXT('Screen Footer')
A OVERLAY
A WINDOW(SH_HDR)
A 14 1' Demo Corp of America -
A '
A DSPATR(UL)
A SFT_KEYS 53A O 15 1COLOR(BLU)
A*===============================================================
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A TEXT('Message Subfile')
A SFLMSGRCD(16)
A MSGKEY SFLMSGKEY
A MSGPGMQ SFLPGMQ(10)
A*===============================================================
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A TEXT('Message Subfile Control')
A WINDOW(SH_HDR)
A PAGEDOWN
A PAGEUP
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N90 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A MSGPGMQ SFLPGMQ(10)
A*===============================================================
A*=== Dummy Record - Assume =====================================
A*
A R DUMMY
A ASSUME
A KEEP
A 1 2'*'
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="SCREEN1">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ <record-write record-format="SH_HDR" />
A*%%RS+ <record-write record-format="DETAILS" />
A*%%RS+ <record-write record-format="SFT_FKEY" />
A*%%RS+ <record-write record-format="MSGSFL" />
A*%%RS+ <record-write record-format="MSGCTL" />
A*%%RS+ <record-write record-format="DUMMY" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="Untitled">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
5250_Subfile/MTNCUSTR.SQLRPGLE
+277 -361
View File
File diff suppressed because it is too large Load Diff
5250_Subfile/PMTCUSTD.DSPF
+171
View File
@@ -0,0 +1,171 @@
A*===============================================================
A* This is a full screen expanding subfile to search for
A* a customer.
A* - There are filters limit selection.
A* - A message subfile is included.
A*===============================================================
A* CRTDSPF FILE(PMTCUSTD) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_
A* -- Subfile Control: Fields begin with SC_
A* -- Screen footer: Fields begin with SFT_
A*===============================================================
A* Indicator usage:
A* 01-20 Are not routinely cleared after an EXFMT. Some
A* of these are used in subfile & subfile control for
A* highlighting, etc., which does not change unless
A* explicitly requested.
A* 21-99 Are routinely cleared after an EXFMT.
a* 79 SC_NAME Position Cursor
A* 80-89 Subfile record
A* 90 Nessage Subfile end
A* 91-99 Subfile Control Record
A* Note: INDARA is specified here and in the program and this
A* means that the display file indicators are in a
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
A*==============================================================
A DSPSIZ(24 80 *DS3)
A PRINT
A INDARA
A ALTHELP
A CA03
A CF04
A CA05
A CA06
A CA09
A CA42
A HELP
A*===============================================================
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A OVERLAY
A TEXT('Screen Header')
A SH_PGM 10A O 1 2
A 1 33'Customer Master'
A 1 72DATE
A EDTCDE(Y)
A SH_FUNCT 50A O 2 16DSPATR(HI)
A 2 72TIME
A 2 2USER
A*===============================================================
A*=== Subfile: Fields begin with SF_ ===========================
A*
A R SFL SFL
A TEXT('SubFile')
A 80 SFLNXTCHG
A SF_ACT_H 1D H
A SF_CUST_H 4D H
A SF_OPT 1A B 9 3
A 81 DSPATR(RI)
A 82 DSPATR(PC)
A SF_NAME 40A O 9 6
A 83 COLOR(RED)
A SF_CITY 20A O 9 47
A 83 COLOR(RED)
A SF_STATE 2A O 9 69
A 83 COLOR(RED)
A SF_ZIP 5A O 9 74
A 83 COLOR(RED)
A*===============================================================
A*=== Subfile Control: Fields begin with SC_ ====================
A*
A R SFLCTL SFLCTL(SFL)
A SFLSIZ(0013)
A SFLPAG(0012)
A TEXT('Subfile Control')
A PAGEDOWN
A RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
A BLINK
A OVERLAY
A N98 ERASE(SFL)
A 98 SFLDSP
A SFLDSPCTL
A 99 SFLCLR
A 97 SFLEND(*MORE)
A 4 2'Name starts with:'
A 4 31'City Starts with:'
A 4 60'State+'
A 4 71'Including'
A COLOR(RED)
A N03 DSPATR(ND)
A SC_NAME 13A B 5 6
A 79 DSPATR(PC)
A SC_CITY 13A B 5 35
A SC_STATE 2A B 5 62
A 5 71'Inctives'
A COLOR(RED)
A N03 DSPATR(ND)
A 6 2'Type options, press Enter.'
A COLOR(BLU)
A SC_OPTIONS 69A 7 2COLOR(BLU)
A 8 2'Opt'
A DSPATR(HI)
A 8 6'Customer Name'
A DSPATR(UL)
A COLOR(WHT)
A 8 47'City '
A DSPATR(UL)
A COLOR(WHT)
A 8 69'St'
A DSPATR(UL)
A COLOR(WHT)
A 8 74'ZIP '
A COLOR(WHT)
A DSPATR(UL)
A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A TEXT('Screen Footer')
A OVERLAY
A 22 2' Demo Cor-
A p of America -
A '
A DSPATR(UL)
A SFT_KEYS 78A O 23 2COLOR(BLU)
A*===============================================================
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A TEXT('Message Subfile')
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A MSGPGMQ SFLPGMQ(10)
A*===============================================================
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A TEXT('Message Subfile Control')
A PAGEDOWN
A PAGEUP
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N90 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A MSGPGMQ SFLPGMQ(10)
A*===============================================================
A*=== Dummy Record ==============================================
A*
A R DUMMY
A 24 79'*'
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="TOP">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ <record-write record-format="SH_HDR" />
A*%%RS+ <record-write record-format="SFT_FKEY" />
A*%%RS+ <record-write record-format="SFL" />
A*%%RS+ <record-write record-format="SFLCTL" />
A*%%RS+ <record-write record-format="MSGSFL" />
A*%%RS+ <record-write record-format="MSGCTL" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
5250_Subfile/PMTCUSTR.SQLRPGLE
+333 -388
View File
File diff suppressed because it is too large Load Diff
5250_Subfile/PMTSTATED.DSPF
+170
View File
@@ -0,0 +1,170 @@
A*===============================================================
A* This is a "load all" subfile in a windown to select a
A* state code.
A*===============================================================
A* CRTDSPF FILE(PMTSTATED) SRCFILE(...) RSTDSP(*YES)
A*==============================================================
A* There is a naming convention for the fields in each record.
A* -- Screen Header: Fields begin with SH_
A* -- Subfile: Fields begin with SF_
A* -- Subfile Control: Fields begin with SC_
A* -- Screen footer: Fields begin with SFT_
A*===============================================================
A* Indicator usage:
A* 01-20 Are not routinely cleared after an EXFMT. Some
A* of these are used in subfile & subfile control for
A* highlighting, etc., which does not change unless
A* explicitly requested.
A* 21-99 Are routinely cleared after and EXFMT.
A* 80-89 Subfile record
A* 90 Nessage Subfile end
A* 91-99 Subfile Control Record
A* Note: INDARA is specified here and in the program and this
A* means that the display file indicators are in a
A* data structure separate from the program indicators.
A* This makes it easy to name the indicators in the DS.
A*==============================================================
A DSPSIZ(24 80 *DS3 -
A 27 132 *DS4)
A PRINT
A INDARA
A ALTHELP
A HELP
A*===============================================================
A*=== Screen Header: Fields begin with SH_ =====================
A*
A R SH_HDR
A OVERLAY
A TEXT('Screen Header')
A WINDOW(*DFT 16 40)
A WDWBORDER((*DSPATR RI) (*CHAR +
A ' '))
A WDWBORDER((*COLOR BLU))
A SH_PGM 10A O 1 1
A 1 16'USA States'
A COLOR(WHT)
A 1 33DATE
A EDTCDE(Y)
A SH_FUNCT 17A O 2 13DSPATR(HI)
A 2 33TIME
A 2 1USER
A*===============================================================
A*=== Subfile: Fields begin with SF_ ===========================
A*
A R SFL SFL
A TEXT('SubFile')
A 80 SFLNXTCHG
A SF_OPT 1A B 6 2
A 81 DSPATR(RI)
A 82 DSPATR(PC)
A SF_CODE 2A 6 6
A 22 COLOR(RED)
A SF_NAME 30A O 6 11
A 22 COLOR(RED)
A*===============================================================
A*=== Subfile Control: Fields begin with SC_ ====================
A*
A R SFLCTL SFLCTL(SFL)
A CF03
A CF05
A CF07
A CF12
A *DS3 SFLSIZ(9999)
A *DS4 SFLSIZ(9999)
A *DS3 SFLPAG(0006)
A *DS4 SFLPAG(0006)
A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR)
A TEXT('Subfile Control')
A RTNCSRLOC(&SC_PMT_RCD &SC_PMT_FLD)
A BLINK
A OVERLAY
A N98 ERASE(SFL)
A 98 SFLDSP
A SFLDSPCTL
A 99 SFLCLR
A 97 SFLEND(*MORE)
A 3 1'Name Contains'
A SC_NAME 10A B 3 16
A 95 DSPATR(MDT)
A SC_OPTIONS 20A 4 1COLOR(BLU)
A 4 26'Sorted by:'
A SC_SORTED 4 4 37
A 5 1'Opt'
A DSPATR(HI)
A DSPATR(UL)
A 5 5'Code'
A 01 COLOR(PNK)
A DSPATR(UL)
A 5 11'Name '
A DSPATR(UL)
A 02 COLOR(PNK)
A SC_PMT_RCD 10A H
A SC_PMT_FLD 10A H
A SC_CSR_RCD 4S 0H SFLRCDNBR(CURSOR)
A*===============================================================
A*=== Screen footer & function keys: Fields begin with SFT_ ====
A*
A R SFT_FKEY
A *DS3 WINDOW(SH_HDR)
A *DS4 WINDOW(SH_HDR)
A TEXT('Screen Footer')
A OVERLAY
A 13 1' Demo Corp of America -
A '
A DSPATR(UL)
A SFT_KEYS 40 O 14 1
A*===============================================================
A*=== Message Subfile: No fields ===============================
A*
A R MSGSFL SFL
A TEXT('Message Subfile')
A SFLMSGRCD(15)
A MSGKEY SFLMSGKEY
A MSGPGMQF SFLPGMQ(10)
A*===============================================================
A*=== Message Subfile Control: No fields ========================
A*
A R MSGCTL SFLCTL(MSGSFL)
A TEXT('Message Subfile Control')
A WINDOW(SH_HDR)
A PAGEDOWN
A PAGEUP
A OVERLAY
A SFLDSP
A SFLDSPCTL
A SFLINZ
A N90 SFLEND
A SFLSIZ(0002)
A SFLPAG(0001)
A MSGPGMQC SFLPGMQ(10)
A*===============================================================
A*=== Dummy Record - Assume =====================================
A*
A R DUMMY
A ASSUME
A 1 2' '
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="SCREEN1">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ <record-write record-format="SH_HDR" />
A*%%RS+ <record-write record-format="SFL" />
A*%%RS+ <record-write record-format="SFLCTL" />
A*%%RS+ <record-write record-format="SFT_FKEY" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="Untitled">
A*%%RS+ <device type="display" width="132" height="27" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="Untitled">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
A*%%RS+<record-sequences>
A*%%RS+ <sequence name="Untitled">
A*%%RS+ <device type="display" width="80" height="24" />
A*%%RS+ </sequence>
A*%%RS </record-sequences>
5250_Subfile/PMTSTATER.SQLRPGLE
+190 -295
View File
@@ -1,3 +1,4 @@
**free
/TITLE PMTSTATE Search and return a USA State Code
//==============================================================*
// This is a "load all" subfile, where the system takes care or
@@ -38,138 +39,108 @@
//===============================================================
// Compilation
// Use CRTSQLRPGI command.
// Note that /INCLUDEs expects to find code in DEMO library,
// Note that /INCLUDEs expects to find code in Copy_Mbrs file,
// not the default of QRPGLESRC. Change as needed.
//=============================================================
// 12/2023 Converted to totally **FREE
// Use SQLPROBLEM service program
//=============================================================
ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
bnddir('UTIL_BND': 'SQL_BND');
h DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
h BndDir('UTIL_BND')
h main(Main)
// === Program parameters =======================================
dcl-pi *n;
pState like(FetchData.state);
end-pi;
//=== Display File ==============================================
fPMTSTATED CF E WorkStn INFDS(dfInfDS)
f INDDS(dfIndDS)
f SFILE(SFL:SflRRN)
f USROPN
d Main pr extpgm('PMTSTATER')
d ReturnState 2A
dcl-f PMTSTATED workstn infds(dfInfDS) indds(dfIndDS) sfile(SFL:SflRRN)
usropn;
//=== Service Program Prototypes ================================
/include copy_mbrs,Srv_Msg_P
/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
/INCLUDE ../Copy_Mbrs/SRV_SQL_P.RPGLE
//=== Named hexadecimal constants for function keys =============
/include copy_mbrs,##AIDBYTES
/INCLUDE ../Copy_Mbrs/AIDBYTES.RPGLE
//=== Fields read by SQL ========================================
// NOTE: Only the fields in fetchData which are fetched by the
// SQL Cursor are populated.
d STATES e ds extname(STATES)
d qualified template
d FetchData ds likeds(STATES)
dcl-ds STATESds extname('STATES') qualified template end-ds;
dcl-ds FetchData likeds(STATESds);
//=== SQL State Constants =======================================
d SQLSuccess c '00000'
d SQLNoData c '02000'
d SQLNoMoreData c '02000'
d SQLDupRecd c '23505'
d SQLRowLocked c '57033'
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
dcl-c SQLNOMOREDATA '02000';
dcl-c SQLDUPRECD '23505';
dcl-c SQLROWLOCKED '57033';
//=== Display File Information Data Structure ===================
// Allows us to determine which function key was pressed
d dfInfDS DS
d Key 369 369
dcl-ds dfInfDS;
Key char(1) pos(369);
end-ds;
//=== Display File Indicator Data Structure =====================
// This is a "private" indicator area for the display file.
d dfIndDS ds 99
//--- 01-20 are not automatically cleared after EXFMT ----------
d scCodeHi 01 01
d scNameHi 02 02
dcl-ds dfIndDS len(99);
scCodeHi char(1) pos(1);
//--- 21-99 automatically cleared after EXFMT ------------------
d dfIndClr 21 99
scNameHi char(1) pos(2);
//--- Subfile indicators (prefix "sf") -------------------------
d sfSflNxtChg 80 80n
d sfOPT_RI 81 81n
d sfOPT_PC 82 82n
dfIndClr char(79) pos(21);
sfSflNxtChg ind pos(80);
sfOPT_RI ind pos(81);
//--- Subfile Control indicators (prefix "sc") ----------------
d scMDT 95 95n
d scNoDta 96 96n
d scSflEnd 97 97n
d scSflDsp 98 98n
d scSflClr 99 99n
sfOPT_PC ind pos(82);
scMDT ind pos(95);
scNoDta ind pos(96);
scSflEnd ind pos(97);
scSflDsp ind pos(98);
scSflClr ind pos(99);
end-ds;
//=== Fields to control the subfile screen ======================
d SflRRN s 5i 0
d RcdsInSfl s 5i 0
d SflPageSize c 6
d SflMaxRecd s 5i 0 inz(9999)
dcl-s SflRRN int(5);
dcl-s RcdsInSfl int(5);
dcl-c SFLPAGESIZE 6;
dcl-s SflMaxRecd int(5) inz(9999);
// SC_CSR_RCD is defined in the display file and is set with a
// RRN which determines which subfile page is displayed and on
// which record the cursor is positioned.
//=== Program Status Data Structure =============================
d ProgStatus sds
d PgmName *PROC
d MainProc S 10a
dcl-ds ProgStatus PSDS;
PgmName *PROC;
end-ds;
dcl-s MainProc char(10);
//=== Text for function keys ====================================
d F3Text c 'F3=Exit'
d F5Text c 'F5=Refresh'
d F12Text c 'F12=Cancel'
d F7Text1 c 'F7=By '
d F7Text2 s 5a inz(' ')
d F7Text S 11a inz(' ')
dcl-c F3TEXT 'F3=Exit';
dcl-c F5TEXT 'F5=Refresh';
dcl-c F12TEXT 'F12=Cancel';
dcl-c F7TEXT1 'F7=By ';
dcl-s F7Text2 char(5) inz(' ');
dcl-s F7Text char(11) inz(' ');
//SortSeq is used in SQL Order By in a CASE construct.
d SQLSortSeq s 4a inz(' ')
d SortbyName s 4a inz('Name')
d SortbyCode s 4a inz('Code')
dcl-s SQLSortSeq char(4) inz(' ');
dcl-s SortbyName char(4) inz('Name');
dcl-s SortbyCode char(4) inz('Code');
//=== Options Text ==============================================
d Opt1Text c '1=Select'
dcl-c OPT1TEXT '1=Select';
//=== Search Criteria Screen Fields =============================
d SearchCriteria ds inz
d SC_NAME
dcl-ds SearchCriteria inz;
SC_NAME;
end-ds;
//=== Last Search Criteria Fields ===============================
d LastSearchCriteria...
d ds inz
d LastSC_NAME Like(SC_NAME)
dcl-ds LastSearchCriteria inz;
LastSC_NAME like(sc_name);
end-ds;
//=== SQL Search Variables ======================================
d DESCLike S 12 varying
dcl-s DESCLike varchar(12);
//=== Global Switches ===========================================
d EofData s n
d CursorOpen s n
d NewSearchCriteria...
d s n
d SflMsgSnt s n
d Opt1OK s n
d OptError s n
d CowsComeHome c const('0')
dcl-s EofData ind;
dcl-s CursorOpen ind;
dcl-s NewSearchCriteria ind;
dcl-s SflMsgSnt ind;
dcl-s Opt1OK ind;
dcl-s OptError ind;
//=== Work Fields ===============================================
d inx s 10i 0
//=============================================================
//== Program Starts Here ======================================
//=============================================================
p Main b
d Main pi
d pState Like(FetchData.STATE)
/FREE
exsr Init;
exsr BldFkeyText;
dcl-s inx int(10);
//=== Set SQL Options =========================================
exec sql set option datfmt=*iso,
closqlcsr=*endmod;
@@ -182,38 +153,45 @@
STATE,
NAME
from STATES
where upper(NAME) like :DescLike
where upper(NAME) like :DESCLike
order by case :SQLSortSeq
when :SortByName then NAME
when :SortByCode then STATE
when :SortbyName then NAME
when :SortbyCode then STATE
else '1'
end
for fetch only;
//=============================================================
//== Program Starts Here ======================================
//=============================================================
//--- Analyse parameters ---
Opt1OK = *off;
if %parms() > 0;
Opt1OK = *on;
endif;
Init();
BldFkeyText();
// === Initial screen display =================================
write SH_HDR;
SflClear();
exsr ProcessSearchCriteria;
exsr SflLoadAll;
ProcessSearchCriteria();
SflLoadAll();
//=============================================================
// === Main Program Loop ======================================
//=============================================================
dou CowsComeHome;
dow *INLR = *OFF;
// To exit this program, some procedures tuen on *INLR
// Put the last search criteria back on the screen.
SearchCriteria = LastSearchCriteria;
// Set "*More" display
scSflEnd = EofData;
// If switching display order, reload first page
if Key = F07;
exsr ProcessSearchCriteria;
exsr SflLoadAll;
ProcessSearchCriteria();
SflLoadAll();
endif;
// Write/Read the screen
exsr ScreenIO;
ScreenIO();
//-- Enter Key --------------------------------------------
If Key = Enter;
// Either new Search Criteria entered or option(s) entered.
@@ -221,199 +199,159 @@
if SearchCriteria <> LastSearchCriteria
or NewSearchCriteria = *on;
SflClear();
exsr ProcessSearchCriteria;
exsr SflLoadAll;
ProcessSearchCriteria();
SflLoadAll();
else;
exsr ProcessOption;
ProcessOption();
endif;
iter;
endif;
//--- Any other entry must be a function key ---------------
exsr ProcessFunctionKey;
ProcessFunctionKey();
enddo;
return; // to Caller
//=============================================================
//=== End of Main Program Loop ================================
//=============================================================
//=== ScreenIO ================================================
// Writes and Reads the screen
begsr ScreenIO;
Dcl-Proc ScreenIO;
write SH_HDR;
write SFT_FKEY;
// Show any messages in the error subfile.
if SflMsgSnt = *on;
write MSGCTL;
endif;
// If we have records in the subfile, display them.
if RcdsInSfl > 0;
scSflDsp = *ON;
else;
scSflDsp = *OFF;
ENDIF;
// Write/read the subfile. SC_CSR_RCD contains a RRN and
// determines which page will be on the screen and where the
// cursor will be.
exfmt SFLCTL;
// Clear most display file indicators
clear dfIndClr;
// Clear any messages in the error subfile.
if SflMsgSnt = *on;
SflMsgSnt = ClrMsgPgmQ(MainProc);
write MSGCTL;
endif;
endsr;
End-Proc;
//=== ProcessFunctionKey ======================================
// Process whatever keyboard entry was made.
// Will not return from subroutine if F3 or F12 was pressed.
// May not return from subroutine when an option is entered.
begsr ProcessFunctionKey;
Dcl-Proc ProcessFunctionKey;
select;
//--- F3: Exit, close down program -----------------------
when Key = F03;
exsr CloseDownPgm;
//--- F3 or F12: Exit, close down program -----------------------
when (Key = F03 or Key = F12);
CloseDownPgm();
*inlr = *on;
return;
//--- F12: Return to caller, leave program active ---------
when Key = F12;
exsr CloseDownPgm;
return;
//--- F5: Refresh all search fields ----------------------
when Key = F05;
clear LastSearchCriteria;
NewSearchCriteria = *on;
SflClear();
//--- F7: Toggle Sort Sequence ---------------------------
when Key = F07;
if SQLSortSeq=SortByName;
SQLSortSeq = SortByCode;
SC_SORTED = SortByCode;
if SQLSortSeq=SortbyName;
SQLSortSeq = SortbyCode;
SC_SORTED = SortbyCode;
scCodeHi = *on;
scNameHi = *off;
F7Text2 = SortByName;
F7Text2 = SortbyName;
else;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
SQLSortSeq = SortbyName;
SC_SORTED = SortbyName;
scNameHi = *on;
scCodeHI = *off;
F7Text2 = SortbyCode;
endif;
F7Text = F7Text1 + F7Text2;
exsr BldFkeyText;
F7Text = F7TEXT1 + F7Text2;
BldFkeyText();
NewSearchCriteria = *on;
SflClear();
//--- Other keys: Function key not active message ---------
other;
SflMsgSnt= SndSflMsg('DEM0003');
endsl;
endsr;
End-Proc;
//=== ProcessOption ===========================================
// Did user enter an option? If so, process it.
// May not return from this subroutine.
begsr ProcessOption;
Dcl-Proc ProcessOption;
if RcdsInSfl > 0;
OptError = *off;
// Don't know yet which page to display next time.
SC_CSR_RCD = 0;
// Loop through changed records in the subfile.
readc SFL;
dow not %eof;
select;
//--- 1 = Select ------------------------------------------
when SF_OPT = '1' and Opt1OK;
// Return Code to caller
pSTATE = SF_CODE;
exsr CloseDownPgm;
pState = SF_CODE;
CloseDownPgm();
*inlr = *on;
return;
//--- Opt is blank ----------------------------------------
when SF_OPT = ' ';
// If changed, assume clearing an error from last time
sfOPT_PC = *off;
sfOPT_RI = *off;
update SFL;
//--- Other -----------------------------------------------
other;
// Send message about invalid selection.
// Position cursor and page at first error.
// Always force to be read again next time & reverse image.
// Not a valid option at this time
SflMsgSnt= SndSflMsg('DEM0004':SF_OPT);
// Leave cursor at first invalid option
exsr SetScreenCursorPosition;
optError = *on;
SetScreenCursorPosition();
OptError = *on;
// SFLNXTCHG forces this record to be read again
// even if user doesn't correct it, so we can
// check it again for validity.
sfSflNxtChg = *on;
sfOPT_RI = *on;
update SFL;
// set off indicators applying to just this recd.
sfSflNxtChg = *off;
sfOPT_RI = *off;
endsl;
readc SFL;
enddo;
endif;
// If no positioning done, display last page, cursor on 1st recd.
// (Enter with no option takes you to the last page of subfile.)
if SC_CSR_RCD = 0;
SC_CSR_RCD =
( %int( (RcdsInSfl-1) / SflPageSize )
* SflPageSize
( %int( (RcdsInSfl-1) / SFLPAGESIZE )
* SFLPAGESIZE
) + 1;
endif;
endsr;
End-Proc;
//=== SflLoadAll ==============================================
// Loads all selected records to the subfile.
// Returns:
// EofData = *on (there are no more data records.)
// RcdsInSfl contains relative record number of last record
// written to the subfile.
// SC_CSR_RCD contains relative record number of 1st record
// on the page & positions cursor there.
begsr SflLoadAll;
Dcl-Proc SflLoadAll;
// Position cursor at first record on the subfile page.
SC_CSR_RCD = 1;
for inx = 1 to SflMaxRecd;
EofData = FetchNextData();
if EofData = *on;
@@ -423,21 +361,17 @@
clear SF_OPT;
SF_CODE = FetchData.STATE;
SF_NAME = FetchData.NAME;
SflRRN = inx;
RcdsinSfl = RcdsInSfl + 1;
RcdsInSfl = RcdsInSfl + 1;
write SFL;
// Can't display more than 9,9999 records.
if SflRRN = SflMaxRecd;
EofData = *on;
SflMsgSnt= SndSflMsg('DEM0006');
leave;
endif;
endfor;
endsr;
End-Proc;
//=== ProcessSearchCriteria====================================
// Examines the data entered in the search fields and sets up
@@ -451,14 +385,12 @@
// NewSearchCriteria is left on
// Error message is sent to the msg sufile
// Cursor is postioned at the field in error
begsr ProcessSearchCriteria;
Dcl-Proc ProcessSearchCriteria;
// Reset switches
NewSearchCriteria = *off;
// Save entered values. (Never change screen fields.)
LastSearchCriteria = SearchCriteria;
CloseCursor();
//---------------------------------------------------------------
if SC_NAME = ' ';
// Not searching, take all
@@ -467,125 +399,104 @@
DESCLike = '%' + %trim(SC_NAME) + '%';
endif;
//---------------------------------------------------------------
// If no errors in search criteria, open the SQL cursor
if NewSearchCriteria = *off;
exec sql open DataCur;
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
SQLProblem('Open DataCur');
endif;
CursorOpen = *on;
endif;
End-Proc;
endsr;
//=== SetCursorPostion ========================================
//=== SetScreenCursorPostion ===================================
// If Invalid Option, position screen cursor on first one,
// else postion cursor on the last valid option.
begsr SetScreenCursorPosition;
Dcl-Proc SetScreenCursorPosition;
if OptError = *off;
SC_CSR_RCD=SflRRN;
endif;
endsr;
End-Proc;
//=== BldFKeyText =============================================
// Build the Function key text for the bottom of the screen.
begsr BldFkeyText;
Dcl-Proc BldFkeyText;
SFT_KEYS=' ';
SFT_KEYS = CatB(SFT_KEYS : F3Text);
SFT_KEYS = CatB(SFT_KEYS : F5Text);
SFT_KEYS = CatB(SFT_KEYS : F3TEXT);
SFT_KEYS = CatB(SFT_KEYS : F5TEXT);
SFT_KEYS = CatB(SFT_KEYS : F7Text);
SFT_KEYS = CatB(SFT_KEYS : F12Text);
endsr;
SFT_KEYS = CatB(SFT_KEYS : F12TEXT);
End-Proc;
//=== CloseDownPgm ============================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
Dcl-Proc CloseDownPgm;
CloseCursor();
if %open(PMTSTATED);
close PMTSTATED;
endif;
endsr;
End-Proc;
//=== Init ====================================================
// Must be executed each time program is entered
begsr Init;
SQLSortSeq = SortByName;
SC_SORTED = SortByName;
Dcl-Proc Init;
SQLSortSeq = SortbyName;
SC_SORTED = SortbyName;
scNameHi = *on; // Name highlighted
scCodeHi = *off;
F7Text2 = SortByCode;
F7Text = F7Text1 + F7Text2;
//--- Analyse parameters ---
Opt1OK = *off;
if %parms() > 0;
Opt1OK = *on;
endif;
F7Text2 = SortbyCode;
F7Text = F7TEXT1 + F7Text2;
// Set up for subfile message queue
MainProc = %proc();
MainProc = PgmName;
MSGPGMQF = MainProc;
MSGPGMQC = MSGPGMQF;
SH_PGM = PgmName;
if not %open(PMTSTATED);
open PMTSTATED;
endif;
// Clear fields left over from previous F12.
reset LastSearchCriteria;
reset SearchCriteria;
// Build options string.
clear SC_OPTIONS;
if Opt1OK;
SC_OPTIONS = Opt1Text;
SC_OPTIONS = OPT1TEXT;
endif;
endsr;
p Main e
//=============================================================
// S u b P r o c e d u r e s
//=============================================================
End-Proc;
//=== CatB ====================================================
// Concatenates a string to another string with a blank between.
// If the target string is all blank to start with it will not
// end up with a leading blank.
/END-FREE
pCatB b
dCatB PI 79 varying
d ToStr 79 varying value
d AddStr 79 varying value
/FREE
dcl-proc CatB;
dcl-pi CatB varchar(79);
ToStr varchar(79) value;
AddStr varchar(79) value;
end-pi;
if ToStr=' ';
return AddStr;
else;
return %trimr(ToStr) + ' ' + AddStr;
endif;
/END-FREE
pCatB e
end-proc;
// === SQLProblem ================================================
// For those "Never should happen" SQL errors.
// Issues DUMP(A) to dump memory, then ends program by
// sending an *ESCAPE message of the supplied debugging text.
p SQLProblem B
d SQLProblem PI
d piSQLDebug 1024 varying value
//--- Local Variables ---------------------------------
d wkSQLDebug s 1024 varying
/free
wkSQLDebug = 'SQLSTT ' + SQLSTT
+ ' << Unexpected SQL Return Code: '
+ piSQLDebug;
dump(a);
SndEscMsg(wkSqlDebug);
return;
/end-free
p SQLProblem E
// dcl-proc SQLProblem;
// dcl-pi SQLProblem;
// piSQLDebug varchar(1024) value;
// end-pi;
// //--- Local Variables ---------------------------------
// dcl-s wkSQLDebug varchar(1024);
// wkSQLDebug = 'SQLSTT ' + SQLSTT
// + ' << Unexpected SQL Return Code: '
// + piSQLDebug;
// dump(a);
// SndEscMsg(wkSQLDebug);
// return;
// end-proc;
//--------------------------------------------------
// Procedure name: FetchNextData
@@ -594,30 +505,25 @@
// *ON No more data, nothing returned
// *OFF Data returned
//--------------------------------------------------
p FetchNextData B
d FetchNextData PI N
dcl-proc FetchNextData;
dcl-pi FetchNextData ind end-pi;
// Local fields
d wkEof S N
/FREE
wkEoF= *off;
dcl-s wkEof ind;
wkEof= *off;
exec sql fetch DataCur into
:FetchData.STATE,
:FetchData.NAME
;
select;
when SQLSTT = SQLSuccess;
when SQLSTT = SQLSUCCESS;
wkEof = *off;
when SQLSTT = SQLNoMoreData;
when SQLSTT = SQLNOMOREDATA;
wkEof = *on;
Other;
SQLProblem('Fetch DATACUR');
endsl;
RETURN wkEof;
/END-FREE
p FetchNextData E
end-proc;
//--------------------------------------------------
// Procedure name: SndSflMsg
@@ -628,21 +534,17 @@
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//--------------------------------------------------
p SndSflMsg B
d SndSflMsg PI N
d ErrMsgId 7A CONST
d ErrMsgData 80A CONST
d OPTIONS(*NOPASS:*VARSIZE)
d ErrMsgFile 10A CONST
d OPTIONS(*NOPASS)
dcl-proc SndSflMsg;
dcl-pi SndSflMsg ind;
ErrMsgId char(7) const;
ErrMsgData char(80) const options(*nopass:*varsize);
ErrMsgFile char(10) const options(*nopass);
end-pi;
// Local fields
d retField S N
d wkMsgId s 7a
d wkMsgFile s 10a
d wkMsgData s 80a varying
/FREE
dcl-s retField ind;
dcl-s wkMsgId char(7);
dcl-s wkMsgFile char(10);
dcl-s wkMsgData varchar(512);
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
@@ -654,48 +556,41 @@
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(MainProc:
wkMsgid:
SndMsgPgmQ(MainProc:
wkMsgId:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
p SndSflMsg E
end-proc;
//--------------------------------------------------
// Procedure name: CloseCurssor
// Purpose: Closes the SQL Cursor
//--------------------------------------------------
p CloseCursor B
d CloseCursor PI
/FREE
dcl-proc CloseCursor;
dcl-pi CloseCursor end-pi;
if CursorOpen = *on;
exec sql close DataCur;
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
SQLProblem('Close DATACUR');
endif;
CursorOpen = *off;
endif;
RETURN;
/END-FREE
p CloseCursor E
end-proc;
//--------------------------------------------------
// Procedure name: SflClear
// Purpose: Clears the Subfile
// Returns:
//--------------------------------------------------
p SflClear B
d SflClear PI
/FREE
dcl-proc SflClear;
dcl-pi SflClear end-pi;
clear SflRRN;
clear RcdsInSfl;
scSflClr = *ON;
write SFLCTL;
scSflClr = *OFF;
return;
/END-FREE
p SflClear E
end-proc;
5250_Subfile/README.md
+37 -5
View File
@@ -18,13 +18,11 @@ This is a working application that allows display, selection and maintenance of
## General Notes
Some of the programs use /Include statements, which are found in the Copy_Mbrs directory. So to compile you will need to create and populate a source file named COPY_MBRS.
Some of the programs use /Include statements, which are found in the Copy_Mbrs directory.
The RPG code is free form, except that the D-Specs are fixed form. This probably allows more developers who are still on older versions of the OS, or are still using the out of date SEU, to more easily use the code. The code can be converted to totally free format using the free _**"JCRHFD - Rpg H,F,D to free form syntax"**_ command available at [JCRCMDS.COM](http://www.jcrcmds.com/jcrdown2.html#JCRHFD_tag). If there is interest I may post totally free form versions.
The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2002-2004. The code was then cloned as a standard approach by another team leader. This code is a more modern version that I cleaned up in 2020 and restructured again in late 2023.
The genesis of these programs was code that I wrote in RPG IV for a Fortune 500 retailer circa 2002-2004. The code was then cloned as a standard approach by another team leader. This code is a more modern version that I cleaned up in 2020.
The style tries to have consistent naming and I do not share field names between the RPG and the display files--I've seen too many accidental modifications in my support career.
My style tries to have consistent naming and I do not share field names between the RPG and the display files--I've seen too many accidental modifications in my support career.
The display file uses a private set of indicators, something I started doing to try to educate coworkers who were struggling with monolithic code where all 99 indicators were in use. You can also reset indicators and such in display files, but I prefer to do it myself.
@@ -41,6 +39,8 @@ The display file uses a private set of indicators, something I started doing to
Conceptually, you can call this program from almost anywhere and control access to it by whatever menuing or security system you have in place. The general user population would progably get Inquiry and Sales would have Maintenance. Selection could be used for any in-house program that needed to prompt for a customer id number.
Note that this version uses a static SQL cursor, where City and State selection criteria use a "between" predicate. This differs from [the originally posted version](https://github.com/SJLennon/IBM-i-RPG-Free-CLP-Code/blob/master/5250_Subfile/PMTCUSTR.SQLRPGLE) which used a dynamic cursor which had to be prepared when the selection criteria changed. I think a static cursor makes coding easier and can improve performance since it doesn't need a "prepare". Conversely, on large files this approach may hurt performance. However, I tested the program on PUB400.COM with 1 million records and there was no discernable performance hit.
### MTNCUSTR/MTNCUSTD
RPG program that maintains a customer. Customer id is provided as the first parameter. It also adds or displays a customer. Function is controlled by the second parameter. It is called from PMTCUSTR, but it could be called from any program that has a customer id available, or which needs to add a customer.
@@ -74,3 +74,35 @@ The window has a blue border of reverse image blanks. This will display consiste
### States.SQL
SQL Code to create and populate the STATES table, which is a table of USA state names and their 2-character abbreviations.
### Creating a large CUSTMAST
I have provided a program that will create as large number of fairly realistic random CUSTMAST records. To get a decent distribution of City, State, ZIP values I used a USPS file which you will have to upload from the USPS site.
#### LOADCUSTR.SQLRPGLE
This clears CUSTMAST and repopulates it with an many randon records are you specify. It requires the CSZ file, below. Typical usage is `call loadcustr 1000` to load 1,000 records.
#### CSZ (City/State/ZIP) File
This file contains real data, over 40,000 records, dowloaded from the USPS website.
To create the CSZ file:
- Download the City, State and Zip database from USPS as an Excel spreadsheet. It is a free download at this [link](https://www.unitedstateszipcodes.org/zip-code-database/).
- Delete all columns except zip, type, primary city and state. Raname primary_city to city, save, but leave the spreadsheet open.
- Select all data in the speadsheet (this will fill in starting and ending colums and rows later).
- Using iACS "Data transfer to IBM i" upload the spreadsheet to file CSZ.
- In the Actions tab choose "Create IBM i Database file" and follow the prompts.
- In "Change Data Options" set defaults of VARCHAR and INTEGER.
- Keep following the prompts.
- Set Library/file to *yourlib*/CSZ.
Read this [IBM article](https://www.ibm.com/support/pages/transferring-data-excel-using-access-client-solutions) on uploading data from Excel using Access Client Solutions if you need more help.
5250_Subfile/States.sql
+5 -2
View File
@@ -1,6 +1,9 @@
-- Build table of US State code and names
-- RUNSQLSTM SRCSTMF(states.sql) COMMIT(*NONE) ERRLVL(40)
set schema lennons1;
-- To run from the green screen, adjust the path below:
-- RUNSQLSTM SRCSTMF('/home/LENNONS/IBMi_IFS_Dev/5250_Subfile/States.sql') COMMIT(*NONE) ERRLVL(40)
-- Our paste into Run SQL Scripts in iACS.
-- Or run directly in VS Code with Code for IBM i extension.
set schema lennonsb; -- Change to your desired library
drop table states;
CREATE TABLE STATES (
STATE CHAR(2) CCSID 273 NOT NULL ,
APIs/GETJOBTR.RPGLE
+2 -1
View File
@@ -20,11 +20,12 @@
// It was origially a standalone program. Perhaps it should
// be a service program and perhaps some of the diract API
// call should be in a service program.
// 02/--/2024 Set for soource in IFS
// -------------------------------------------------------------------
ctl-opt debug option(*nodebugio: *srcstmt)
dftactgrp(*no) actgrp(*caller)
main(Main);
/copy copy_mbrs,USPHDR
/copy ../Copy_Mbrs/USPHDR.RPGLE
//=== CRTUSRSPC (QUSCTRUS) Parameters ================================
dcl-s CusName char(20) inz('GETJOBTR QTEMP');
dcl-s CusAttr char(10) inz('GETJOBTR ');
APIs/GETOBJUC.CLLE
+3
View File
@@ -16,6 +16,8 @@ GETOBJUC: +
/* message fails. If this occurs, just continue and */
/* *LIBL may appear in the message. */
/* -----------------------------------------------------------------*/
/* 02/--/2024 CPF7306 to allow for SQL created GETOBJUP member */
/* -----------------------------------------------------------------*/
/* Input parameters */
DCL VAR(&OBJECT) TYPE(*CHAR) LEN(20) /* Obj & lib */
@@ -58,6 +60,7 @@ GETOBJUC: +
CRTDUPOBJ OBJ(GETOBJUP) FROMLIB(&FRMOBJLIB) OBJTYPE(*FILE) +
TOLIB(QTEMP)
ADDPFM FILE(QTEMP/GETOBJUP) MBR(GETOBJUP)
MONMSG MSGID(CPF7306)
OVRDBF FILE(GETOBJUP) TOFILE(QTEMP/GETOBJUP) SECURE(*YES)
ENDDO
APIs/GETOBJUP.SQL
+33
View File
@@ -0,0 +1,33 @@
-- Generate SQL
-- Version: V7R5M0 220415
-- Generated on: 02/13/24 22:08:51
-- Relational Database: PUB400
-- Standards Option: Db2 for i
CREATE or REPLACE TABLE LENNONS1.GETOBJUP (
-- SQL150B 10 REUSEDLT(*NO) in table GETOBJUP in LENNONS1 ignored.
-- SQL1505 20 Number of members for GETOBJUP in LENNONS1 not valid.
OUJOBNAME CHAR(10) CCSID 37 NOT NULL DEFAULT '' ,
OUJOBUSER CHAR(10) CCSID 37 NOT NULL DEFAULT '' ,
OUJOBNUM CHAR(6) CCSID 37 NOT NULL DEFAULT '' ,
OUJOBTYPE CHAR(1) CCSID 37 NOT NULL DEFAULT '' )
RCDFMT GETOBJU ;
LABEL ON TABLE LENNONS1.GETOBJUP
IS 'Users of an object' ;
LABEL ON COLUMN LENNONS1.GETOBJUP
( OUJOBNAME IS 'Job Name' ,
OUJOBUSER IS 'Job User' ,
OUJOBNUM IS 'Job Number' ,
OUJOBTYPE IS 'Type' ) ;
LABEL ON COLUMN LENNONS1.GETOBJUP
( OUJOBNAME TEXT IS 'Job Name' ,
OUJOBUSER TEXT IS 'Job User' ,
OUJOBNUM TEXT IS 'Job Number' ,
OUJOBTYPE TEXT IS 'I=interact, other=non inter' ) ;
GRANT ALTER , DELETE , INDEX , INSERT , REFERENCES , SELECT , UPDATE
ON LENNONS1.GETOBJUP TO LENNONS WITH GRANT OPTION ;
APIs/GETOBJUR.RPGLE
+20 -19
View File
@@ -24,12 +24,13 @@
// 1997. This code probably performs better than existing
// SQL interfaces. For most use cases performance may not
// be a consideration.
// 02/--/2024 Set for source in IFS
//--------------------------------------------------------------------
ctl-opt debug option(*nodebugio: *srcstmt)
dftactgrp(*no) actgrp(*caller)
main(Main);
dcl-f GETOBJUP usage(*output) usropn block(*yes);
/copy copy_mbrs,USPHDR
/copy ../Copy_Mbrs/USPHDR.RPGLE
//=== CRTUSRSPC (QUSCTRUS) Parameters ================================
dcl-ds *n;
CusQName char(20);
@@ -51,7 +52,7 @@ dcl-s MSNStackE char(10) inz('*CTLBDY');
dcl-s MSNStackC int(10) inz(1);
dcl-s MSNMsgKey char(4);
//=== List Object Locks List Entry Layout ============================
dcl-ds LOLEntry based(loptr);
dcl-ds LOLEntry based(LOPtr);
LOJobName char(10);
LOJobUser char(10);
LOJobNum char(6);
@@ -74,17 +75,17 @@ dcl-ds APIError len(272);
end-ds;
//=== Misc Field Definitions =========================================
dcl-s LolFmt char(8) inz('OBJL0100');
dcl-s ObjMEM char(10);
dcl-s ObjMem char(10);
dcl-s NumJobs packed(5);
dcl-c MaxJobs const(4); //Maximum jobs for detailed reporting.
// If you increase MaxJobs, increase the message parameter by 30 bytes
dcl-c MAXJOBS const(4); //Maximum jobs for detailed reporting.
// If you increase MAXJOBS, increase the message parameter by 30 bytes
// for each additional job.
dcl-ds JobName26;
SavJobName like(lojobname);
SavJobUser like(lojobuser);
SavJobNum like(lojobnum);
end-ds;
dcl-s Jobname28 char(28);
dcl-s JobName28 char(28);
dcl-s JobType char(1);
//=== Parameters for SRTUSRSPC =======================================
// SKeyStart - Array of key starting positions
@@ -193,7 +194,7 @@ dcl-proc Main ;
pObjType:
ObjMem:
APIError);
exsr srtusrspc;
exsr SrtUsrSpc;
// === Main Program Loop =========================================
// Loop through the entries in the list
exsr NxtJob;
@@ -213,11 +214,11 @@ dcl-proc Main ;
endif;
if pMsgYN='*YES';
select;
when NumJobs >= 1 and NumJobs <=MaxJobs;
pMsgfld=%trimr(pMsgFld) + '.';
when NumJobs > MaxJobs;
pMsgfld=%trimr(pMsgFld) + ' plus ' +
%trim(%editc(NumJobs-MaxJobs:'J')) +
when NumJobs >= 1 and NumJobs <=MAXJOBS;
pMsgFld=%trimr(pMsgFld) + '.';
when NumJobs > MAXJOBS;
pMsgFld=%trimr(pMsgFld) + ' plus ' +
%trim(%editc(NumJobs-MAXJOBS:'J')) +
' more.';
other;
endsl;
@@ -256,7 +257,7 @@ dcl-proc Main ;
endsr;
// === BldMsg ====================================================
// Adds current job to the message until MaxJobs have been added.
// Adds current job to the message until MAXJOBS have been added.
begsr BldMsg;
JobName28=%trimr(SavJobName) + '/' +
%trimr(SavJobUser) + '/' +
@@ -269,8 +270,8 @@ dcl-proc Main ;
%trimr(pObjType) +
' is in use by ' +
JobName28;
when NumJobs >= 2 and NumJobs <=MaxJobs;
pMsgFld=%trimr(pMsgfld) + ', ' +
when NumJobs >= 2 and NumJobs <=MAXJOBS;
pMsgFld=%trimr(pMsgFld) + ', ' +
JobName28;
endsl;
endsr;
@@ -298,10 +299,10 @@ dcl-proc Main ;
// === Sort User Space ===========================================
begsr SrtUsrSpc;
p_SRTUSRSPC(
p_srtusrspc(
CusName:
CusLib:
S#keys:
S#Keys:
SKeyStart:
SKeyLgth:
SKeyAorD:
@@ -335,14 +336,14 @@ dcl-proc Main ;
// === Create User Space =====================================
// Allow for 100,000 entries, which should be more than enough
APIEProv = 0;
CusIntSize=%size(UspHdr) + (%size(LOLentry)*100000);
CusIntSize=%size(UspHdr) + (%size(LOLEntry)*100000);
UsrSpcCrt(
CusQName:
CusAttr:
CusIntSize:
CusIntVal:
CusAut:
Custext);
CusText);
// === Get Pointer to User Space =============================
UsrSpcPointer(CusQName: UspPtr);
// === Initialize requested outputs ==========================
APIs/LCKOBJ.CMD
+39
View File
@@ -0,0 +1,39 @@
LCKOBJ: CMD PROMPT('Get a lock on an object')
/*-----------------------------------------------------------------*/
/* CPP is LCKOBJC */
/* 02/00/97 LENNON Original writting */
/*-----------------------------------------------------------------*/
PARM KWD(OBJ) TYPE(OBJSTUFF) MIN(1) +
PROMPT('Object Name')
PARM KWD(WAIT) TYPE(*DEC) LEN(5) DFT(*CLS) +
RANGE(30 32767) SPCVAL((*CLS 99999) (0)) +
PROMPT('Seconds to wait')
PARM KWD(OPMAYCAN) TYPE(*CHAR) LEN(4) RSTD(*YES) +
DFT(*NO) VALUES(*YES *NO) PROMPT('May +
operator cancel job?')
OBJSTUFF: ELEM TYPE(Q1) MIN(1) PROMPT('Object Name')
ELEM TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*AUTL +
*BNDDIR *CLD *CRQD *CSI *CSPMAP *CSPTBL +
*DEVD *DTAARA *DTADCT *DTAQ *FCT *FILE +
*FNTRSC *FNTTBL *FORMDF *IPXD *LIB +
*LOCALE *MENU *MODULE *MSGQ *NODL *NTBD +
*NWSD *OVL *PAGDFN *PAGSEG *PDG *PGM +
*PNLGRP *PSFCFG *QMFORM *QMQRY *QRYDFN +
*SBSD *SCHIDX *SQLPKG *SRVPGM *SSND *S36 +
*USRIDX *USRQ *USRSPC *WSCST) MIN(1) +
PROMPT('Object Type')
ELEM TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*SHRRD +
*SHRNUP *SHRUPD *EXCLRD *EXCL) MIN(1) +
PROMPT('Lock state')
ELEM TYPE(*NAME) LEN(10) SPCVAL((*FIRST)) +
EXPR(*NO) PROMPT('Member, if data base file')
Q1: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')
APIs/LCKOBJC.CLLE
+229
View File
@@ -0,0 +1,229 @@
LCKOBJC: +
PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
/* -----------------------------------------------------------------*/
/* Program attemps to lock an object with the requested lock state, */
/* *EXCL, EXCLRD, etc. */
/* If it fails to obtain the lock in the specified time it talks to */
/* the system operator, telling him which job are causing the */
/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ */
/* for 5, 10, 0r 30 minutes, or the default class wait time. */
/* -----------------------------------------------------------------*/
/* Use the LCKOBJ command to invoke this program */
/* -----------------------------------------------------------------*/
/* 11/24/97 LENNON Original writing */
/* -----------------------------------------------------------------*/
/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
/* RTVOBJD to get real library name to put in the */
/* message fails. If this occurs, just continue and */
/* *LIBL may appear in the message. */
/* Change retry logic to allow entry of varying times. */
/* Installed 9/2002. */
/* -----------------------------------------------------------------*/
/* 02/--/2024 Build ALCOBJ commands for *FILE and all other to */
/* handle Member being specified. */
/* Ignore *FIRST for member because it won't work */
/* with the SQL service. */
/* Add CONFLICT(*RQSRLS) to the ALCOBJ command. */
/* -----------------------------------------------------------------*/
/* Input parameters */
DCL VAR(&P_OBJ) TYPE(*CHAR) LEN(48) /* Obj & lib */
DCL VAR(&P_WAIT) TYPE(*DEC) LEN(5) /* Seconds */
DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4) /* *YES *NO */
/* Variables used in this program */
DCL VAR(&ORGWAIT) TYPE(*DEC) LEN(7) /* Original wait*/
DCL VAR(&ELEMC) TYPE(*CHAR) LEN(2) /* # elements */
DCL VAR(&ELEMP) TYPE(*DEC) LEN(5) /* # elements */
DCL VAR(&JOBTYPE) TYPE(*CHAR) LEN(1) /* 1=interactive */
DCL VAR(&LCKSTATE) TYPE(*CHAR) LEN(8) /* *SHRRD, etc */
DCL VAR(&KEYVAR) TYPE(*CHAR) LEN(4) /* messages */
DCL VAR(&MEMBER) TYPE(*CHAR) LEN(10) /* if *FILE */
DCL VAR(&OBJNAM) TYPE(*CHAR) LEN(10) /* Obj name */
DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10) /* Obj lib */
DCL VAR(&OPMSG) TYPE(*CHAR) LEN(500) /* No msg fld passed */
DCL VAR(&REPLY) TYPE(*CHAR) LEN(2) /* Oper Reply */
DCL VAR(&RETMSG) TYPE(*CHAR) LEN(200) /* From GETOBJUSR */
DCL VAR(&TYPE) TYPE(*CHAR) LEN(8) /* Obj type */
DCL VAR(&WAIT) TYPE(*DEC) LEN(5) /* Wait as num */
DCL VAR(&WAITC) TYPE(*CHAR) LEN(5) /* Wait as char */
DCL VAR(&WAITMIN) TYPE(*DEC) LEN(5) /* Wait in mins */
DCL VAR(&WAITMSG) TYPE(*CHAR) LEN(20) /* temp field */
DCL VAR(&ALC_CMD) TYPE(*CHAR) LEN(200) /* ALLOBJ Command */
/* Error Handling Variables */
DCL VAR(&E_MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&E_MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGFLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGDTA) TYPE(*CHAR) LEN(100)
/* Catch unmonitored errors */
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
/*==== Pre processing of input parameters =========================*/
/* &P_OBJ is a mixed list: */
/* 1 L2 binary # elements */
/* 3 L10 object name */
/* 13 L10 library */
/* 23 L8 object type */
/* 31 L8 lock state, *EXCL etc. */
/* 39 L10 member, if data base file */
/* Get number of elements */
CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
/* Extract elements from list. First 3 are required. */
/* Obj and lib are considered 1 element */
CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
/* Member is optional */
IF COND(&ELEMP *GT 3) THEN(DO)
CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
ENDDO
/* Set the default wait value */
/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
IF COND(&P_WAIT = 99999) THEN(DO)
RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
ENDDO
ELSE CMD(DO)
CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
ENDDO
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
/*=== Attempt to allocate the object ==============================*/
RETRY: +
/* Convert *LIBL/*CURLIB into a real name, if possible, */
/* for clarity in operator message. This may fail if the object*/
/* is already allocated *EXCL. If so, we just continue. */
IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
MONMSG MSGID(CPF9803) /* Cannot Allocate */
ENDDO
/* Blank member is syntax error in ALLOBJ, but if you do */
/* not specify a member it is the same as specifying *FIRST */
/* so get the *FIRST actual name. */
/* If not available just put in *FIRST and GETOBJUR will sort */
/* it out. */
IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
MONMSG MSGID(CPF3018) EXEC(DO) /* Not available */
CHGVAR VAR(&MEMBER) VALUE('*FIRST')
ENDDO
ENDDO
CHGVAR VAR(&WAITC) VALUE(&WAIT)
IF COND(&TYPE *NE '*FILE') THEN(DO)
/* Not a file: build command like this, without MEMBER */
/* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC) +
CONFLICT(*RQSRLS) */
CHGVAR VAR(&ALC_CMD) +
VALUE('ALCOBJ OBJ((' +
*TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
*CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
*TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
*TCAT ' CONFLICT(*RQSRLS) ' +
)
ENDDO
ELSE CMD(DO)
/* Is a file: build command like this, with MEMBER */
/* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATER)) WAIT(&WAITC) +
CONFLICT(*RQSRLS) */
CHGVAR VAR(&ALC_CMD) +
VALUE('ALCOBJ OBJ((' +
*TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
*CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
*TCAT ' ' *CAT &MEMBER +
*TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
*TCAT ' CONFLICT(*RQSRLS) ' +
)
ENDDO
/* If fail to obtain lock, then we must analyse the situation */
/* SNDUSRMSG MSG(&ALC_CMD) MSGTYPE(*INFO) TOMSGQ(*EXT) */
CALL PGM(QCMDEXC) PARM(&ALC_CMD 200)
MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
/* If wait is longer than 60 seconds, make minutes for */
/* message and round up to next minute. */
IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
ENDDO
ELSE CMD(DO)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
ENDDO
/* Find out who is using the object. By now all the */
/* locks may have been freed. If so, retry the ALCOBJ */
GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
MSGFLD(&RETMSG)
IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
/* Build a message for the operator. */
CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT ' Waited for ' *CAT +
&WAITMSG *TCAT ' Please attempt to resolve the conflict, +
then enter R to retry, or 5 to retry for 5 minutes, 10 to +
retry for 10 minutes or 30 to retry for 30 minutes.')
/* If he may cancel the job, let him know */
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
cancel.)')
ENDDO
/* Talk to the operator */
TALKTOOP: +
SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
MSGRPY(&REPLY) VALUES(5 10 30 R C)
/* R = retry for originally specified time */
IF COND(&REPLY *EQ 'R') THEN(DO)
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
GOTO CMDLBL(RETRY)
ENDDO
/* Send a CPF9898 escape message if operator cancels */
IF COND(&REPLY *EQ 'C') THEN(DO)
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
was canceled by a response of C') MSGTYPE(*ESCAPE)
ENDDO
ELSE (DO)
GOTO CMDLBL(TALKTOOP)
ENDDO
ENDDO
/* Else set new specified wait time and retry */
CHGVAR VAR(&WAIT) VALUE(&REPLY)
CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
GOTO CMDLBL(RETRY)
ENDDO /* MONMSG CPF1002 */
/*=== If we get this far we have the object locked as requested.===*/
/* End of program */
GOTO CMDLBL(ENDPGM)
/*=== Error handler - resend diagnostic & escape messages =========*/
ERROR: +
MOVPGMMSG MSGTYPE(*DIAG)
RSNESCMSG
ENDPGM: +
ENDPGM
APIs/T0.CLLE
+5
View File
@@ -0,0 +1,5 @@
PGM
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) MSGFLD(&MSG)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
ENDPGM
APIs/T1.CLLE
+6
View File
@@ -0,0 +1,6 @@
PGM
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(QSYS/LENNONS2) TYPE(*LIB) MSGFLD(&MSG)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
ENDPGM
APIs/T2.CLLE
+15
View File
@@ -0,0 +1,15 @@
PGM
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(QSYS/QSYS) TYPE(*LIB) MSGFLD(&MSG) +
RETFILE(*YES)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
QRY FILE(QTEMP/GETOBJUP)
GETOBJUSR OBJECT(QSYS/LENNONS2) TYPE(*LIB) MSGFLD(&MSG)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
GETOBJUSR OBJECT(QSYS/LENNONS1) TYPE(*LIB) MSGFLD(&MSG)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
ENDPGM
APIs/T9.CLP
+6
View File
@@ -0,0 +1,6 @@
PGM
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) +
MSGFLD(&MSG) RETFILE(*YES)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
ENDPGM
APIs/T9ALLOC1.CLLE
+4
View File
@@ -0,0 +1,4 @@
PGM
ALCOBJ OBJ((QIWS/QCUSTCDT *FILE *SHRRD)) WAIT(0)
DLYJOB DLY(90)
ENDPGM
APIs/T9ALLOCMNY.CLP
+10
View File
@@ -0,0 +1,10 @@
PGM
SBMJOB CMD(CALL PGM(T9ALLOC1)) JOB(CUSTLST) +
JOBQ(QUSRNOMAX)
SBMJOB CMD(CALL PGM(T9ALLOC1)) JOB(INV_UPD) +
JOBQ(QUSRNOMAX)
SBMJOB CMD(CALL PGM(T9ALLOC1)) JOB(DAILYORD) +
JOBQ(QUSRNOMAX)
SBMJOB CMD(CALL PGM(T9ALLOC1)) JOB(YTD_RPT) +
JOBQ(QUSRNOMAX)
ENDPGM
APIs_SQL/GETOBJUR.SQLRPGLE
+40 -30
View File
@@ -42,8 +42,8 @@ ctl-opt debug option(*nodebugio: *srcstmt)
bnddir('UTIL_BND':'SQL_BND')
main(Main);
//=== Prototypes =====================================================
/include copy_mbrs,Srv_Msg_P
/include copy_mbrs,Srv_SQL_P
/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
/include ../Copy_Mbrs/SRV_SQL_P.RPGLE
// Gets job type entry for this job.
// Returns: JobType has the job type. I=interactive, B=batch, etc.
@@ -56,8 +56,7 @@ end-pr;
// Input Parameters
// 1) pObject is object name (10c) + object library (10c)
// 2) pObjType is *FILE, *DTAARA, etc., standard OS/400 type
// 3) pObjMem is the member for files, or *NONE if just want users
// of the file.
// 3) pObjMem is the member for files
// 4) pMsgYN is *YES to create a message.
// 5) pFileYN is *YES if file GETOBJUP is to be created in QTEMP
// Output Parameter
@@ -65,18 +64,18 @@ end-pr;
//=== Global Definitions =============================================
dcl-s JobName28 char(28); // like '580065/JOBNM/USER''
dcl-c SQLSuccess '00000';
dcl-c SQLNoData '02000';
dcl-c SQLNoMoreData '02000';
dcl-c SQLProcWarning '01548';
dcl-c SQLFileNotFound '42704';
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
dcl-c SQLNOMOREDATA '02000';
dcl-c SQLPROCWARNING '01548';
dcl-c SQLFILENOTFOUND '42704';
//====================================================================
dcl-proc Main ;
//=== Misc Field Definitions =====================================
dcl-s NumJobs packed(5);
dcl-c MaxJobs const(4); //Maximum jobs for detailed reporting.
dcl-c MAXJOBS const(4); //Maximum jobs for detailed reporting.
// If you increase MaxJobs, increase the message parameter by 30 bytes
// for each additional job.
dcl-s JobName26 char(26); // is name(10) User(10) number(6)
@@ -96,6 +95,7 @@ dcl-proc Main ;
dcl-s theLibrary char(10);
dcl-s theObject char(10);
dcl-s j int(10);
dcl-s wkMem like(pObjMem);
// ---------------------------------------------------------
dcl-pi *n extpgm('GETOBJUR');
pObject char(20);
@@ -117,7 +117,7 @@ dcl-proc Main ;
if pFileYN='*YES';
exec sql drop table qtemp.GETOBJUP;
if SQLSTATE <> SQLSuccess and SQLSTATE <> SQLFileNotFound;
if SQLSTATE <> SQLSUCCESS and SQLSTATE <> SQLFILENOTFOUND;
SQLProblem('Delete GETOBJUP');
endif;
exec sql declare global temporary table GETOBJUP (
@@ -131,8 +131,8 @@ dcl-proc Main ;
OUOBJTYPE CHAR(10),
OUOBJMBR CHAR(10)
);
if SQLSTATE <> SQLSuccess;
SQLProblem('Declare global tempory table GETOBJUP');
if SQLSTATE <> SQLSUCCESS;
SQLProblem('Declare global temporary table GETOBJUP');
endif;
endif;
@@ -146,28 +146,38 @@ dcl-proc Main ;
JobOBJTYPE = pObjType;
JobOBJMBR = pObjMem;
// *FIRST doesn't work with SQL services. ALCOBJ puts a lock on
// the *FIRST member if you don't specify one and if the file
// is locked *EXCL then we can't get the first member name, so
// we leave it blank. Shouldn't matter because we're looking for
// any lock by any job.
if pObjMem = '*FIRST';
wkMem = ' ';
else;
wkMem = pObjMem;
endif;
// === Find the locks ============================================
exec sql declare Lock_Cursor cursor for
select distinct JOB_NAME
from QSYS2.OBJECT_LOCK_INFO
where SYSTEM_OBJECT_SCHEMA = :thelibrary
and SYSTEM_OBJECT_NAME = :theobject
and OBJECT_TYPE = :pobjtype
where SYSTEM_OBJECT_SCHEMA = :theLibrary
and SYSTEM_OBJECT_NAME = :theObject
and OBJECT_TYPE = :pObjType
and ifnull(SYSTEM_TABLE_MEMBER,' ') =
case when :pobjtype = '*FILE' and :pobjmem <> '*ALL' then :pobjmem
case when :pObjType = '*FILE' and :wkMem <> ' ' then :wkMem
else ' '
END
order by JOB_NAME
;
exec sql open Lock_Cursor ;
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
SQLProblem('open Lock_Cursor');
endif;
// Loop through the cursor, building requested outputs
fetchNext();
dow SQLSTT <> SQLNoData;
dow SQLSTT <> SQLNODATA;
NumJobs += 1;
if pFileYN='*YES';
// Build JobName26, parm for GetJobType
@@ -192,11 +202,11 @@ dcl-proc Main ;
// === End of Program ============================================
if pMsgYN='*YES';
select;
when NumJobs >= 1 and NumJobs <=MaxJobs;
pMsgfld=%trimr(pMsgFld) + '.';
when NumJobs > MaxJobs;
pMsgfld=%trimr(pMsgFld) + ' plus '
+ %trim(%editc(NumJobs-MaxJobs:'J'))
when NumJobs >= 1 and NumJobs <= MAXJOBS;
pMsgFld = %trimr(pMsgFld) + '.';
when NumJobs > MAXJOBS;
pMsgFld = %trimr(pMsgFld) + ' plus '
+ %trim(%editc(NumJobs-MAXJOBS:'J'))
+ ' more.';
other;
endsl;
@@ -215,8 +225,8 @@ dcl-proc Main ;
%trimr(pObjType) +
' is in use by ' +
JobName28;
when NumJobs >= 2 and NumJobs <=MaxJobs;
pMsgFld=%trimr(pMsgfld) + ', ' +
when NumJobs >= 2 and NumJobs <=MAXJOBS;
pMsgFld=%trimr(pMsgFld) + ', ' +
JobName28;
endsl;
endsr;
@@ -226,7 +236,7 @@ dcl-proc Main ;
begsr WriteRec;
JobNM28 = JobName28;
exec sql insert into qtemp.GETOBJUP values(:JobSQLDS);
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
sqlProblem('Insert into GETOBJUP');
endif;
endsr;
@@ -235,9 +245,9 @@ end-proc;
// === fetchNext =====================================================
dcl-proc fetchNext;
exec sql fetch next from Lock_Cursor into :JobName28;
if SQLSTT <> SQLSuccess
and SQLSTT <> SQLNOData
and SQLSTT <> SQLProcWarning;
if SQLSTT <> SQLSUCCESS
and SQLSTT <> SQLNODATA
and SQLSTT <> SQLPROCWARNING;
SQLProblem('fetchNext');
endif;
end-proc;
APIs_SQL/LCKOBJ.CMD
+39
View File
@@ -0,0 +1,39 @@
LCKOBJ: CMD PROMPT('Get a lock on an object')
/*-----------------------------------------------------------------*/
/* CPP is LCKOBJC */
/* 02/00/97 LENNON Original writting */
/*-----------------------------------------------------------------*/
PARM KWD(OBJ) TYPE(OBJSTUFF) MIN(1) +
PROMPT('Object Name')
PARM KWD(WAIT) TYPE(*DEC) LEN(5) DFT(*CLS) +
RANGE(30 32767) SPCVAL((*CLS 99999) (0)) +
PROMPT('Seconds to wait')
PARM KWD(OPMAYCAN) TYPE(*CHAR) LEN(4) RSTD(*YES) +
DFT(*NO) VALUES(*YES *NO) PROMPT('May +
operator cancel job?')
OBJSTUFF: ELEM TYPE(Q1) MIN(1) PROMPT('Object Name')
ELEM TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*AUTL +
*BNDDIR *CLD *CRQD *CSI *CSPMAP *CSPTBL +
*DEVD *DTAARA *DTADCT *DTAQ *FCT *FILE +
*FNTRSC *FNTTBL *FORMDF *IPXD *LIB +
*LOCALE *MENU *MODULE *MSGQ *NODL *NTBD +
*NWSD *OVL *PAGDFN *PAGSEG *PDG *PGM +
*PNLGRP *PSFCFG *QMFORM *QMQRY *QRYDFN +
*SBSD *SCHIDX *SQLPKG *SRVPGM *SSND *S36 +
*USRIDX *USRQ *USRSPC *WSCST) MIN(1) +
PROMPT('Object Type')
ELEM TYPE(*CHAR) LEN(8) RSTD(*YES) VALUES(*SHRRD +
*SHRNUP *SHRUPD *EXCLRD *EXCL) MIN(1) +
PROMPT('Lock state')
ELEM TYPE(*NAME) LEN(10) +
EXPR(*NO) PROMPT('Member, if data base file')
Q1: QUAL TYPE(*NAME) LEN(10) MIN(1)
QUAL TYPE(*NAME) LEN(10) DFT(*LIBL) +
SPCVAL((*LIBL) (*CURLIB)) PROMPT('Library')
APIs_SQL/LCKOBJC.CLLE
+229
View File
@@ -0,0 +1,229 @@
LCKOBJC: +
PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
/* -----------------------------------------------------------------*/
/* Program attemps to lock an object with the requested lock state, */
/* *EXCL, EXCLRD, etc. */
/* If it fails to obtain the lock in the specified time it talks to */
/* the system operator, telling him which job are causing the */
/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ */
/* for 5, 10, 0r 30 minutes, or the default class wait time. */
/* -----------------------------------------------------------------*/
/* Use the LCKOBJ command to invoke this program */
/* -----------------------------------------------------------------*/
/* 11/24/97 LENNON Original writing */
/* -----------------------------------------------------------------*/
/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
/* RTVOBJD to get real library name to put in the */
/* message fails. If this occurs, just continue and */
/* *LIBL may appear in the message. */
/* Change retry logic to allow entry of varying times. */
/* Installed 9/2002. */
/* -----------------------------------------------------------------*/
/* 02/--/2024 Build ALCOBJ commands for *FILE and all other to */
/* handle Member being specified. */
/* Ignore *FIRST for member because it won't work */
/* with the SQL service. */
/* Add CONFLICT(*RQSRLS) to the ALCOBJ command. */
/* -----------------------------------------------------------------*/
/* Input parameters */
DCL VAR(&P_OBJ) TYPE(*CHAR) LEN(48) /* Obj & lib */
DCL VAR(&P_WAIT) TYPE(*DEC) LEN(5) /* Seconds */
DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4) /* *YES *NO */
/* Variables used in this program */
DCL VAR(&ORGWAIT) TYPE(*DEC) LEN(7) /* Original wait*/
DCL VAR(&ELEMC) TYPE(*CHAR) LEN(2) /* # elements */
DCL VAR(&ELEMP) TYPE(*DEC) LEN(5) /* # elements */
DCL VAR(&JOBTYPE) TYPE(*CHAR) LEN(1) /* 1=interactive */
DCL VAR(&LCKSTATE) TYPE(*CHAR) LEN(8) /* *SHRRD, etc */
DCL VAR(&KEYVAR) TYPE(*CHAR) LEN(4) /* messages */
DCL VAR(&MEMBER) TYPE(*CHAR) LEN(10) /* if *FILE */
DCL VAR(&OBJNAM) TYPE(*CHAR) LEN(10) /* Obj name */
DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10) /* Obj lib */
DCL VAR(&OPMSG) TYPE(*CHAR) LEN(500) /* No msg fld passed */
DCL VAR(&REPLY) TYPE(*CHAR) LEN(2) /* Oper Reply */
DCL VAR(&RETMSG) TYPE(*CHAR) LEN(200) /* From GETOBJUSR */
DCL VAR(&TYPE) TYPE(*CHAR) LEN(8) /* Obj type */
DCL VAR(&WAIT) TYPE(*DEC) LEN(5) /* Wait as num */
DCL VAR(&WAITC) TYPE(*CHAR) LEN(5) /* Wait as char */
DCL VAR(&WAITMIN) TYPE(*DEC) LEN(5) /* Wait in mins */
DCL VAR(&WAITMSG) TYPE(*CHAR) LEN(20) /* temp field */
DCL VAR(&ALC_CMD) TYPE(*CHAR) LEN(200) /* ALLOBJ Command */
/* Error Handling Variables */
DCL VAR(&E_MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&E_MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGFLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGDTA) TYPE(*CHAR) LEN(100)
/* Catch unmonitored errors */
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
/*==== Pre processing of input parameters =========================*/
/* &P_OBJ is a mixed list: */
/* 1 L2 binary # elements */
/* 3 L10 object name */
/* 13 L10 library */
/* 23 L8 object type */
/* 31 L8 lock state, *EXCL etc. */
/* 39 L10 member, if data base file */
/* Get number of elements */
CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
/* Extract elements from list. First 3 are required. */
/* Obj and lib are considered 1 element */
CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
/* Member is optional */
IF COND(&ELEMP *GT 3) THEN(DO)
CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
ENDDO
/* Set the default wait value */
/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
IF COND(&P_WAIT = 99999) THEN(DO)
RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
ENDDO
ELSE CMD(DO)
CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
ENDDO
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
/*=== Attempt to allocate the object ==============================*/
RETRY: +
/* Convert *LIBL/*CURLIB into a real name, if possible, */
/* for clarity in operator message. This may fail if the object*/
/* is already allocated *EXCL. If so, we just continue. */
IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
MONMSG MSGID(CPF9803) /* Cannot Allocate */
ENDDO
/* Blank member is syntax error in ALLOBJ, but if you do */
/* not specify a member it is the same as specifying *FIRST */
/* so get the *FIRST actual name. */
/* If not available just put in *FIRST and GETOBJUR will sort */
/* it out. */
IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
MONMSG MSGID(CPF3018) EXEC(DO) /* Not available */
CHGVAR VAR(&MEMBER) VALUE('*FIRST')
ENDDO
ENDDO
CHGVAR VAR(&WAITC) VALUE(&WAIT)
IF COND(&TYPE *NE '*FILE') THEN(DO)
/* Not a file: build command like this, without MEMBER */
/* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC) +
CONFLICT(*RQSRLS) */
CHGVAR VAR(&ALC_CMD) +
VALUE('ALCOBJ OBJ((' +
*TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
*CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
*TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
*TCAT ' CONFLICT(*RQSRLS) ' +
)
ENDDO
ELSE CMD(DO)
/* Is a file: build command like this, with MEMBER */
/* ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATER)) WAIT(&WAITC) +
CONFLICT(*RQSRLS) */
CHGVAR VAR(&ALC_CMD) +
VALUE('ALCOBJ OBJ((' +
*TCAT &OBJLIB *TCAT '/' *TCAT &OBJNAM *TCAT ' ' +
*CAT &TYPE *TCAT ' ' *CAT &LCKSTATE +
*TCAT ' ' *CAT &MEMBER +
*TCAT ')) WAIT(' *TCAT &WAITC *TCAT ')' +
*TCAT ' CONFLICT(*RQSRLS) ' +
)
ENDDO
/* If fail to obtain lock, then we must analyse the situation */
/* SNDUSRMSG MSG(&ALC_CMD) MSGTYPE(*INFO) TOMSGQ(*EXT) */
CALL PGM(QCMDEXC) PARM(&ALC_CMD 200)
MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
/* If wait is longer than 60 seconds, make minutes for */
/* message and round up to next minute. */
IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
ENDDO
ELSE CMD(DO)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
ENDDO
/* Find out who is using the object. By now all the */
/* locks may have been freed. If so, retry the ALCOBJ */
GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
MSGFLD(&RETMSG)
IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
/* Build a message for the operator. */
CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT ' Waited for ' *CAT +
&WAITMSG *TCAT ' Please attempt to resolve the conflict, +
then enter R to retry, or 5 to retry for 5 minutes, 10 to +
retry for 10 minutes or 30 to retry for 30 minutes.')
/* If he may cancel the job, let him know */
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
cancel.)')
ENDDO
/* Talk to the operator */
TALKTOOP: +
SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
MSGRPY(&REPLY) VALUES(5 10 30 R C)
/* R = retry for originally specified time */
IF COND(&REPLY *EQ 'R') THEN(DO)
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
GOTO CMDLBL(RETRY)
ENDDO
/* Send a CPF9898 escape message if operator cancels */
IF COND(&REPLY *EQ 'C') THEN(DO)
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
was canceled by a response of C') MSGTYPE(*ESCAPE)
ENDDO
ELSE (DO)
GOTO CMDLBL(TALKTOOP)
ENDDO
ENDDO
/* Else set new specified wait time and retry */
CHGVAR VAR(&WAIT) VALUE(&REPLY)
CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
GOTO CMDLBL(RETRY)
ENDDO /* MONMSG CPF1002 */
/*=== If we get this far we have the object locked as requested.===*/
/* End of program */
GOTO CMDLBL(ENDPGM)
/*=== Error handler - resend diagnostic & escape messages =========*/
ERROR: +
MOVPGMMSG MSGTYPE(*DIAG)
RSNESCMSG
ENDPGM: +
ENDPGM
APIs_SQL/LCKOBJCorg.CLLE
+199
View File
@@ -0,0 +1,199 @@
LCKOBJC: +
PGM PARM(&P_OBJ &P_WAIT &P_OPMAYCAN)
/* -----------------------------------------------------------------*/
/* Program attemps to lock an object with the requested lock state, */
/* *EXCL, EXCLRD, etc. */
/* If it fails to obtain the lock in the specified time it talks to */
/* the system operator, telling him which job are causing the */
/* ALCOBJ to fail. Operator can opt to cancel, or retry the ALCOBJ */
/* for 5, 10, 0r 30 minutes, or the default class wait time. */
/* -----------------------------------------------------------------*/
/* Use the LCKOBJ command to invoke this program */
/* -----------------------------------------------------------------*/
/* 11/24/97 LENNON Original writing */
/* -----------------------------------------------------------------*/
/* 10/05/2001 Sam Lennon. If a non file object is locked *EXCL then */
/* RTVOBJD to get real library name to put in the */
/* message fails. If this occurs, just continue and */
/* *LIBL may appear in the message. */
/* Change retry logic to allow entry of varying times. */
/* Installed 9/2002. */
/* -----------------------------------------------------------------*/
/* Input parameters */
DCL VAR(&P_OBJ) TYPE(*CHAR) LEN(48) /* Obj & lib */
DCL VAR(&P_WAIT) TYPE(*DEC) LEN(5) /* Seconds */
DCL VAR(&P_OPMAYCAN) TYPE(*CHAR) LEN(4) /* *YES *NO */
/* Variables used in this program */
DCL VAR(&ORGWAIT) TYPE(*DEC) LEN(7) /* Original wait*/
DCL VAR(&ELEMC) TYPE(*CHAR) LEN(2) /* # elements */
DCL VAR(&ELEMP) TYPE(*DEC) LEN(5) /* # elements */
DCL VAR(&JOBTYPE) TYPE(*CHAR) LEN(1) /* 1=interactive */
DCL VAR(&LCKSTATE) TYPE(*CHAR) LEN(8) /* *SHRRD, etc */
DCL VAR(&KEYVAR) TYPE(*CHAR) LEN(4) /* messages */
DCL VAR(&MEMBER) TYPE(*CHAR) LEN(10) /* if *FILE */
DCL VAR(&OBJNAM) TYPE(*CHAR) LEN(10) /* Obj name */
DCL VAR(&OBJLIB) TYPE(*CHAR) LEN(10) /* Obj lib */
DCL VAR(&OPMSG) TYPE(*CHAR) LEN(500) /* No msg fld passed */
DCL VAR(&REPLY) TYPE(*CHAR) LEN(2) /* Oper Reply */
DCL VAR(&RETMSG) TYPE(*CHAR) LEN(200) /* From GETOBJUSR */
DCL VAR(&TYPE) TYPE(*CHAR) LEN(8) /* Obj type */
DCL VAR(&WAIT) TYPE(*DEC) LEN(5) /* Wait as num */
DCL VAR(&WAITC) TYPE(*CHAR) LEN(5) /* Wait as char */
DCL VAR(&WAITMIN) TYPE(*DEC) LEN(5) /* Wait in mins */
DCL VAR(&WAITMSG) TYPE(*CHAR) LEN(20) /* temp field */
/* Error Handling Variables */
DCL VAR(&E_MSGID) TYPE(*CHAR) LEN(7)
DCL VAR(&E_MSGF) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGFLIB) TYPE(*CHAR) LEN(10)
DCL VAR(&E_MSGDTA) TYPE(*CHAR) LEN(100)
/* Catch unmonitored errors */
MONMSG MSGID(CPF0000) EXEC(GOTO CMDLBL(ERROR))
/*==== Pre processing of input parameters =========================*/
/* &P_OBJ is a mixed list: */
/* 1 L2 binary # elements */
/* 3 L10 object name */
/* 13 L10 library */
/* 23 L8 object type */
/* 31 L8 lock state, *EXCL etc. */
/* 39 L10 member, if data base file */
/* Get number of elements */
CHGVAR VAR(&ELEMC) VALUE(%SST(&P_OBJ 1 2))
CHGVAR VAR(&ELEMP) VALUE(%BIN(&ELEMC))
/* Extract elements from list. First 3 are required. */
/* Obj and lib are considered 1 element */
CHGVAR VAR(&OBJNAM) VALUE(%SST(&P_OBJ 3 10))
CHGVAR VAR(&OBJLIB) VALUE(%SST(&P_OBJ 13 10))
CHGVAR VAR(&TYPE) VALUE(%SST(&P_OBJ 23 8))
CHGVAR VAR(&LCKSTATE) VALUE(%SST(&P_OBJ 31 8))
/* Member is optional */
IF COND(&ELEMP *GT 3) THEN(DO)
CHGVAR VAR(&MEMBER) VALUE(%SST(&P_OBJ 39 10))
ENDDO
/* If MEMBER is blank, change to *FIRST. *FIRST is ignored on */
/* non-file objects, but blanks causes a syntax error in ALCOBJ */
/* IF COND(&MEMBER *EQ ' ') THEN(DO) */
/* CHGVAR VAR(&MEMBER) VALUE('*FIRST') */
/* ENDDO */
/* Set the default wait value */
/* Wait 99999 means use *CLS as the wait value on the ALCOBJ */
IF COND(&P_WAIT = 99999) THEN(DO)
RTVJOBA TYPE(&JOBTYPE) DFTWAIT(&ORGWAIT)
ENDDO
ELSE CMD(DO)
CHGVAR VAR(&ORGWAIT) VALUE(&P_WAIT)
ENDDO
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
/*==== Convert *LIBL/*CURLIB into a real name, if possible,========*/
/* for clarity in operator message. This may fail if the object*/
/* is already allocated *EXCL. If so, we just continue. */
IF COND(&OBJLIB *EQ '*LIBL') THEN(DO)
RTVOBJD OBJ(&OBJLIB/&OBJNAM) OBJTYPE(&TYPE) RTNLIB(&OBJLIB)
MONMSG MSGID(CPF9803) /* Cannot Allocate */
ENDDO
/* Blank member is syntax error in ALLOBJ, but if you do */
/* not specify a member it is the same as specifying *FIRST */
/* so get the *FIRST actual name. */
IF COND((&TYPE *EQ '*FILE') *AND (&MEMBER *EQ ' ') ) THEN(DO)
RTVMBRD FILE(&OBJLIB/&OBJNAM) RTNMBR(&MEMBER)
ENDDO
/*=== Attempt to allocate the object ==============================*/
RETRY: +
CHGVAR VAR(&WAITC) VALUE(&WAIT)
ALCOBJ OBJ((&OBJLIB/&OBJNAM &TYPE &LCKSTATE &MEMBER)) WAIT(&WAITC)
/* If fail to obtain lock, then we must analyse the situation */
MONMSG MSGID(CPF1002) EXEC(DO) /* Not allocated */
/* If wait is longer than 60 seconds, make minutes for */
/* message and round up to next minute. */
IF COND(&WAIT > 60 *AND &WAIT *NE 0) THEN(DO)
CHGVAR VAR(&WAITMIN) VALUE((&WAIT + 59) / 60)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAITMIN) */
CHGVAR VAR(&WAITMSG) VALUE(&WAITMIN)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' minutes. ')
ENDDO
ELSE CMD(DO)
/* EDTVAR CHROUT(&WAITMSG) NUMINP(&WAIT)*/
CHGVAR VAR(&WAITMSG) VALUE(&WAIT)
CHGVAR VAR(&WAITMSG) VALUE(%TRIML(&WAITMSG '0'))
IF (&WAITMSG = ' ') CHGVAR &WAITMSG ('0')
CHGVAR VAR(&WAITMSG) VALUE(&WAITMSG *TCAT ' seconds. ')
ENDDO
/* Find out who is using the object. By now all the */
/* locks may have been freed. If so, retry the ALCOBJ */
GETOBJUSR OBJECT(&OBJLIB/&OBJNAM) TYPE(&TYPE) MEMBER(&MEMBER) +
MSGFLD(&RETMSG)
IF COND(&RETMSG *EQ ' ') THEN(GOTO CMDLBL(RETRY))
/* Build a message for the operator. */
CHGVAR VAR(&OPMSG) VALUE(&RETMSG *TCAT ' Waited for ' *CAT +
&WAITMSG *TCAT ' Please attempt to resolve the conflict, +
then enter R to retry, or 5 to retry for 5 minutes, 10 to +
retry for 10 minutes or 30 to retry for 30 minutes.')
/* If he may cancel the job, let him know */
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
CHGVAR VAR(&OPMSG) VALUE(&OPMSG *TCAT ' (Or enter C to +
cancel.)')
ENDDO
/* Talk to the operator */
TALKTOOP: +
SNDUSRMSG MSG(&OPMSG) MSGTYPE(*INQ) TOUSR(*REQUESTER) +
MSGRPY(&REPLY) VALUES(5 10 30 R C)
/* R = retry for originally specified time */
IF COND(&REPLY *EQ 'R') THEN(DO)
CHGVAR VAR(&WAIT) VALUE(&ORGWAIT)
GOTO CMDLBL(RETRY)
ENDDO
/* Send a CPF9898 escape message if operator cancels */
IF COND(&REPLY *EQ 'C') THEN(DO)
IF COND(&P_OPMAYCAN *EQ '*YES') THEN(DO)
SNDPGMMSG MSGID(CPF9898) MSGF(QCPFMSG) MSGDTA('PGM +
was canceled by a response of C') MSGTYPE(*ESCAPE)
ENDDO
ELSE (DO)
GOTO CMDLBL(TALKTOOP)
ENDDO
ENDDO
/* Else set new specified wait time and retry */
CHGVAR VAR(&WAIT) VALUE(&REPLY)
CHGVAR VAR(&WAIT) VALUE(&WAIT * 60)
GOTO CMDLBL(RETRY)
ENDDO /* MONMSG CPF1002 */
/*=== If we get this far we have the object locked as requested.===*/
/* End of program */
GOTO CMDLBL(ENDPGM)
/*=== Error handler - resend any trapped escape message ===========*/
ERROR: +
RCVMSG MSGTYPE(*LAST) MSGDTA(&E_MSGDTA) MSGID(&E_MSGID) +
MSGF(&E_MSGF) MSGFLIB(&E_MSGFLIB)
MONMSG MSGID(CPF0000) /* Just in case */
SNDPGMMSG MSGID(&E_MSGID) MSGF(&E_MSGFLIB/&E_MSGF) +
MSGDTA(&E_MSGDTA) MSGTYPE(*ESCAPE)
MONMSG MSGID(CPF0000) /* Just in case */
ENDPGM: +
ENDPGM
APIs_SQL/T2.CLLE
+1 -1
View File
@@ -1,5 +1,5 @@
PGM
/* Masic test, using a library as the oject of choice. */
/* Basic test, using a library as the oject of choice. */
/* Return just a file. Message will be blank. */
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
APIs_SQL/T9ALLOC1.CLLE
+2 -2
View File
@@ -2,6 +2,6 @@
/* Create a lock and delay. Called by T9ALLOCMNY */
ALCOBJ OBJ((QIWS/QCUSTCDT *FILE *SHRRD)) WAIT(0)
DLYJOB DLY(90)
ALCOBJ OBJ((lennons1/qclsrc *FILE *SHRRD)) WAIT(0)
DLYJOB DLY(180)
ENDPGM
APIs_SQL/T9ALLOCMNY.CLLE
+10 -4
View File
@@ -1,11 +1,17 @@
PGM
/***************************************************************/
/* Creates locks on QIWS/QCUSTCDT to test GETOBJUR. */
/* Creates locks on LENNONS/QCLSRC to test GETOBJUR. */
/* Call T9DSPMNY to report the locks. */
/***************************************************************/
DCL VAR(&JOBTYP) TYPE(*CHAR) LEN(1)
RTVJOBA TYPE(&JOBTYP)
IF COND(&JOBTYP *EQ '1') THEN(DO)
SBMJOB CMD(CALL PGM(T9ALLOCMNY) ) +
JOB(T9ALLOCMNY) JOBQ(QUSRNOMAX)
RETURN
ENDDO
/* Create an interactive lock */
ALCOBJ OBJ((QIWS/QCUSTCDT *FILE *SHRRD))
ALCOBJ OBJ((lennons1/qclsrc *FILE *SHRRD))
/* Create some batch locks. Submitted jobs wait for 90 seconds */
/* so you can call T9DSPMAY to see the locks. */
@@ -17,4 +23,4 @@
JOBQ(QUSRNOMAX)
SBMJOB CMD(CALL PGM(T9ALLOC1)) JOB(YTD_RPT) +
JOBQ(QUSRNOMAX)
ENDPGM
ENDPGM: ENDPGM
APIs_SQL/T9DSPMNY.CLLE
+1 -1
View File
@@ -3,7 +3,7 @@
/* Display locks after running T9ALLOCMNY */
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(QIWS/QCUSTCDT) TYPE(*FILE) +
GETOBJUSR OBJECT(lennons1/qclsrc) TYPE(*FILE) +
MSGFLD(&MSG) RETFILE(*YES)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
QRY FILE(QTEMP/GETOBJUP)
APIs_SQL/t90.clle
+10
View File
@@ -0,0 +1,10 @@
pgm
DCL VAR(&MSG) TYPE(*CHAR) LEN(200)
GETOBJUSR OBJECT(lennons1/qclsrc) TYPE(*file) +
MSGFLD(&MSG) RETFILE(*YES)
SNDMSG MSG(&MSG) TOUSR(*REQUESTER)
QRY FILE(QTEMP/GETOBJUP)
ENDPGM
BASE36/BASE36_Px.RPGLE
+5
View File
@@ -0,0 +1,5 @@
**FREE
// === BASE36ADD prototype ==========================================
dcl-pr BASE36ADD varchar(50);
theValue varchar(50) const;
end-pr;
BASE36/BTBR.SQLRPGLE
+1 -1
View File
@@ -17,7 +17,7 @@
ctl-opt debug option(*nodebugio: *srcstmt) dftactgrp(*no)
actgrp(*caller) bnddir('SRV_BASE36')
main(Main);
/include base36,base36_p
/include ../base36/base36_p.rpgle
dcl-proc Main ;
dcl-pi *N extpgm('BTBR');
BASE36/BTIR.RPGLE
+5 -5
View File
@@ -11,7 +11,7 @@
ctl-opt debug option(*nodebugio: *srcstmt) dftactgrp(*no)
actgrp(*caller) bnddir('SRV_BASE36')
main(Main);
/include base36,base36_p
/include ../base36/base36_p.rpgle
dcl-f BTID WORKSTN INFDS(dfInfDS) Usropn;
dcl-ds dfInfDS;
@@ -20,7 +20,7 @@ end-ds;
dcl-c F03 x'33';
dcl-c F05 x'35';
dcl-s ValVar varchar(20);
dcl-s valVar varchar(20);
dcl-s j int(10);
dcl-ds *N; // Rolling screen fields
@@ -61,14 +61,14 @@ dow Key <> F03;
// Roll values up the screen
for j = 1 to %elem(Values)-1;
Values(j) = Values(J+1);
Values(j) = Values(j+1);
endfor;
Val18 = Val;
// Increment by 1
valVar = %trim(val);
valVar = BASE36ADD(ValVar);
Val = ValVar;
valVar = BASE36ADD(valVar);
Val = valVar;
exfmt SCREEN;
enddo;
BASE36/SRV_BASE36.RPGLE
+5 -5
View File
@@ -24,7 +24,7 @@
ctl-opt debug nomain option(*nodebugio: *srcstmt) ;
/include BASE36,BASE36_P
/include ../BASE36/BASE36_P.RPGLE
dcl-proc BASE36ADD export ;
dcl-pi BASE36ADD varchar(50);
@@ -35,8 +35,8 @@ dcl-s wkValue like(PI_Value);
dcl-s inx int(10);
// Ascending values of a postion is A,B,...,Y,Z,0,1,2,...,7,8,9.
dcl-c From 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
dcl-c To 'BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789A';
dcl-c FROM 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
dcl-c TO 'BCDEFGHIJKLMNOPQRSTUVWXYZ0123456789A';
wkValue = PI_Value;
// Increment the last position in the input value. If it now is
@@ -44,9 +44,9 @@ wkValue = PI_Value;
// so move to the prior input value field and repeat.
inx = %len(PI_Value);
dow inx > 0;
%subst(wkValue:inx:1) = %xlate(From:To:%subst(wkValue:inx:1));
%subst(wkValue:inx:1) = %xlate(FROM:TO:%subst(wkValue:inx:1));
// if %subst(wkValue:inx:1) <> 'A'; // Not rolled over
if %subst(wkValue:inx:1) <> %subst(To:%size(To):1) ; // Not rolled over
if %subst(wkValue:inx:1) <> %subst(TO:%size(TO):1) ; // Not rolled over
leave;
endif;
inx -= 1;
Copy_Mbrs/AIDBYTES.RPGLE
+51
View File
@@ -0,0 +1,51 @@
**FREE
// 5250 Attention Indicator (AID) definitions
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');
// Page Down/Roll Up
dcl-c RollUp const(x'F5');
dcl-c PageDown const(x'F5');
// Page Up/Roll Down
dcl-c RollDown const(x'F4');
dcl-c PageUp const(x'F4');
// Enter
dcl-c Enter const(x'F1');
dcl-c Home const(x'F8');
//Mouse events linked to DDS MOUBTN keyword
dcl-c ME00 const(x'70');
dcl-c ME01 const(x'71');
dcl-c ME02 const(x'72');
dcl-c ME03 const(x'73');
dcl-c ME04 const(x'74');
dcl-c ME05 const(x'75');
dcl-c ME06 const(x'76');
dcl-c ME07 const(x'77');
dcl-c ME08 const(x'78');
dcl-c ME09 const(x'79');
dcl-c ME10 const(x'7A');
dcl-c ME11 const(x'7B');
dcl-c ME12 const(x'7C');
dcl-c ME13 const(x'7D');
dcl-c ME14 const(x'7E');
Copy_Mbrs/BASE36_P.RPGLE
+5
View File
@@ -0,0 +1,5 @@
**FREE
// === BASE36ADD prototype ==========================================
dcl-pr BASE36ADD varchar(50);
theValue varchar(50) const;
end-pr;
Copy_Mbrs/README.md
+12 -8
View File
@@ -2,30 +2,34 @@
These are source files that will be copied into programs using /COPY or /INCLUDE
* ##AIDBTYE
* ##AIDBTYE.RPGLE
5250 Attention ID Definitions. These are the value that are returned in byte 369 of the display file indicator data structure when a screen entry is made.
* SRV_MSG_P
* SRV_MSG_P.RPGLE
Prototype definitions for procedures in the SRV_MSG service program.
* SRV_STR_P
* SRV_RAND_P.RPGLE
Prototype definitions for procedures in the SRV_STR service program.
Prototype definitions for procedures in the SRV_RANDOM service program.
* SRV_SQL_P
* SRV_SQL_P.RPGLE
Prorotype definitions for procedures in the SQL_SRV service program.
* USADRVAL_P
* SRV_STR_P.RPGLE
Prototype definitions for procedures in the SRV_STR service program.
* USADRVAL_P.RPGLE
Prototype for the USADRVAL service program.
* USADRVALDS
* USADRVALDS.RPGLE
Template Data Structure for the USADRVAL parameters.
* USPHDR
* USPHDR.RPGLE
User Space Header Layout.
Copy_Mbrs/SRV_MSG_P.RPGLE
+24 -25
View File
@@ -1,34 +1,33 @@
//=== Prototypes for SRV_MSG routines ========================
//============================================================
D SndMsgPgmQ pr Send Msg to PGM Q
D pMsgQ 10
D pMsgid 7
D pMsgFile 10
D pMsgDta 512 options(*NOPASS)
D Varying
dcl-pr SndMsgPgmQ; // Send Msg to PGM Q
*n char(10); // pMsgQ
*n char(7); // pMsgid
*n char(10); // pMsgFile
*n varchar(512) options(*nopass); // pMsgDta
end-pr;
//============================================================
D ClrMsgPgmQ pr N Clear PGM Msg Q
D pPgmMsgQ 10
dcl-pr ClrMsgPgmQ ind; // Clear PGM Msg Q
*n char(10); // pPgmMsgQ
end-pr;
//============================================================
D SndEscMsg pr Send ESC Msg
D piMsg 512a Const Varying
D pStackEnt 10i 0 Const options(*nopass)
dcl-pr SndEscMsg; // Send ESC Msg
*n varchar(512) const; // piMsg
*n int(10) const options(*nopass); // pStackEnt
end-pr;
//============================================================
D SndInfMsg pr Send INF Msg
D piMsg 512a Const Varying
dcl-pr SndInfMsg; // Send INF Msg
*n varchar(512) const; // piMsg
end-pr;
//============================================================
D JobLogMsg Pr
D piMsg 512a Value Varying Msg to job log
dcl-pr JobLogMsg;
*n varchar(512) value; // piMsg Msg to job log
end-pr;
//============================================================
D Show pr extpgm('SHOW') Show popup msg
D piPext 8192a Const Varying
D piMsgId 7a Const options(*NOPASS)
d piMsgFile 21a Const options(*NOPASS)
dcl-pr Show extpgm('SHOW'); // Show popup msg
*n varchar(8192) const; // piPext
*n char(7) const options(*nopass); // piMsgId
*n char(21) const options(*nopass); // piMsgFile
end-pr;
//=== End of Prototypes forSRV_MSG Routines ==================
Copy_Mbrs/SRV_SQL_P.RPGLE
+5 -3
View File
@@ -1,4 +1,6 @@
//============================================================
Dcl-PR SQLProblem ; // Report SQL Problem
**free
// === Prototype for SRV_SQL routines =========================
dcl-pr SQLProblem ; // Report SQL Problem
pDebugMsg varchar(200) const;
End-PR;
end-pr;
// === End of Prototype for SRV_SQL routines ==================
Copy_Mbrs/SRV_STR_P.RPGLE
+4 -5
View File
@@ -1,8 +1,7 @@
**FREE
//=== Prototypes for SRV_STR routines ========================
//============================================================
d CenterStr pr 256a varying
d InStr 256a varying const
d
dcl-pr CenterStr varchar(256);
*n varchar(256) const; // InStr
end-pr;
//=== End of Prototypes forSRV_STR Routines ==================
Copy_Mbrs/USPHDR.RPGLE
+21 -20
View File
@@ -1,25 +1,26 @@
**free
//=== USPHDR Description =============================================
// The list APIs which return data in a user space put a standard
// header at the start of the user space. This descibes the header.
//=== Basing Pointer for Header ======================================
D UspPtr s * inz(*Null)
dcl-s UspPtr pointer inz(*null);
//=== User Space Header Layout =======================================
D UspHdr ds based(UspPtr)
D UspH 192a
D UspUser 64a overlay(UspH:1)
D UspSize 10i 0 overlay(UspH:65)
D UspInfSts 1a overlay(UspH:104)
D UspICmpl c const('C')
D UspIPrtl c const('P')
D UspIIncp c const('I')
D UspSpSize 10i 0 overlay(UspH:105)
D UspInOff 10i 0 overlay(UspH:109)
D UspInSize 10i 0 overlay(UspH:113)
D UspHdrOfs 10i 0 overlay(UspH:117)
D UspHdrSize 10i 0 overlay(UspH:121)
D UspLstOfs 10i 0 overlay(UspH:125)
D UspLstSize 10i 0 overlay(UspH:129)
D UspLst#Ent 10i 0 overlay(UspH:133)
D UspLstEntSz 10i 0 overlay(UspH:137)
dcl-ds UspHdr based(uspptr);
UspH char(192);
UspUser char(64) overlay(usph:1);
UspSize int(10) overlay(usph:65);
UspInfSts char(1) overlay(usph:104);
UspSpSize int(10) overlay(usph:105);
UspInOff int(10) overlay(usph:109);
UspInSize int(10) overlay(usph:113);
UspHdrOfs int(10) overlay(usph:117);
UspHdrSize int(10) overlay(usph:121);
UspLstOfs int(10) overlay(usph:125);
UspLstSize int(10) overlay(usph:129);
UspLst#Ent int(10) overlay(usph:133);
UspLstEntSz int(10) overlay(usph:137);
end-ds;
// UspInfSts values
dcl-c UspICmpl const('C');
dcl-c UspIPrtl const('P');
dcl-c UspIIncp const('I');
DATEADJ/DATEADJR.RPGLE
+1 -1
View File
@@ -13,7 +13,7 @@ ctl-opt option(*nodebugio: *srcstmt)
actgrp(*new)
main(Main);
ctl-opt BndDir('UTIL_BND');
/COPY copy_mbrs,Srv_Msg_P
/COPY ../Copy_Mbrs/SRV_MSG_P.RPGLE
dcl-pr getSpecFmts extpgm('DATEADJC');
jobfmt char(4);
sysvalfmt char(3);
DATEADJ/ReadMe.md
+1 -1
View File
@@ -4,7 +4,7 @@ Date arithmetic in CL programs is limited and lacks the simplicity and scope fou
The DATEADJ command adds the functionality of RPG date handling to CL programs.
DATEADJ adds or subtracts days, months or years from a date and returns an adjusted date. Input and output dates can be in almost any format that RPG recognizes.
DATEADJ adds or subtracts days, months or years from a date and returns an adjusted date. Input and output dates can be in almost any format that RPG recognizes. It can also be used to just change the format of a date by specifying an adjustment of 0.
A prompted DATEADJ command looks like this:
DATEADJ/T1R.RPGLE
+3 -3
View File
@@ -2,8 +2,8 @@
ctl-opt DftActGrp(*NO) ActGrp(*new) option(*nodebugio: *srcstmt)
main(Main);
ctl-opt BndDir('UTIL_BND');
/COPY copy_mbrs,Srv_Msg_P
/COPY copy_mbrs,Prt_p
/COPY ../Copy_Mbrs/SRV_MSG_P.RPGLE
/COPY ../Copy_Mbrs/PRT_P.RPGLE
dcl-proc Main;
@@ -48,7 +48,7 @@ dcl-proc Main;
head.inType = 'Type';
head.outDate = 'OutDate';
head.outFmt = 'OutFmt';
PRT(head :'*HEAD') ;
PRT(head :'*H1') ;
// === Test default stuff ====
inType = '*DAYS';
DATE_UDF/DATE_SQL.RPGLE
+68 -67
View File
@@ -1,3 +1,4 @@
**free
/title SQL UDFs to convert numeric to true dates
//===============================================================
// The DATE_SQL service program contains routines that are
@@ -49,37 +50,40 @@
// 3) Run the CREATE_FNSQL statements to register to SQL
//===============================================================
H NoMain
Ctl-Opt NoMain;
//=== Prototypes ================================================
D Date_YMD pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
Dcl-PR Date_YMD;
NumericDate Packed(8:0) const;
RealDate Date;
Indicators Int(5) dim(1);
RetInd Int(5);
SQLSTATE Char(5);
FuncName Varchar(517);
SpecificName Varchar(128);
ErrText Varchar(1000);
End-PR;
D Date_CYMD pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
Dcl-PR Date_CYMD;
NumericDate Packed(8:0) const;
RealDate Date;
Indicators Int(5) dim(1);
RetInd Int(5);
SQLSTATE Char(5);
FuncName Varchar(517);
SpecificName Varchar(128);
ErrText Varchar(1000);
End-PR;
D Date_MDY pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
Dcl-PR Date_MDY;
NumericDate Packed(8:0) const;
RealDate Date;
Indicators Int(5) dim(1);
RetInd Int(5);
SQLSTATE Char(5);
FuncName Varchar(517);
SpecificName Varchar(128);
ErrText Varchar(1000);
End-PR;
//===============================================================
// DATE_YMD
@@ -92,18 +96,18 @@
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_YMD b export
d Date_YMD pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
Dcl-Proc Date_YMD export;
Dcl-PI Date_YMD;
pDateIn Packed(8:0) const;
pDateOut Date;
pIndicators Int(5) dim(1);
pRetInd Int(5);
pSQLSTATE Char(5);
pFuncName Varchar(517);
pSpecificNam Varchar(128);
pErrText Varchar(1000);
End-PI;
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
@@ -122,8 +126,7 @@
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_YMD e
End-Proc;
//===============================================================
// DATE_CYMD
@@ -136,18 +139,18 @@
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_CYMD b export
d Date_CYMD pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
Dcl-Proc Date_CYMD export;
Dcl-PI Date_CYMD;
pDateIn Packed(8:0) const;
pDateOut Date;
pIndicators Int(5) dim(1);
pRetInd Int(5);
pSQLSTATE Char(5);
pFuncName Varchar(517);
pSpecificNam Varchar(128);
pErrText Varchar(1000);
End-PI;
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
@@ -159,8 +162,7 @@
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_CYMD e
End-Proc;
//===============================================================
// DATE_MDY
@@ -173,18 +175,18 @@
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_MDY b export
d Date_MDY pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
Dcl-Proc Date_MDY export;
Dcl-PI Date_MDY;
pDateIn Packed(8:0) const;
pDateOut Date;
pIndicators Int(5) dim(1);
pRetInd Int(5);
pSQLSTATE Char(5);
pFuncName Varchar(517);
pSpecificNam Varchar(128);
pErrText Varchar(1000);
End-PI;
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
@@ -203,5 +205,4 @@
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_MDY e
End-Proc;
DATE_UDF/DATE_SQLFX.RPGLE
+207
View File
@@ -0,0 +1,207 @@
/title SQL UDFs to convert numeric to true dates
//===============================================================
// The DATE_SQL service program contains routines that are
// registered as User Defined Functions to SQL and which
// convert legacy numeric dates to true dates. This makes doing
// date arithmetic in SQL much easier.
//
// For example, if DSTPT is a 6-digit date in YYMMDD format, in SQL
// you can code:
//
// SELECT PNOPT FROM MVPSPRTP
// WHERE DATE_YMD(DSTPT) >= CURDATE() - 9O DAYS
//
// On alder versions of the OS,you may need to cast character dates
// to numeric before using.
// For example, WHERE DECIMAL(DATE_YMD(DSTPT)) >= ...
//
// Function included are:
// DATE_YMD Accepts numeric dates in YMD format, with
// either 6 or 8 digits.
// DATE_MDY Accepts numeric dates in MDY format, with
// either 6 or 8 digits.
// DATE_CYMD Accepts 7 digit numeric dates. If the 1st
// digit is 0 then it is in the 1900s and if
// it is 1 then it is the 2000s. These are
// standard IBM seven byte dates.
// ??????? Similar routines could be added to
// accept other formats
//
// For YMD or MDY dates, it handles either 6 or 8 digits.
// If the date passed is greater then 999999 then is it
// assumed to already have the century.
//
// Invalid dates return a null value. This means the UDFs will
// not crash, but be aware that your results may be skewed if
// you have bad data. (Logic could be added to convert
// "special" bad dates into some corporately acceptable value,
// e.g., 999999 could be converted to 9999-12-31.)
//
// Originally coded late 1990s, before the Y2K cleanups. Since
// tidied up and converted to free form..
//
// To Create
// =========
// 1) CRTRPGMOD MODULE(DATE_SQL) SRCFILE(DATE_UDF)
// OPTION(*EVENTF) DBGVIEW(*SOURCE)
// 2) CRTSRVPGM SRVPGM(DATE_SQL) EXPORT(*ALL)
// TEXT('DATE_SQL Service Program')
// 3) Run the CREATE_FNSQL statements to register to SQL
//===============================================================
H NoMain
//=== Prototypes ================================================
D Date_YMD pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
D Date_CYMD pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
D Date_MDY pr
D NumericDate 8p 0 const
d RealDate d
D Indicators 5i 0 dim(1)
D RetInd 5i 0
d SQLSTATE 5a
d FuncName 517a varying
d SpecificName 128a varying
d ErrText 1000a varying
//===============================================================
// DATE_YMD
// ========
// SQL User Defined Function (UDF) converts a 6 or 8 digit
// numeric date in YMD format to a true date.
//
// Returns
// =======
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_YMD b export
d Date_YMD pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
select;
// === 8 digit dates, yyyymmdd =================================
when pDateIn > 999999;
pDateOut = %date(pDateIn: *ISO);
// === 6 digit dates, yymmdd ===================================
other;
pDateOut = %date(pDateIn: *YMD);
endsl;
on-error;
pRetInd = -1;
pDateOut = %date('9999-01-03');
pSQLSTATE = '01H99';
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_YMD e
//===============================================================
// DATE_CYMD
// =========
// SQL User Defined Function (UDF) converts a 7 digit
// numeric date in CYMD format to a true date.
//
// Returns
// =======
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_CYMD b export
d Date_CYMD pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
pDateOut = %date(pDateIn: *CYMD);
on-error;
pRetInd = -1;
pDateOut = %date('9999-01-01');
pSQLSTATE = '01H99';
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_CYMD e
//===============================================================
// DATE_MDY
// ========
// SQL User Defined Function (UDF) converts a 6 or 8 digit
// numeric date in MDY format to a true date.
//
// Returns
// =======
// If input date is valid, then a true date.
// If input date is invalid, returns null with warning 01H99.
p Date_MDY b export
d Date_MDY pi
d pDateIn 8p 0 const
d pDateOut d
d pIndicators 5i 0 dim(1)
d pRetInd 5i 0
d pSQLSTATE 5a
d pFuncName 517a varying
d pSpecificName 128a varying
d pErrText 1000a varying
/FREE
pRetInd = 0;
pSQLSTATE = '00000';
monitor;
select;
// === 8 digit dates, mmddyyyy =================================
when pDateIn > 999999;
pDateOut = %date(pDateIn: *USA);
// === 6 digit dates, mmddyy ===================================
other;
pDateOut = %date(pDateIn: *MDY);
endsl;
on-error;
pRetInd = -1;
pDateOut = %date('9999-01-02');
pSQLSTATE = '01H99';
pErrText = %char(pDateIn) + ' is not a (numeric) date';
endmon;
return;
/END-FREE
p Date_MDY e
DATE_UDF/ReadMe.md
+5 -5
View File
@@ -10,7 +10,7 @@ Legacy databases on the IBM i stored dates in numeric (or character) fields. Doi
## Development
What these functions do can also be done, with some work, directly in SQL. And I'm aware there are other open source date UDFs avaliable, e.g. [iDate](https://www.think400.dk/downloads.htm).
What these functions do can also be done, *with some work*, directly in SQL. And I'm aware there are other open source date UDFs avaliable, e.g. [iDate](https://www.think400.dk/downloads.htm).
However...
@@ -41,15 +41,15 @@ An invalid input value will return a null value and give a 01H99 SQLSTATE warnin
## DATE_SQL
The RPG code for the DATE_SQL service program, which contains the functions. It is free format but the D-Specs are still fixed, and it can be edited in SEU. (When I originally wrote it, it was in fixed form RPGIV.)
The RPG code for the DATE_SQL service program, which contains the functions.
## DATE_SQLFR
## DATE_SQLFX
This is DATE_SQL but converted to totally free form. I converted it using [RpgFreeWeb](https://github.com/worksofbarry/rpgfreeweb), which does a nice job.
This is DATE_SQL with the D-Specs in fixed form, as a convenience for any who might still be on older releases.
## DATECRTFN
This is SQL "Create Function" code that tells SQL where the functions are.
This is SQL "Create Function" code that tells SQL where the functions are. Use the RUNSQLSTM command or iACS Run SQL Scripts.
## TEST_CYMD/TEST_MDY/TEST_YMD
GRP_JOB/ReadMe.md
+1 -1
View File
@@ -40,4 +40,4 @@ This program is called from GRP to establish each group job. The command it runs
## GRP_ATN
This is called when the Attn key is pressed. **Shift+Esc is the Attn keys in most 5250 emulators.** It pops up a very functional but effective IBM menu to pick another group job.
This is called when the Attn key is pressed. **Shift+Esc is the Attn keys in most 5250 emulators.** It pops up a very functional but effective IBM menu to pick another group job. You can add your own menu to make this more friendly.
PGM_REFS/Readme.MD
+5 -3
View File
@@ -10,8 +10,10 @@ So far I have not found a decent manual or turorial. If you know of any please p
My primary approach was trial and error, with help
from these articles on IT Jungle:
[Ted HolT Article 1](https://www.itjungle.com/2017/06/12/guru-error-handling-sql-pl-part-1/) and
[Ted Holt Article 2](https://www.itjungle.com/2017/10/16/guru-error-handling-sql-pl-part-2/)
[Ted Holt Article 1](https://www.itjungle.com/2016/09/27/fhg092716-story02/) and
[Ted Holt Article 2](https://www.itjungle.com/2016/10/18/fhg101816-story03/) and
[Ted HolT Article 3](https://www.itjungle.com/2017/06/12/guru-error-handling-sql-pl-part-1/) and
[Ted Holt Article 4](https://www.itjungle.com/2017/10/16/guru-error-handling-sql-pl-part-2/)
and browsing [Scott Forstie Gists on Github](https://gist.github.com/forstie
)
@@ -41,7 +43,7 @@ You need to supply library and name. The type will default to `*PGM` and the dep
### Library list
Since many objects will have a library of `*LIBL`, that is what will get passed to DSPPGMREF for expansion. So you need to have your library list contain all libraries whose objects you want expanded.
Since many objects will have a library of `*LIBL`, that is what will get passed to DSPPGMREF for expansion. So you need to make sure your library list contain all libraries whose objects you want expanded.
### DSPPGMREF Failure
PRT_CL/DEMO_RPG1.SQLRPGLE
+3 -3
View File
@@ -20,8 +20,8 @@
ctl-opt option(*srcstmt: *nodebugio)
bnddir('SQL_BND')
actgrp(*new) main(Main);
/COPY copy_mbrs,prt_p
/COPY copy_mbrs,srv_sql_p
/COPY ../Copy_Mbrs/PRT_P.RPGLE
/COPY ../Copy_Mbrs/SRV_SQL_P.RPGLE
dcl-proc Main;
dcl-pi Main;
@@ -205,4 +205,4 @@ dcl-proc Main;
endif;
endsr;
end-proc main;
end-proc Main;
PRT_CL/PRT_T.RPGLE
+1 -2
View File
@@ -1,7 +1,7 @@
**free
// === Test program to exercise the PRT program =====================
ctl-opt option(*srcstmt: *nodebugio) actgrp(*new) main(Main);
/COPY copy_mbrs,prt_p
/COPY ../Copy_Mbrs/PRT_P.RPGLE
dcl-proc Main;
dcl-pi Main;
// pi_head char(132);
@@ -217,5 +217,4 @@ dcl-proc Main;
*inlr = *on;
end-proc;
README.md
+37 -6
View File
@@ -1,15 +1,45 @@
# RPGLE free format, SQL and CLP Code for the IBM i
# RPGLE free format, SQL & CLP Code for the IBM i
More developers are learning about the **IBM i** as a wonderful business platform. (It was formerly known as the **AS/400**.)
This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i.
My intent is to provide real programs that help you learn and/or improve your current understanding. Explore and adapt the code to your needs. Some of the code may be of use "as is" but no guarantee is provided.
**This repository contains *working* example code, using RPGLE free-format, enbedded SQL and CLP for the IBM i. All RPG code here is totally free form.**.
**Each folder has its own ReadMe with additional infomation/documentation.**
My intent is to provide real programs that help you learn and/or improve your current understanding. Explore and adapt the code to your needs. Some of the code may be of use "as is" but no guarantee is provided.
Feel free to provide comments and feedback as issues.
# Source Control Philosophy
This code in this repository is based on having source in the file system (IFS) rather than the traditional approach of members in a PF-SRC file.
For these personal projects I use the free IBM i [PUB400.COM](https://pub400.com/).
I edit and compile using [VS Code](https://code.visualstudio.com/) with the ["Code for IBM i"](https://codefori.github.io/docs/#/) extension. My source is/was in PF-SRC members and for backup I created a SAVF file of my PF-SRC files and downloaded it to my PC. But I didn't do it regularly.
Now that ["Code for IBM i"](https://codefori.github.io/docs/#/) supports local development on a PC and will push code to the IFS, I am using Github as a permanent repository. Doing editing on my PC and pushing changes to Github and the IFS is easier than creating a save file and downloading it.
This means that on the IBM i, code is in directories in the IFS instead of being in PF-SRC file members.
This is my setup:
- Github contains my personal "production" source.
- My PC has Git installed and the PC files are where I make changes.
- I deploy to the IFS to compile with ["Code for IBM i"](https://codefori.github.io/docs/#/).
My PC has a directory structure like this:
| Directory shown in VS CODE |Directory shown in File Explorer |
|----------------------------------------|---------------------------------------|
| ![Directory Structure](image.png) | ![Directory Structure](image-2.png) |
The IFS directory after deployment looks like this:
![Directory Structure](image-1.png)
The primary difference from moving away from PF-SRC file members is that COPY and INCLUDE statements must now reference an IFS file. I do not want to hard code directory names so I am using relative addressing, such as
``/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE``.
## Copy_Mbrs
Code to be copied into other programs.
@@ -74,3 +104,4 @@ Developer Utilities.
QRY - Qry (List) Contents of a file
RC - Display File Record count
RcdLckDsp/RCDLCKBAD.RPGLE
+36 -44
View File
@@ -1,51 +1,45 @@
*==============================================================
* Program that locks a record and then waits for input from
* the operator.
*
* Call this program in two different sessions to see the effect.
* Second program will typically get a error:
* 'Unable to allocate a record in file' (RNX1218)
* and the end user typically choses an unhelpful response.
*==============================================================
* Note: This is a poor technique because the record remains
* locked to all other users until the transaction is
* completed, which may be in a few seconds or after lunch.
*
*Note: Pgm reads by RRN for convenience. This is not a good
* idea is a production program.
*
*Note: DSPLY is use to simulate a display file interaction
* with the user.
*
*Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
*==============================================================
**free
// ==============================================================
// Program that locks a record and then waits for input from
// the operator.
//
// Call this program in two different sessions to see the effect.
// Second program will typically get a error:
// 'Unable to allocate a record in file' (RNX1218)
// and the end user typically choses an unhelpful response.
// ==============================================================
// Note: This is a poor technique because the record remains
// locked to all other users until the transaction is
// completed, which may be in a few seconds or after lunch.
//
// Note: Pgm reads by RRN for convenience. This is not a good
// idea is a production program.
//
// Note: DSPLY is use to simulate a display file interaction
// with the user.
//
// Note: QIWS/QCUSTCDT: believed to be on virtually all systems.
// ==============================================================
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
H DFTACTGRP(*NO) ACTGRP(*NEW)
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
F RECNO(RRN)
F* INFSR(*PSSR)
D QCmdexc PR EXTPGM('QCMDEXC')
D CMD 512A
D lgth 15P 5 const
D RRN s 10p 0 inz(10)
D reply S 1A inz('*')
D Cmd S 512A
/free
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output) USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
// INFSR(*PSSR)
;
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
Cmd Char(512);
lgth Packed(15:5) CONST;
End-PR;
Dcl-S RRN Packed(10:0) INZ(10);
Dcl-S reply Char(1) INZ('*');
Dcl-S Cmd Char(512);
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCMDEXC(cmd:512);
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCmdexc(Cmd:512);
open QCUSTCDT;
chain RRN QCUSTCDT;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
@@ -53,12 +47,10 @@
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
// Often found in old programs. Uncomment INFSR(*PSSR) in the
// F-SPEC to make this active.
BEGSR *PSSR;
RcdLckDsp/RCDLCKDEMO.RPGLE
+43 -47
View File
@@ -1,54 +1,53 @@
*==============================================================
* Program that locks a record and then waits for input from
* the operator.
*
* Call this program in two different sessions to see the effect.
*==============================================================
* - Locking the record first is a poor technique because
* the record remains locked to all other users until the
* transaction is completed, which may be in a few seconds or
* after lunch.
* It is used here to demonstate the RCDLCKDSP processing.
*==============================================================
* - Pgm reads by RRN for convenience. This is generally not a
* good idea is a production program.
*
*- DSPLY is use to simulate a display file interaction with
* the user. Not normally done in production.
*
* - QIWS/QCUSTCDT: believed to be on virtually all systems.
*==============================================================
**free
// ==============================================================
// Program that locks a record and then waits for input from
// the operator.
//
// Call this program in two different sessions to see the effect.
// ==============================================================
// - Locking the record first is a poor technique because
// the record remains locked to all other users until the
// transaction is completed, which may be in a few seconds or
// after lunch.
// It is used here to demonstate the RCDLCKDSP processing.
// ==============================================================
// - Pgm reads by RRN for convenience. This is generally not a
// good idea is a production program.
//
// - DSPLY is use to simulate a display file interaction with
// the user. Not normally done in production.
//
// - QIWS/QCUSTCDT: believed to be on virtually all systems.
// ==============================================================
H DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF)
H DFTACTGRP(*NO) ACTGRP(*NEW)
Ctl-Opt DEBUG(*YES) OPTION(*NODEBUGIO:*SRCSTMT:*NOUNREF);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
FQCUSTCDT UF E DISK USROPN EXTDESC('QIWS/QCUSTCDT')
F RECNO(RRN)
F* INFSR(*PSSR)
Dcl-F QCUSTCDT Usage(*Update:*Delete:*Output)
USROPN EXTDESC('QIWS/QCUSTCDT') RECNO(RRN)
// INFSR(*PSSR)
;
D RCDLCKDSP PR EXTPGM('RCDLCKDSP')
D poReply 1A
D piPSDS *
D QCmdexc PR EXTPGM('QCMDEXC')
D CMD 512A
D lgth 15P 5 const
D RRN s 10p 0 inz(10)
D reply S 1A inz('*')
D Cmd S 512A
D myPSDS SDS
D myPSDS_ptr S * inz(%addr(myPSDS))
/free
Dcl-PR RCDLCKDSP EXTPGM('RCDLCKDSP');
poReply Char(1);
piPSDS Pointer;
End-PR;
Dcl-PR QCmdexc EXTPGM('QCMDEXC');
Cmd Char(512);
lgth Packed(15:5) CONST;
End-PR;
Dcl-S RRN Packed(10:0) INZ(10);
Dcl-S reply Char(1) INZ('*');
Dcl-S Cmd Char(512);
Dcl-DS myPSDS PSDS;
End-DS;
Dcl-S myPSDS_ptr Pointer INZ(%ADDR(myPSDS));
*inlr = *on;
// Set update file to a short wait time. Otherwise the file or
// system default wait time applies.
cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCMDEXC(cmd:512);
Cmd = ' OVRDBF FILE(QCUSTCDT) TOFILE(QIWS/QCUSTCDT) WAITRCD(1)';
QCmdexc(Cmd:512);
open QCUSTCDT;
dou not %error;
chain(e) RRN QCUSTCDT;
if %error;
@@ -65,7 +64,6 @@
endif;
endif;
enddo;
if %found(QCUSTCDT);
// Logic to update the record would be here.
dsply 'Read for update' ' ' reply;
@@ -73,12 +71,10 @@
// Logic for record not found would be here
dsply 'Record not found' ' ' reply;
endif;
// === End of Program =========================================
// Close file before returning
close QCUSTCDT;
return;
begsr Prog_Cancelled;
close QCUSTCDT;
// Put graceful ending logic & notification to user here
RcdLckDsp/RCDLCKDSP.RPGLE
+110 -139
View File
@@ -1,136 +1,118 @@
*==============================================================
* When an interactive program tries to update a record that is
* locked by another user, often the program doesn't handle it.
* The RPG error routines kick in and give the user a confusing
* error message.
*
* Instead, trap the error and handle it by calling this program.
*
* This program communicates info about a locked record to an
* interactive user telling who has the lock.
**free
// ==============================================================
// When an interactive program tries to update a record that is
// locked by another user, often the program doesn't handle it.
// The RPG error routines kick in and give the user a confusing
// error message.
//
// Instead, trap the error and handle it by calling this program.
//
// This program communicates info about a locked record to an
// interactive user telling who has the lock.
* See program RCDLCKDEMO for a usage example.
*
* RCDLCKDSP accepts a continuation reply from the user and
* passes it back to the caller.
*
* If the status is not 1218, then it is considered an
* unexpected error and a slightly different dialog is
* presented, asking the user to contact IT. You can
* customize this as you see fit. Or add other statuses.
*
* Information is retrieved from the *PSDS passed from the caller.
*
*==============================================================
* Parameters
* ==========
* 1 Output CL1 User's reply about what to do:
* R - Retry the IO operation that failed
* C - Cancel the program
* D - DUmp the program and cancel
* 2 Input * Pointer to the *PSDS in the calling program.
* (A pointer is used because the *PDSD is not
* always the same length in a program.)
*==============================================================
* Create with CRTBNDRPG
* New activation group so we destroy nothing in the caller.
* No worries about overhead since rarely called.
h OPTION(*NODEBUGIO: *SRCSTMT)
H DFTACTGRP(*NO) ACTGRP(*NEW)
*==============================================================
// See program RCDLCKDEMO for a usage example.
//
// RCDLCKDSP accepts a continuation reply from the user and
// passes it back to the caller.
//
// If the status is not 1218, then it is considered an
// unexpected error and a slightly different dialog is
// presented, asking the user to contact IT. You can
// customize this as you see fit. Or add other statuses.
//
// Information is retrieved from the *PSDS passed from the caller.
//
// ==============================================================
// Parameters
// ==========
// 1 Output CL1 User's reply about what to do:
// R - Retry the IO operation that failed
// C - Cancel the program
// D - DUmp the program and cancel
// 2 Input * Pointer to the *PSDS in the calling program.
// (A pointer is used because the *PDSD is not
// always the same length in a program.)
// ==============================================================
// Create with CRTBNDRPG
// New activation group so we destroy nothing in the caller.
// No worries about overhead since rarely called.
Ctl-Opt OPTION(*NODEBUGIO: *SRCSTMT);
Ctl-Opt DFTACTGRP(*NO) ACTGRP(*NEW);
// ==============================================================
FrcdlckdspdCF E WORKSTN
Dcl-F rcdlckdspd WORKSTN;
Dcl-PR RCDLCKDSP;
poReply Char(1);
piPSDS Pointer;
End-PR;
Dcl-PI RCDLCKDSP;
poReply Char(1);
piPSDS Pointer;
End-PI;
d RCDLCKDSP pr
D poReply 1A
D piPSDS *
// === The caller's Program Status Data Structure ===============
// Many fields not currently used.
Dcl-DS PSDS QUALIFIED BASED(PIPSDS);
PROC_NAME Char(10) Pos(1); //* Procedure name
PGM_STATUS Zoned(5:0) Pos(11); //* Status code
PRV_STATUS Zoned(5:0) Pos(16); //* Previous status
LINE_NUM Char(8) Pos(21); //* Src list line num
ROUTINE Char(8) Pos(29); //* Routine name
PARMS Char(3) Pos(37); //* Num passed parms
EXCP_TYPE Char(3) Pos(40); //* Exception type
EXCP_NUM Char(4) Pos(43); //* Exception number
PGM_LIB Char(10) Pos(81); //* Program library
EXCP_DATA Char(80) Pos(91); //* Exception data
EXCP_ID Char(4) Pos(171); //* Exception Id
LAST_FILE_IO Char(10) Pos(175); //* Last file used
DATE Char(8) Pos(191); //* Date (*DATE fmt)
YEAR Zoned(2:0) Pos(199); //* Year (*YEAR fmt)
LAST_FILE Char(8) Pos(201); //* Last file used
FILE_INFO_STATUS Zoned(5:0) Pos(209) ; //* Last file status
FILE_INFO_OPCODE Char(6) Pos(214); //* Last file opcode
FILE_INFO_ROUTINE Char(8) Pos(220) ; //* Last file RPG
FILE_INFO_LIST_NUM Char(8) Pos(228) ; //* Last file listing
FILE_INFO_RECORD Int(20) Pos(236) ; //* Last file record
JOB_NAME Char(10) Pos(244); //* Job name
USER Char(10) Pos(254); //* User name
JOB_NUM Zoned(6:0) Pos(264); //* Job number
JOB_DATE Zoned(6:0) Pos(270); //* Date (UDATE fmt)
RUN_DATE Zoned(6:0) Pos(276); //* Run date (UDATE)
RUN_TIME Zoned(6:0) Pos(282); //* Run time (UDATE)
CRT_DATE Char(6) Pos(288); //* Create date
CRT_TIME Char(6) Pos(294); //* Create time
CPL_LEVEL Char(4) Pos(300); //* Compiler level
SRC_FILE Char(10) Pos(304); //* Source file
SRC_LIB Char(10) Pos(314); //* Source file lib
SRC_MBR Char(10) Pos(324); //* Source file mbr
PROC_PGM Char(10) Pos(334); //* Pgm Proc is in
PROC_MOD Char(10) Pos(344); //* Mod Proc is in
LINE_NUM_SRCID Int(5) Pos(354); //* Src list source ID
FILE_INFO_LIST_NUM_SRCID Int(5) Pos(356) ; //* Last file listing
CURR_USER Char(10) Pos(358) ; //* Current user
EXTERNAL_RC Int(10) Pos(368) ; //* External return
NUM_XML_ELEMS Int(20) Pos(372) ; //* Number of XML
End-DS;
// === My Variables ==============================================
Dcl-DS MyPSDS PSDS;
MyName Char(10) Pos(1); //* This program
End-DS;
d RCDLCKDSP pi
D poReply 1A
D piPSDS *
* === The caller's Program Status Data Structure ===============
* Many fields not currently used.
D PSDS DS qualified based(piPSDS)
D PROC_NAME 1 10 * Procedure name
D PGM_STATUS 11 15s 0 * Status code
D PRV_STATUS 16 20S 0 * Previous status
D LINE_NUM 21 28 * Src list line num
D ROUTINE 29 36 * Routine name
D PARMS 37 39 * Num passed parms
D EXCP_TYPE 40 42 * Exception type
D EXCP_NUM 43 46 * Exception number
D PGM_LIB 81 90 * Program library
D EXCP_DATA 91 170 * Exception data
D EXCP_ID 171 174 * Exception Id
D LAST_FILE_IO 175 184 * Last file used
D DATE 191 198 * Date (*DATE fmt)
D YEAR 199 200S 0 * Year (*YEAR fmt)
D LAST_FILE 201 208 * Last file used
D FILE_INFO_STATUS...
D 209 213S 0 * Last file status
D * Code
D FILE_INFO_OPCODE...
D 214 219 * Last file opcode
D FILE_INFO_ROUTINE...
D 220 227 * Last file RPG
D * routine
D FILE_INFO_LIST_NUM...
D 228 235 * Last file listing
D * line
D FILE_INFO_RECORD...
D 236 243I 0 * Last file record
D * name
D JOB_NAME 244 253 * Job name
D USER 254 263 * User name
D JOB_NUM 264 269S 0 * Job number
D JOB_DATE 270 275S 0 * Date (UDATE fmt)
D RUN_DATE 276 281S 0 * Run date (UDATE)
D RUN_TIME 282 287S 0 * Run time (UDATE)
D CRT_DATE 288 293 * Create date
D CRT_TIME 294 299 * Create time
D CPL_LEVEL 300 303 * Compiler level
D SRC_FILE 304 313 * Source file
D SRC_LIB 314 323 * Source file lib
D SRC_MBR 324 333 * Source file mbr
D PROC_PGM 334 343 * Pgm Proc is in
D PROC_MOD 344 353 * Mod Proc is in
D LINE_NUM_SRCID...
D 354 355I 0 * Src list source ID
D FILE_INFO_LIST_NUM_SRCID...
D 356 357I 0 * Last file listing
D * source ID
D CURR_USER 358 367 * Current user
D * profile
D EXTERNAL_RC 368 371I 0 * External return
D * code
D NUM_XML_ELEMS 372 379I 0 * Number of XML
d * elements
*=== My Variables ==============================================
D MyPSDS sDS
D MyName 1 10 * This program
D User c 'User: '
D UserPrf S 10A inz(' ')
D UserName S 40A inz(' ')
D wkI s 10I 0
D wkJ s 10I 0
d myStatus s 4S 0
D*AAA DS likeds(PSDS)
/FREE
Dcl-C USER 'USER: ';
Dcl-S UserPrf Char(10) INZ(' ');
Dcl-S UserName Char(40) INZ(' ');
Dcl-S wkI Int(10);
Dcl-S wkJ Int(10);
Dcl-S myStatus Zoned(4:0);
//Dcl-DS AAA LIKEDS(PSDS);
// AAA = PSDS; // Eases Debugging...
SH_PGM = MyName;
// Sometimes the Status is not numeric
monitor;
myStatus = psds.FILE_INFO_STATUS;
myStatus = PSDS.FILE_INFO_STATUS;
on-error;
myStatus = -0;
ENDMON;
// Display fields are prefixed with SC_.
select;
when myStatus = 1218; //Record locked
@@ -138,44 +120,35 @@
SC_USER2 = 'their transaction or exits their application.';
exsr GetUserPrf;
//exsr GetUserName;
// Fill in user profile and user name
select;
when UserPrf = ' ' and UserName = ' ';
SC_USER3 = User + '*Unknown* -- Call IT Now.';
SC_USER3 = USER + '*Unknown* -- Call IT Now.';
when UserName = ' ';
SC_USER3 = User + UserPrf;
SC_USER3 = USER + UserPrf;
other;
SC_USER3 = User + UserName;
SC_USER3 = USER + UserName;
endsl;
SC_INSTR = 'Enter R to Retry, C to Cancel';
other; //Unknown error
SC_USER1 = 'An unexpected error has occurred.';
SC_USER2 = 'Please contact IT now.';
SC_INSTR = 'IT: D=Dump, C=Cancel; R=Retry';
endsl;
// We try to fill in this info for all conditions
SC_IT_PGM = PSDS.PROC_NAME;
SC_IT_STS = myStatus;
SC_IT_FILE = PSDS.LAST_FILE;
SC_IT_OPCD = PSDS.FILE_INFO_OPCODE;
SC_IT_EM1 = %subst(PSDS.EXCP_DATA: 1: %len(SC_IT_EM1));
SC_IT_EM2 = %subst(PSDS.EXCP_DATA: %len(SC_IT_EM1)+1);
exfmt dspwin;
exfmt DSPWIN;
poReply = 'R'; //Default to R
if SC_RESP = 'C' or SC_RESP = 'R' or SC_RESP = 'D';
poReply = SC_RESP;
endif;
*inlr = *on;
return;
begsr GetUserPrf;
// Dig the user profile out of the error message (EXCP_DATA)
// which looks like this:
@@ -185,18 +158,16 @@
if wkI <> 0;
wkI = wkI +1;
wkJ = %scan('/' :PSDS.EXCP_DATA: wkI);
if WkJ <> 0;
wkJ = WkJ - wkI;
if wkJ <> 0;
wkJ = wkJ - wkI;
if wkI > 0;
UserPrf = %subst(PSDS.EXCP_DATA: wkI: wkJ);
endif;
endif;
endif;
endsr;
begsr GetUserName;
// If you have a way to connect a user name to a user
// then set UserName here.
UserName = ' ';
endsr;
/END-FREE
RcdLckDsp/Readme.md
+1 -1
View File
@@ -16,7 +16,7 @@ The top half of the window is information for the current user of the interactiv
The bottom half provides information for the IT Department should the need arise.
## RCDLCKDSP
## RCDLCKDSP.RPGLE
This is the standalone RPG program that handles the window display. It is passed two parameters:
SQL_SKELETON/SQL_SKEL2.SQLRPGLE
+12 -12
View File
@@ -26,14 +26,14 @@
main(SQL_SKEL);
//=== Prototypes ======================================
/include copy_mbrs,srv_sql_p
/include ../Copy_Mbrs/SRV_SQL_P.RPGLE
//=== SQL State Constants =============================
dcl-c SQLSuccess '00000';
dcl-c SQLNoData '02000';
dcl-c SQLNoMoreData '02000';
dcl-c SQLDupRecd '23505';
dcl-c SQLRowLocked '57033';
dcl-c SQLSUCCESS '00000';
dcl-c SQLNODATA '02000';
dcl-c SQLNOMOREDATA '02000';
dcl-c SQLDUPRECD '23505';
dcl-c SQLROWLOCKED '57033';
//=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=
// Main Program =
@@ -47,7 +47,7 @@ dcl-proc SQL_SKEL;
dcl-ds InTbl extname('QIWS/QCUSTCDT') template
end-ds;
dcl-s MyCusnum like(cusnum);
dcl-s MyCusNum like(cusnum);
dcl-s MyLstNam like(lstnam);
dcl-s MyInit like(init);
dcl-s MyState like(state);
@@ -73,12 +73,12 @@ dcl-proc SQL_SKEL;
;
//=== Initialization ================================
exec sql open DemoCursor;
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
SQLProblem('open DemoCursor');
endif;
//=== Main Logic ====================================
exsr FetchCur;
dow SQLSTT = SQLSuccess;
dow SQLSTT = SQLSUCCESS;
RecordsRead += 1;
// Real program logic goes here <<<<<<<<<<
exsr FetchCur;
@@ -89,7 +89,7 @@ dcl-proc SQL_SKEL;
// ---- Deliberate bug to exercise SQLProblem -----
exec sql close DemoCursor;
// ------------------------------------------------
if SQLSTT <> SQLSuccess;
if SQLSTT <> SQLSUCCESS;
SQLProblem('close DemoCursor');
endif;
*inlr = *on;
@@ -111,8 +111,8 @@ dcl-proc SQL_SKEL;
:MyState,
:MyBalDue
;
if SQLSTT <> SQLSuccess
and SQLSTT <> SQLNoMoreData;
if SQLSTT <> SQLSUCCESS
and SQLSTT <> SQLNOMOREDATA;
SQLProblem('fetch DemoCursor');
endif;
endsr;
Service_Pgms/CRTBNDDIR.CLLE
+17
View File
@@ -0,0 +1,17 @@
PGM
/* === Create UTIL_BND binding directory ======================== */
/* === Set your target library here ================ */
DCL VAR(&TGT_LIB) TYPE(*CHAR) LEN(10) +
VALUE('*CURLIB')
/* ================================================= */
DLTBNDDIR BNDDIR(&TGT_LIB/UTIL_BND)
MONMSG MSGID(CPF0000)
CRTBNDDIR BNDDIR(&TGT_LIB/UTIL_BND) TEXT('Utilities +
Service PGMs')
ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_MSG *SRVPGM *DEFER))
ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_STR *SRVPGM *DEFER))
ENDPGM
Service_Pgms/README.md
+4 -4
View File
@@ -10,13 +10,13 @@ Contains procedures to send messages from an RPG program.
**ClrMsgPgmQ**: Clear all messages from the provided program queue. (Interactive programming.)
**SndEscMsg**: Send provided text as an escape message.
**SndEscMsg**: Send provided text as an escape message. (Note that the SND-MSG opcode can replace this in newer compiler versions.)
**SndInfMsg**: Send provided text as info message to the external message queue.
**SndInfMsg**: Send provided text as info message to the external message queue. (Note that the SND-MSG opcode can replace this in newer compiler versions.)
**JobLogMsg**: Send provided text to the job log using Qp0zLprintf, a C function. For testing, a convenient alternative to the DSPLY opcode for longer messages.
## SRV_RANDON
## SRV_RANDOM
Convenience procedures relating to pseudo random number generation.
@@ -63,6 +63,6 @@ Contains procedures to manipulate strings in an RPG program.
## SHOW
RPG program to display a 5250 message using the QUILNGTX API. Useful for testing, but possibly
JobLogMsg in SRV_MSG is more useful. Really should be part of SRV_MSG, but it is totally *FREE for and I have left SRV_MSG partially fixed.
JobLogMsg in SRV_MSG is more useful. Really should be part of SRV_MSG.
* SHOW_T RPG program to test & exercise SHOW.
Service_Pgms/SHOW_T.RPGLE
+1 -1
View File
@@ -4,7 +4,7 @@ Ctl-Opt DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt);
Ctl-Opt BndDir('UTIL_BND');
//=== Service Program Prototypes ==============================
/include copy_mbrs,Srv_Msg_P
/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
dcl-s short1 char(30) inz('A typical short msg.');
Service_Pgms/SRV_MSG.RPGLE
+114 -124
View File
@@ -1,9 +1,9 @@
**free
//==============================================================
//=== SRV_MSG service program contains prodcedure for sending
//=== messages:
// With QMHSNDPM
// With Qp0zLprintf (to job log.)
// 1) With QMHSNDPM
// 2) With Qp0zLprintf (to job log.)
//==============================================================
// CRTRPGMOD MODULE(SRV_MSG)
//
@@ -12,49 +12,53 @@
// TEXT('Messages service program')
//
// ADDBNDDIRE BNDDIR(UTIL_BND) OBJ((SRV_MSG *SRVPGM *DEFER))
//==============================================================
// 12/2023 Convert to totally **FREE
//==============================================================
h nomain option(*NoDebugIo: *srcstmt)
/include copy_mbrs,Srv_Msg_P
ctl-opt nomain option(*nodebugio: *srcstmt);
/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
//=== QMHSNDPM internal prototype =============================
D QMHSNDPM pr ExtPgm('QMHSNDPM')
D piMsgId 7a Const
D piMsgFile 20a Const
D piMsgData 1024a Const OPTIONS(*varsize)
D piMsgDataLgth 10i 0 Const
D piMsgType 10a Const
D piCallStk 10a Const
D piRelCallStk 10i 0 Const
D piRtnMsgKey 4a
D apiErrorDS 17a
dcl-pr QMHSNDPM extpgm('QMHSNDPM');
*n char(7) const; // piMsgId
*n char(20) const; // piMsgFile
*n char(1024) const options(*varsize); // piMsgData
*n int(10) const; // piMsgDataLgth
*n char(10) const; // piMsgType
*n char(10) const; // piCallStk
*n int(10) const; // piRelCallStk
*n char(4); // piRtnMsgKey
*n char(17); // apiErrorDS
end-pr;
//=== QMHRMVPM internal prototype =============================
d QMHRMVPM pr Extpgm('QMHRMVPM')
d pPgmMsgQ 10a
d PgmStk 10i 0
d MsgKey 4a
d Remove 10a
D apiErrorDS 17a
dcl-pr QMHRMVPM extpgm('QMHRMVPM');
*n char(10); // pPgmMsgQ
*n int(10); // PgmStk
*n char(4); // MsgKey
*n char(10); // Remove
*n char(17); // apiErrorDS
end-pr;
//=== Qp0zLprintf =============================================
d printF pr extproc('Qp0zLprintf')
d piMsg * value options(*string)
dcl-pr printF extproc('Qp0zLprintf');
*n pointer value options(*string); // piMsg
end-pr;
//=== SNDMSGPGMQ ===============================================
// SeND a MeSsaGe to a ProGraM message Queue.
// Sends a pre-defined message to a program message queue
// that you provide as a parameter.
// Primarily designed to be used in interactive programs
// that send messages via a message subfile.
// See also CLRMSGPGMQ which clears messages from a program
// message queue.
//==============================================================
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Msg_P
// /include ../Copy_Mbrs/SRV_MSG_P.RPGLE
// D ProgStatus sds
// D PgmName *PROC
// SNDMSGPGMQ(PgmName:
@@ -62,13 +66,13 @@
// MsgFile:
// MsgDta);
//==============================================================
P SndMsgPgmQ b export
d SndMsgPgmQ pi
d pMsgQ 10
d pMsgid 7
d pMsgFile 10
d pMsgDta 512 options(*NOPASS)
d Varying
dcl-proc SndMsgPgmQ export;
dcl-pi SndMsgPgmQ;
pMsgQ char(10);
pMsgid char(7);
pMsgFile char(10);
pMsgDta varchar(512) options(*nopass);
end-pi;
//=== Calling Parameters =======================================
// Parm I/O/B Description
// ---- ----- -----------
@@ -80,23 +84,22 @@
// is assumed as *LIBL.)
// pMsgDta I Optional: Data to substitute into the message.
// (Trailing blanks will be truncated before use.)
//=== API Error Code Structure ==================================
// We don't provide any bytes, so an error will cause a crash,
// because if we get an error here something bad has happened.
dAPIError ds 272
d APIEProv 1 4b 0 inz(0)
d APIEAvail 5 8b 0 inz(0)
d APIErrId 9 15 inz(*blanks)
dcl-ds APIError len(272);
APIEProv int(10) inz(0) pos(1);
APIEAvail int(10) inz(0) pos(5);
APIErrId char(7) inz(*blanks) pos(9);
end-ds;
//=== QMHSNDPM Parameters =======================================
d QMsgFile s 20
d MsgType s 10 inz('*INFO')
d StackCntr s 10i 0 inz(0)
d MsgKey s 4 inz(' ')
d MsgDta s 256 inz(' ')
d MsgDtaLgth s 10i 0
dcl-s QMsgFile char(20);
dcl-s MsgType char(10) inz('*INFO');
dcl-s StackCntr int(10) inz(0);
dcl-s MsgKey char(4) inz(' ');
dcl-s MsgDta char(256) inz(' ');
dcl-s MsgDtaLgth int(10);
//=== SNDMSGPGMQ execution starts here ==========================
/free
QMsgFile = pMsgFile + '*LIBL';
// Message data length for QMHSNDPM is optional. If supplied,
// use, else default to 0.
@@ -119,94 +122,86 @@
// Exit with LR off. This is a tiny routine which will probably
// be called again.
return;
/end-free
p SndMsgPgmQ e
end-proc;
//=== CLRMSGPGMQ =-=============================================
// CLeaRs all MeSsaGes from a ProGraM message Queue
// Clears all the messages from a program message queue that
// you specify as a parameter.
// It is primarily designed for use by interactive programs that
// send messages through a message subfile.
// See also SNDMSGPGMQ which sends a message to the program queue.
//
// Always returns *OFF
//===============================================================
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Msg_P
// /include ../Copy_Mmbrs/SRV_MSG_P.RPGLE
// D ProgStatus sds
// D PgmName *PROC
// CLRMSGPGMQ(PgmName)
p ClrMsgPgmQ b export
D ClrMsgPgmQ pi N
d pPgmMsgQ 10
dcl-proc ClrMsgPgmQ export;
dcl-pi ClrMsgPgmQ ind;
pPgmMsgQ char(10);
end-pi;
//=== API Error Code Structure ==================================
// We don't provide any bytes, so an error will cause a crash,
// because if we get an error here something bad has happened.
dAPIError ds 272
d APIEProv 1 4b 0 inz(0)
d APIEAvail 5 8b 0 inz(0)
d APIErrId 9 15 inz(*blanks)
dcl-ds APIError len(272);
APIEProv int(10) inz(0) pos(1);
APIEAvail int(10) inz(0) pos(5);
APIErrId char(7) inz(*blanks) pos(9);
end-ds;
//=== Parameters for QMHRMVPM API ===============================
d PgmStk s 10i 0 inz(0)
d MSgKey s 4 inz(*blanks)
d Remove s 10 inz('*ALL')
dcl-s PgmStk int(10) inz(0);
dcl-s MSgKey char(4) inz(*blanks);
dcl-s Remove char(10) inz('*ALL');
//=== Calling Parameters =============================================
// Parm I/O/B Description
// ---- ----- -----------
// pPGMMsgQ I Program message queue to clear.
//=== ClrMsgPgmQ execution starts here ==========================
/free
QMHRMVPM(pPgmMsgQ
:PgmStk
:MsgKey
:MSgKey
:Remove
:APIError);
/free
// Exit with LR off. This is a tiny routine which will probably
// be called again.
RETURN *off;
/end-free
return *off;
p ClrMsgPgmQ e
end-proc;
//=== SndEscMsg ===============================================
// Sends CPF9898 Escape message of the provided text.
// This will kill the current program and cause an
// exception in the one that called it.
P SndEscMsg B Export
dcl-proc SndEscMsg export;
D SndEscMsg PI
D piMsg 512a Const Varying
D piStackEnt 10i 0 Const options(*Nopass)
dcl-pi SndEscMsg;
piMsg varchar(512) const;
piStackEnt int(10) const options(*nopass);
end-pi;
//--- Parameters for QMHSNDPM -------------------------
D MsgId c const('CPF9898')
d MsgF c const('QCPFMSG *LIBL ')
d MsgType c const('*ESCAPE ')
d PgmQue c const('* ')
d InvCount s 10i 0 inz(2)
d ApiError s 17a inz(X'00')
d RetMsgKey s 4a
D DataLen s 10i 0
dcl-c MSGID const('CPF9898');
dcl-c MSGF const('QCPFMSG *LIBL ');
dcl-c MSGTYPE const('*ESCAPE ');
dcl-c PGMQUE const('* ');
dcl-s InvCount int(10) inz(2);
dcl-s ApiError char(17) inz(x'00');
dcl-s RetMsgKey char(4);
dcl-s DataLen int(10);
//--- Local Variables ---------------------------------
D MsgData s 1024a
dcl-s MsgData char(1024);
/FREE
DataLen = %len(PiMSG);
DataLen = %len(piMsg);
MsgData = piMsg;
if %parms = 2;
@@ -215,80 +210,75 @@
InvCount = 2;
endif;
QMHSNDPM(MsgId
:MsgF
QMHSNDPM(MSGID
:MSGF
:MsgData
:DataLen
:MsgType
:PgmQue
:MSGTYPE
:PGMQUE
:InvCount
:RetMsgKey
:APIError);
:ApiError);
return;
/end-free
P SndEscMsg E
end-proc;
//=== SndInfMsg ===============================================
// Sends CPF9898 Info message of the provided text to the
// external message queue.
// Useful for debugging. See also JobLogMsg.
P SndInfMsg B Export
dcl-proc SndInfMsg export;
D SndInfMsg PI
D piMsg 512a Const Varying
dcl-pi SndInfMsg;
piMsg varchar(512) const;
end-pi;
//--- Parameters for QMHSNDPM -------------------------
D MsgId c const('CPF9898')
d MsgF c const('QCPFMSG *LIBL ')
d MsgType c const('*INFO ')
d PgmQue c const('*EXT ')
d InvCount c const(2)
d ApiError s 17a inz(X'00')
d RetMsgKey s 4a
D DataLen s 10i 0
dcl-c MSGID const('CPF9898');
dcl-c MSGF const('QCPFMSG *LIBL ');
dcl-c MSGTYPE const('*INFO ');
dcl-c PGMQUE const('*EXT ');
dcl-c INVCOUNT const(2);
dcl-s ApiError char(17) inz(x'00');
dcl-s RetMsgKey char(4);
dcl-s DataLen int(10);
//--- Local Variables ---------------------------------
D MsgData s 1024a
dcl-s MsgData char(1024);
/FREE
DataLen = %len(PiMSG);
DataLen = %len(piMsg);
MsgData = piMsg;
QMHSNDPM(MsgId
:MsgF
QMHSNDPM(MSGID
:MSGF
:MsgData
:DataLen
:MsgType
:PgmQue
:InvCount
:MSGTYPE
:PGMQUE
:INVCOUNT
:RetMsgKey
:APIError);
:ApiError);
return;
/end-free
P SndInfMsg E
end-proc;
//=== JobLogMsg ===============================================
// Write arbitray message to the Job log.
// Uses Qp0zLprintf, which is a C function.
// Useful for debugging. See also SndInfMsg.
P JobLogMsg B Export
dcl-proc JobLogMsg export;
D JobLogMsg PI
D piMsg 512a Value Varying
dcl-pi JobLogMsg;
piMsg varchar(512) value;
end-pi;
d wkMsg s +1 like(piMSg)
d EOL c x'25'
dcl-s wkMsg like(piMsg:+1);
dcl-c EOL x'25';
/FREE
wkMsg = piMsg + EOL;
printF(wkMsg);
return;
/end-free
P JobLogMsg E
end-proc;
Service_Pgms/SRV_MSGTL.RPGLE
+3 -3
View File
@@ -2,10 +2,10 @@
//=== Tests JobLogMsg procedures in SRV_MSG service program ========
ctl-opt option(*NoDebugIo: *SrcStmt :*NoUnref) indent(' |')
ActGrp('QILE') DftActGrp(*no)
BndDir('UTIL_BND':'SQL_BND')
BndDir('UTIL_BND')
Main(Main);
/include copy_mbrs,Srv_Msg_P
/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
dcl-proc Main ;
dcl-pi *n extpgm('SRV_MSGTL');
@@ -36,5 +36,5 @@ dcl-proc Main ;
// JobLogMsg(scale );
SndInfMsg('SndInfMsg - to compare to JobLogMsg');
JobLogmsg('JobLogMsg - to compare to SndInfMsg');
JobLogMsg('JobLogMsg - to compare to SndInfMsg');
end-proc;
Service_Pgms/SRV_MSGTR.RPGLE
+40 -48
View File
@@ -1,51 +1,50 @@
**free
//=== Tests procedures in SRV_MSG service program =============
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
bnddir('UTIL_BND');
//=== Display File ============================================
FSRV_MSGTD CF E WorkStn INFDS(dfInfDS)
F INDDS(dfIndDS)
F USROPN
dcl-f SRV_MSGTD workstn infds(dfInfDS) indds(dfIndDS) usropn;
//=== Service Program Prototypes ==============================
/include copy_mbrs,Srv_Msg_P
/INCLUDE ../Copy_Mbrs/SRV_MSG_P.RPGLE
//=== Named hexadecimal constants for function keys ===========
/include copy_mbrs,##AIDBYTES
/INCLUDE ../Copy_Mbrs/AIDBYTES.RPGLE
//=== Display File Information Data Structure =================
// Allows us to determine which function key was pressed
D dfInfDS DS
D Key 369 369
dcl-ds dfInfDS;
Key char(1) pos(369);
end-ds;
//=== Display File Indicator Data Structure ===================
// This is a "private" indicator area for the display file.
D dfIndDS ds 99
D SH_ERR 40 40n
dcl-ds dfIndDS len(99);
SH_ERR ind pos(40);
end-ds;
//=== Global Switches =========================================
D SflMsgSnt s n
D CowsComeHome c const('0')
dcl-s SflMsgSnt ind;
dcl-c COWSCOMEHOME const('0');
//=== Work Fields =============================================
D inx s 10i 0
dcl-s inx int(10);
//=== Program Status Data Structure ===========================
D ProgStatus sds
D PgmName *PROC
dcl-ds ProgStatus PSDS;
PgmName *PROC;
end-ds;
/FREE
//=============================================================
// === Main Program Loop ======================================
//=============================================================
exsr init;
Init();
SFT_KEYS='F3/F12=Exit';
SH_Cnt = 2;
SH_MSG = 'This is a fine pickle Ollie!';
dou CowsComeHome;
dou COWSCOMEHOME;
write SH_HDR;
write SFT_FKEY;
if SflMsgSnt = *on;
@@ -56,7 +55,7 @@
SH_ERR = *off;
if key = F03 or Key = F12;
exsr CloseDownPgm;
CloseDownPgm();
return;
endif;
@@ -101,6 +100,7 @@
when Key = F08;
JobLogMsg(SH_MSG);
iter;
other;
endsl;
enddo;
@@ -109,27 +109,25 @@
//=== End of Main Program Loop ================================
//=============================================================
//=== CloseDownPgm ============================================
// Things to do before we issue a return to the caller
begsr CloseDownPgm;
Dcl-Proc CloseDownPgm;
*inlr = *on;
close SRV_MSGTD;
endsr;
End-Proc;
//=== Init ====================================================
begsr Init;
Dcl-Proc Init;
MSGPGMQ = PgmName;
SH_PGM = PgmName;
if not %open(SRV_MSGTD);
open SRV_MSGTD;
endif;
endsr;
End-Proc;
//=============================================================
// S u b P r o c e d u r e s
//=============================================================
//=== SndSflMsg ===============================================
// Send a message to the Error Subfile
// Returns: *ON
@@ -138,22 +136,19 @@
// Parameter: ErrMsgFile => Optional Error Message File
// Defaults to CUSTMSGF
//------------------------------------------------------------
/END-FREE
P SndSflMsg B
D SndSflMsg PI N
D ErrMsgId 7A CONST
D ErrMsgData 80A CONST
D OPTIONS(*NOPASS:*VARSIZE)
D ErrMsgFile 10A CONST
D OPTIONS(*NOPASS)
dcl-proc SndSflMsg;
dcl-pi SndSflMsg ind;
ErrMsgId char(7) const;
ErrMsgData char(80) const options(*nopass:*varsize);
ErrMsgFile char(10) const options(*nopass);
end-pi;
// Local fields
D retField S N
D wkMsgId s 7a
D wkMsgFile s 10a
D wkMsgData s 512a varying
dcl-s retField ind;
dcl-s wkMsgId char(7);
dcl-s wkMsgFile char(10);
dcl-s wkMsgData varchar(512);
/FREE
if %parms >2;
wkMsgFile = ErrMsgFile;
else;
@@ -165,15 +160,12 @@
wkMsgData = ' ';
ENDIF;
wkMsgId = ErrMsgId;
SNDMSGPGMQ(PgmName:
wkMsgid:
SndMsgPgmQ(PgmName:
wkMsgId:
wkMsgFile:
wkMsgData);
retField = *on;
RETURN retField;
/END-FREE
P SndSflMsg E
end-proc;
Service_Pgms/SRV_RANDT1.SQLRPGLE
+1 -1
View File
@@ -3,7 +3,7 @@
// writing them to file RNUM.
ctl-opt DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
BndDir('UTIL_BND');
/COPY copy_mbrs,srv_rand_p
/COPY ../Copy_Mbrs/SRV_RAND_P.RPGLE
exec sql set option datfmt=*iso,
commit=*none,
closqlcsr=*endmod;
Service_Pgms/SRV_SQL.SQLRPGLE
+3 -2
View File
@@ -9,7 +9,8 @@
ctl-opt nomain
bnddir('UTIL_BND')
option(*NoDebugIo: *srcstmt);
option(*NoDebugIo: *srcstmt)
;
//=== SQLProblem ===============================================
// For those "Never should happen" SQL errors.
@@ -21,7 +22,7 @@ dcl-proc SQLProblem export;
piSQLDebug varchar(200) const;
end-pi;
/include copy_mbrs,Srv_Msg_P
/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
//--- Local Variables ---------------------------------
dcl-s myDebugMsg varchar(512); //Max CPF9898 supports
Service_Pgms/SRV_STR.RPGLE
+21 -18
View File
@@ -1,6 +1,7 @@
**free
//==============================================================
//=== SRV_STR service program contains procedures working
//=== with strings
//=== with fixed length strings
//==============================================================
// CRTRPGMOD MODULE(SRV_STR)
// CRTSRVPGM SRVPGM(SRV_STR) EXPORT(*ALL)
@@ -10,14 +11,18 @@
// Return the centered string. The input string is normally
// fixed length and RPG will promote it to varying on the
// call. A varying string is returned which RPG will reset
// to fixed if needed.
// It will also execute with a varying string input but the
// result may not be what you expect.
//
// to fixed.
// **********************************************************
// *** It will also execute with a varying string input ***
// *** but the result probably wont't be what you expect. ***
// *** So don't use it on a varchar string. ***
// **********************************************************
// Conceptual call:
//=================
// H BndDir('UTIL_BND')
// /include copy_mbrs,Srv_Str_P
// /include ../Copy_Mbrs,SRV_STR_P.RPGLE
// d Head S 20A inz('Inquiry')
// Head = CenterStr(Head);
// Notes:
@@ -28,18 +33,16 @@
// Right justify is also simple:
// evalr str = %trim(str);
h nomain option(*NoDebugIo: *srcstmt)
/include copy_mbrs,SRV_STR_P
p CenterStr b export
d CenterStr pi 256a varying
d InStr 256a varying const
d
d blanks s 256a varying inz
d trimInStr s 256a varying
/free
ctl-opt nomain option(*nodebugio: *srcstmt);
/INCLUDE ../Copy_Mbrs/SRV_STR_P.RPGLE
dcl-proc CenterStr export;
dcl-pi CenterStr varchar(256);
InStr varchar(256) const;
end-pi;
dcl-s blanks varchar(256) inz;
dcl-s trimInStr varchar(256);
trimInStr = %trim(InStr);
// Set length to materialize required leading blanks.
%len(blanks) = %int((%len(inStr) - %len(trimInStr))/2);
%len(blanks) = %int((%len(InStr) - %len(trimInStr))/2);
return blanks + trimInStr;
/end-free
p CenterStr e
end-proc;
Service_Pgms/SRV_STRTR.RPGLE
+64 -60
View File
@@ -1,78 +1,82 @@
**free
// === Test the SRV_STR service program========================
H DftActGrp(*NO) ActGrp(*CALLER) option(*nodebugio: *srcstmt)
H BndDir('UTIL_BND')
ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
bnddir('UTIL_BND');
d X1 S 1A inz('A') One char
d X2 S 2A inz('B ') Two char
d X3 S 4A inz('C ') 3 blanks
d X4 S 5A inz('D ') 4 blanks
d X5 S 6A inz('E ') 5 blanks
d X0 S 5A inz(' ') all blank
d Xl S 20A inz('20-chars ') longer
d Xm S 21A inz(' 21-Chars') longer
d Xv S 24 inz(' 24-varying ') varying Varying-note result
d l1 S 20A inz(' ABCDE ') Left align
d l2 S 20A inz('Left already ') Left align
d r1 S 20A inz('abc') Right align
d r2 S 20A inz(' defgh ') Right align
/include copy_mbrs,SRV_STR_P
/free
x1 = tst(x1);
dsply ('-' + x1 + '-');
dcl-s X1 char(1) inz('1');
dcl-s X2 char(2) inz('2 ');
dcl-s X3 char(3) inz('3 ');
dcl-s X4 char(4) inz('4 ');
dcl-s X5 char(5) inz('5 ');
dcl-s X6 char(6) inz('6 ');
dcl-s X7 char(7) inz(' 7 ');
dcl-s X8 char(8) inz(' 8 ');
dcl-s X0 char(5) inz(' '); // all blank
dcl-s XL char(20) inz(' 20-chars'); // longer
dcl-s XM char(21) inz(' 21-Chars'); // longer
dcl-s XV varchar(20) inz('20-vary'); // Varying-fails
dcl-s XW varchar(21) inz(' 21-vary '); // Varying-fails
x2 = tst(x2);
dsply ('-' + x2 + '-');
// dcl-s l1 char(20) inz(' ABCDE '); // Left align
// dcl-s l2 char(20) inz('Left already '); // Left align
// dcl-s r1 char(20) inz('abc'); // Right align
// dcl-s r2 char(20) inz(' defgh '); // Right align
x3 = tst(x3);
dsply ('-' + x3 + '-');
/include ../Copy_Mbrs/SRV_STR_P.RPGLE
/include ../Copy_Mbrs/PRT_P.RPGLE
x4=tst(x4);
dsply ('-' + x4 + '-');
PRT('*** Testing SRV_STR Service Program ***' : '*H1');
CenterIt(X1);
CenterIt(X2);
CenterIt(X3);
CenterIt(X4);
CenterIt(X5);
x5 = tst(x5);
dsply ('-' + x5 + '-');
CenterIt(X6);
CenterIt(X7);
CenterIt(X8);
x0 = tst(x0);
dsply ('-' + x0 + '-');
CenterIt(X0);
xl = tst(xl);
dsply ('-' + xl + '-');
CenterIt(XL);
xm = tst(xm);
dsply ('-' + xm + '-');
CenterIt(XM);
xv = tst(xv);
dsply ('-' + xv + '-');
CenterIt(XV);
CenterIt(XW);
dsply ('---- Left Justify ---');
dsply ('-' + l1 + '-');
l1 =%trim(l1);
dsply ('-' + l1 + '-');
// dsply ('---- Left Justify ---');
// dsply ('-' + l1 + '-');
// l1 =%trim(l1);
// dsply ('-' + l1 + '-');
dsply ('-' + l2 + '-');
l2 =%trim(l2);
dsply ('-' + l2 + '-');
// dsply ('-' + l2 + '-');
// l2 =%trim(l2);
// dsply ('-' + l2 + '-');
dsply ('---- Right Justify ---');
dsply ('-' + r1 + '-');
evalr r1 = %trim(r1);
dsply ('-' + r1 + '-');
// dsply ('---- Right Justify ---');
// dsply ('-' + r1 + '-');
// evalr r1 = %trim(r1);
// dsply ('-' + r1 + '-');
dsply ('-' + r2 + '-');
evalr r2 = %trim(r2);
dsply ('-' + r2 + '-');
// dsply ('-' + r2 + '-');
// evalr r2 = %trim(r2);
// dsply ('-' + r2 + '-');
PRT(' ' :'*CLOSE');
*inlr = *on;
return;
/END-FREE
p tst b
d tst pi 50a varying
d II 50a varying const
/free
dsply '---------------------';
DSPLY ('-' + ii + '-');
return CenterStr(ii);
/end-free
p tst e
dcl-proc CenterIt;
dcl-pi CenterIt;
II varchar(50) const;
end-pi;
dcl-s wk varchar(50) inz;
wk = CenterStr(II);
%len(wk) = %len(II);
PRT('-1234567890123456789012345');
PRT('-' + II + '-');
PRT('-' + wk + '-');
return;
end-proc;
USPS_Address/MTNCUSTR.SQLRPGLE
+14 -14
View File
@@ -40,21 +40,22 @@
//=============================================================
ctl-opt dftactgrp(*no) actgrp(*caller) option(*nodebugio: *srcstmt)
bnddir('UTIL_BND':'ADRVAL_BND') main(main);
bnddir('UTIL_BND': 'ADRVAL_BND': 'SRV_BASE36') main(Main);
//=== Display File =============================================
dcl-f MTNCUSTD workstn infds(dfinfds) indds(dfindds) usropn;
dcl-f MTNCUSTD workstn infds(dfInfDS) indds(dfIndDS) usropn;
//=== Service Program Prototypes ===============================
/include copy_mbrs,Srv_Msg_P
/include copy_mbrs,Srv_Str_P
/include usps,USAdrVal_p
/include ../Copy_Mbrs/SRV_MSG_P.RPGLE
/include ../Copy_Mbrs/SRV_STR_P.RPGLE
/include ../Copy_Mbrs/USADRVAL_P.RPGLE
/include ../Copy_Mbrs/BASE36_P.RPGLE
//=== Named hexadecimal constants for function keys ============
/include copy_mbrs,##AIDBYTES
/include ../Copy_Mbrs/AIDBYTES.RPGLE
//=== USAdrVal Paramter DS ======================================
/include usps,USAdrvalDS
/include ../Copy_Mbrs/USADRVALDS.RPGLE
dcl-ds AdrIn likeds (USAdrValDS);
dcl-ds AdrOut likeds (USAdrValDS);
@@ -133,12 +134,9 @@ dcl-s NoErrors ind;
// === Global Fields ===========================================
dcl-s Orig_CHGTIME timestamp;
//=== Work Fields ==============================================
dcl-s wkInt int(10);
dcl-s wkMsgText varchar(256);
// === Next available customer number ==========================
dcl-s Cust_Next packed(4) dtaara('CUSTNEXT');
dcl-s Cust_Next char(4) dtaara('CUSTNEXT');
dcl-s varCust_Next varchar(4);
//=== Program Status Data Structure ============================
dcl-ds ProgStatus PSDS;
@@ -617,7 +615,9 @@ dcl-proc Main;
begsr AddRecd;
NoErrors = *on;
in *LOCK Cust_Next;
Cust_Next += 1;
varCust_Next = Cust_Next;
varCust_Next = BASE36ADD(varCust_Next);
Cust_Next = varCust_Next;
Out Cust_Next;
CUSTID= Cust_Next;
CHGTIME = %timestamp();
@@ -702,7 +702,7 @@ dcl-proc Main;
write MSGCTL;
endif;
exfmt Details;
exfmt DETAILS;
// Clear most display file indicators
clear dfIndClr;
USPS_Address/Readme.md
+1 -1
View File
@@ -32,4 +32,4 @@ If ADDRESS2 is non blank, then you have a valid address. Otherwise find a descr
### USADRVAL_T
A program to exercise USADRVAL with a some addresses, writing the input and output side by side to QSYSPRT.
A program to exercise USADRVAL with some addresses, writing the input and output side by side to QSYSPRT.
USPS_Address/USADRVAL.SQLRPGLE
+2 -2
View File
@@ -27,10 +27,10 @@ ctl-opt
option(*nodebugio: *srcstmt)
;
//=== Prototypes =====================================================
/copy copy_mbrs,Srv_SQL_P
/copy ../Copy_Mbrs/SRV_SQL_P.RPGLE
//=== Parameter Data Structure Template ==============================
/copy copy_mbrs,USAdrValDS
/copy ../Copy_Mbrs/USADRVALDS.RPGLE
// === Data area containing your USPS supplied User id. ==============
// (The USPS supplied USER ID length is not clear, so I made it
USPS_Address/USADRVAL_T.RPGLE
+3 -3
View File
@@ -7,9 +7,9 @@ ctl-opt debug option(*nodebugio: *srcstmt)
// Program to exercise USADRVAL.
// Results are printed to QSYSPPRT.
//====================================================================
/copy copy_mbrs,USAdrValDS
/copy copy_mbrs,Srv_Msg_P
/copy copy_mbrs,USAdrVal_p
/copy ../Copy_Mbrs/USADRVALDS.RPGLE
/copy ../Copy_Mbrs/SRV_MSG_P.RPGLE
/copy ../Copy_Mbrs/USADRVAL_P.RPGLE
dcl-f qsysprt printer(132) usropn;
image-1.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 13 KiB

image-2.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 8.6 KiB

image.png
BIN
View File
Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 15 KiB