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
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