* * (C) COPYRIGHT IBM CORP, 1998, 1999 - ALL RIGHTS RESERVED. * * * QueryENQ - Version 2.00 * * Function: * This is a rexx function and it sets rexx variables * variables. * Function to return ENQ status on a data set or any * rname/Qname or to return ENQ contention information * * Syntax (Any of the following): * Call QueryENQ rname * call QueryENQ rname,qname * xx=QueryENQ(rname) * xx=QueryENQ(rname,qname) * call QueryENQ 'contention' * * Rname is assumed to be a data set name that follows tso naming * Conventions. If it is not in quotes, the user prefix * will be added. If qname is specified and is not sysdsn * then the rname is not treated as a tso style ds name. * * If rname is 'contention' all system ENQs causing * contention are returned. When rname = Contention, * qname must not be specified. The word 'contention' can * be in any mixed case. * * Qname is the major name of the ENQ to be queried. * * Output variables: * ENQJOB.N stem variable containing jobs ENQUEUED to a * Resource. * * ENQTYPE.N ENQ information for the corresponding request. * Col 1-3 'shr' or 'old' * Col 5-8 'own ' or 'wait' * Col 10-17 'system ', 'systems', or 'nonsys ' * Col 10-17 'system ', 'systems', or 'nonsys ' * Col 19-25 'step ' or 'nonstep' * Col 27-34 System name on which request was made * * ENQQNAME.N stem variable containing corresponding qname * * ENQRNAME.N stem variable containing corresponding rname. This * Is a data set name if ENQQNAME.N is sysdsn. * * Rc and result values: * RC=0 RESULT='OK' * RC=16 RESULT='TOO MANY PARAMETERS' * RC=20 RESULT='RNAME NOT SPECIFIED' * * Installation: * Assemble amode(31),rmode(any). Place load module in any * accessable load library. * * Samples: * * Say center(' ENQs on SYS1.BROADCAST ',78,'-') * s = queryenq("'SYS1.BRODCAST'") * Do a = 1 to ENQJOB.0 * Say ENQJOB.a ENQTYPE.a * End * * Say center(' ISPF edits of CLIST(MEMBER) ',78,'-') * s = queryenq(left(userid()'.CLIST',44)||'MEMBER ','SPFEDIT') * Do a = 1 to ENQJOB.0 * Say ENQJOB.a ENQTYPE.a ENQRNAME.a * End * * Say center(' ENQ Contention ',78,'-') * Call queryenq 'contention' * If ENQJOB.0 > 0 Then * Do a = 1 to min(10, ENQJOB.0) * Say ENQJOB.a ENQTYPE.a ENQQNAME.a ENQRNAME.a * End * Else * Say 'No ENQ contention exists on this system.' * * Author information: * Doug Nadel - nadel@us.ibm.com * * Version information * 1.00 - Nov , 1998 - Initial release * 2.00 - July 1, 1999 - Added contention and ENQQNAME/ENQRNAME * * ------------------------------------------------------------------ * *QueryENQ: * proc (p1,p2,p3,p4,efplparm,evalparm) options(amode(31),rmode(24), * datanum(3),reentrant,autodata(loc(below))); *@list off; *%INCLUDE syslib(cvt); *%INCLUDE syslib(ikjtcb ); *%INCLUDE syslib(isgrib); *%INCLUDE syslib(ikjpscb); *%INCLUDE syslib(iezjscb); *%INCLUDE syslib(ikjupt); *%INCLUDE syslib(irxshvb); *%INCLUDE syslib(irxevalb); *@list on; * dcl * 1 efplparm(*), /* Input parms */ * 3 parma ptr, /* Parm address */ * 3 parml fixed, /* Parm length */ * evalparm ptr(31); /* Ptr to eval block */ * dcl * dataset char(46), /* 44+2 For quotes */ * tempdataset char(44), /* Area for dsname resolution */ * cvtptr ptr(31) location(16), /* Pointer to cvt */ * pscbptr ptr(31), /* Pointer to pscb */ * uptptr ptr(31), /* Pointer to upt */ * tcbptr ptr(31), /* Pointer to tcb */ * ENQRC fixed, /* Retcode from routine */ * spfctnw char(8) boundary(dword), /* Work area for conversion */ * spfctnx char(16), /* Work area for conversion */ * count fixed, /* Count of found ENQs */ * shvcount fixed, /* Count of used shvblocks */ * prefix char(8), /* Tso prefix */ * varnum char(8) bdy(dword), /* Conversion area */ * countc char(8) bdy(dword), /* Ebcdic representation of count*/ * r0save ptr(31), /* Original register zero (R0) */ * 1 allblocks(8192/(16+34+60+length(shvblock))) bdy(dword), * 3 struc char(length(shvblock)), * 3 ENQTYPE, * 5 shrold char(3), * 5 * char(1), * 5 ownwait char(4), * 5 * char(1), * 5 scope char(8), * 5 * char(1), * 5 step char(7), * 5 * char(1), * 5 system char(8), * 3 varname char(16), /* Var names for rexx store */ * 3 varrname char(52), /* Misc var val */ * 5 varqname char(8), /* Misc var val */ * 7 varval char(8), /* Misc var val */ * emcomp ptr(31), /* Pointer to module irxemcom */ * emcom internal entry based(emcomp) valrg(*) options(vlist), * r0 reg(0) pointer(31), /* Register definitions */ * r1 reg(1) pointer(31), * r2 reg(2) pointer(31), * r3 reg(3) pointer(31), * r4 reg(4) pointer(31), * r14 reg(14) pointer(31), * r15 reg(15) pointer(31), * on bit(1) constant('1'B), /* Test or set switch on */ * off bit(1) constant('0'B), /* Test or set switch off */ * parray(*) ptr(31) based, /* Any pointer array */ * chars character(*) based; /* Any character string */ * dcl * 1 qnrn, * 3 rname char(120), /* Rname to look for */ * 3 qname char(8), /* Qname to look for */ * dsnl fixed, /* Length of dsname */ * gqareap ptr(31), /* Address of the rib/Ribe area */ * gqarea char(32768) bdy(dword) based(gqareap),/* Rib/Ribe area*/ * token fixed abnl, /* Token for use by gqscan */ * ribptr ptr(31), /* Pointer to rib */ * ribeptr ptr(31), /* Pointer to ribe */ * ribcnt fixed(31), /* No of ribes per rib */ * blockp ptr, /* Ptr to shvblock */ * contention bit(1), /* Looking for contention */ * writeall bit(1), /* Force variable writes */ * 1 locrlens bdy(word), /* Returned r0 from gqscan */ * 3 riblen fixed(15), * 3 ribelen fixed(15), * a fixed(31), /* General counter */ * b fixed(31), /* General counter */ * i fixed(31), * gqscanrc fixed(31), /* Retcode from gqscan */ * gqlst char(*) gend, /* Dynamic area gqscan */ * gqparm char(*) gend static; /* Static area gqscan */ * GEN DATA DEFS (GQLST); /* */ *GQLST GQSCAN RESNAME=(*-*,*-*,*-*),AREA=(*-*,32768),SCOPE=ALL, X * TOKEN=*-*,REQLIM=MAX,MF=L /* */ *@ENDGEN; /* */ * GEN DATA DEFS (GQPARM); /* */ *GQPARM GQSCAN RESNAME=(*-*,*-*,*-*),AREA=(*-*,32768),SCOPE=ALL, X * TOKEN=*-*,REQLIM=MAX,MF=L /* */ *GQPARML EQU *-GQPARM /* */ * DS 0D /* */ *@ENDGEN; /* */ * rfy * ribvar based(addr(ribend)); * rfy * tcb based(cvttcbp->parray(1)), * pscb based(jscbpscb), * upt based(pscbupt), * shvblock based(blockp), * evalblock based(evalparm), * (r0, * r1, * r14, * r15) rstd; * * /*****************************************************************/ * /* */ * /* Setup */ * /* */ * /*****************************************************************/ * * r0save = r0; * dataset = ''; /* Assume no dataset name given */ * ENQRC = 0; /* Assume no other errors */ * count = 0; /* No ENQs yet */ * shvcount = 0; /* No blocks used yet */ * contention = off; /* Assume not looking for * contention */ * prefix(1) = ' '; /* Assume no tso prefix */ * writeall = off; * if jscbpscb then * if pscbupt then * if uptprefl then /* If user has a tso prefix */ * prefix = uptprefx(1:uptprefl); /* Get tso prefix */ * * /*****************************************************************/ * /* */ * /* Start of mainline code */ * /* */ * /*****************************************************************/ * * GEN SETS (R1,R0,R14,R15) (LOAD EP=IRXEXCOM); /* LOAD IRXEXCOM */ * emcomp = r0; /* Save address for later calls */ * * /*****************************************************************/ * /* */ * /* Drop ENQJOB. To clear the whole stem variable */ * /* */ * /*****************************************************************/ * * call next_block; * shvcode = shvdropv; /* Drop variable */ * shvnaml = 7; /* Name length */ * shvnama = addr('ENQJOB.'); /* Variable name (Stem) */ * call next_block; * shvcode = shvdropv; /* Drop variable */ * shvnaml = 9; /* Name length */ * shvnama = addr('ENQRNAME.'); /* Variable name (Stem) */ * call next_block; * shvcode = shvdropv; /* Drop variable */ * shvnaml = 9; /* Name length */ * shvnama = addr('ENQQNAME.'); /* Variable name (Stem) */ * call next_block; /* Go to next block */ * shvcode = shvdropv; /* Drop variable */ * shvnaml = 8; /* Name length */ * shvnama = addr('ENQTYPE.'); /* Variable name (Stem) */ * * /*****************************************************************/ * /* */ * /* Get data set name using tso conventions. */ * /* */ * /*****************************************************************/ * * if parma(1) = 'FFFFFFFF'X then * ENQRC = 20; /* Too few parms */ * else * if (parma(2) ^= 'FFFFFFFF'X & parma(3) ^= 'FFFFFFFF'X) then * ENQRC = 16; /* Too many parms */ * if ENQRC = 0 & /* No error yet */ * parma(1) ^= 'FFFFFFFF'X & parml(1) <= length(rname) & parml(1) > * 0 then * do; * if parma(2) = 'ffffffff'X | parml(2) = 0 | 'SYSDSN ' = parma(2 * ) -> chars(1:min(parml(2),8)) then * do; * qname = 'SYSDSN '; /* */ * rname = parma(1) -> chars(1:parml(1)); * rname = translate(rname, /* Upper case data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', * 'abcdefghijklmnopqrstuvwxyz'); * if 'CONTENTION' = translate(rname(1:10), /* Upper case * data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz' * ) then * do; * contention = on; * qnrn = ''; * dsnl = length(rname); * end; * else * do; * if rname(1) = '''' then /* If fully qualified */ * do; /* Set rname for svc 99 */ * mvc(rname(1::44),rname(2::44)); /* Remove left * quote */ * i = index(rname,''''); /* Find right quote */ * if i > 0 then /* If a trailing quote exists */ * rname(i) = ' '; /* Remove right quote */ * end; * else /* Must add prefix */ * if prefix(1) ^= ' ' then /* If prefix exists */ * do; * tempdataset = ''; /* Start with blank */ * tempdataset = prefix; * tempdataset(uptprefl+1) = '.'; /* Add dot */ * tempdataset(uptprefl+2:length(tempdataset)) = * rname; * rname = tempdataset; /* Save over original */ * end; * dsnl = index(rname,' ') - 1; /* */ * end; * end; * else * do; * rname = parma(1) -> chars(1:min(parml(1),length(rname))); * qname = parma(2) -> chars(1:min(parml(2),8)); * dsnl = parml(1); * end; * if qname = 'SPFUSER' then * dsnl = 7; * r0 = length(gqarea); * GEN SETS (R1,R0,R14,R15) REFS (R0) * (GETMAIN RU,LV=(0),LOC=BELOW); * gqareap = r1; *@eject; * * /*************************************************************/ * /* */ * /* Main processing section */ * /* */ * /*************************************************************/ * * gqscanrc = 8; /* Start with good return code */ * token = 0; /* Set up for gqscan */ * do while(gqscanrc=8); /* Loop while ENQUEUES found */ * gqarea = ''X; * call findribs; * if (gqscanrc ^= 4 & gqscanrc < 9) then /* If ENQs found */ * do a = 1 to ribcnt; /* Loop through ENQUEUES */ * ribeptr = ribptr + ribvlen + riblen; /* First ribe */ * if /* */ * contention = on /* Looking for contention */ * | /* */ * (ribrnmln = dsnl & /* If dsname same length */ * (ribrname(1:dsnl) /* And they match */ * = rname(1:dsnl) /* */ * & ribqname = qname)) then * do b = 1 to ribnribe; /* Loop through all ribes */ * *! if contention = off /* */ *! | (contention = on /* Looking only for *! Contention */ *! & (ribntwe ^= 0 | ribntws ^= 0)) /* And waiters *! Exist */ *! then * * do; * call next_block; /* Go to next block */ * count = count + 1; * cvd(count,spfctnw); /* Var ENQJOB.COUNT */ * unpk(spfctnx,spfctnw); * spfctnx(16) = spfctnx(16) | 'F0'X; * varnum = spfctnx(17-length(varnum):16); * i = verify(varnum,'0'); * varname(shvcount) = 'ENQJOB.'; * varname(shvcount,8::9-i) = varnum(i::9-i); * shvcode = shvstore; * shvnaml = 16 - i; * shvnama = addr(varname(shvcount)); * varval(shvcount) = ribejbnm; * shvvala = addr(varval(shvcount)); * shvvall = length(ribejbnm); * shvret = 'ff'X; * *! * * call next_block; /* Go to next block */ * varname(shvcount) = 'ENQQNAME.'; * varname(shvcount,10::9-i) = varnum(i::9-i); * shvcode = shvstore; * shvnaml = 18 - i; * shvnama = addr(varname(shvcount)); * shvvala = addr(varqname(shvcount)); * shvvall = length(varqname); * varqname(shvcount) = ribqname; * shvret = 'ff'X; * *! * * call next_block; /* Go to next block */ * varname(shvcount) = 'ENQRNAME.'; * varname(shvcount,10::9-i) = varnum(i::9-i); * shvcode = shvstore; * shvnaml = 18 - i; * shvnama = addr(varname(shvcount)); * shvvala = addr(varrname(shvcount)); * shvvall = min(length(varrname),ribrnmln); * varrname(shvcount) = ribrname(1:min(length(varrname * ),ribrnmln)); * shvret = 'ff'X; * *! * * call next_block; /* Go to next block */ * varname(shvcount) = 'ENQTYPE.'; * varname(shvcount,9::9-i) = varnum(i::9-i); * shvcode = shvstore; * shvnaml = 17 - i; * shvnama = addr(varname(shvcount)); * shvvala = addr(ENQTYPE(SHVCOUNT)); * shvvall = length(ENQTYPE); * shvret = 'ff'X; * if ribetype then /* Check shr/Old status */ * shrold(shvcount) = 'SHR'; * else * shrold(shvcount) = 'OLD'; * if ribestat then /* User is owner */ * ownwait(shvcount) = 'OWN '; * else * ownwait(shvcount) = 'WAIT'; * if ribsyss then * scope(shvcount) = 'SYSTEMS'; * else * if ribsys then * scope(shvcount) = 'SYSTEM'; * else * scope(shvcount) = 'NONSYS'; * system(shvcount) = ribesysn; * if ribstep then * step(shvcount) = 'STEP'; * else * step(shvcount) = 'NONSTEP'; * ribeptr = ribeptr + ribelen; /* Next ribe */ * end; * end; * ribptr = ribptr + riblen + ribvlen + (ribnribe * ribelen) * ; * end; * end; * r1 = gqareap; * r0 = length(gqarea); * GEN(FREEMAIN RU,LV=(0),A=(1)); * end; * else /* Parameter error */ * if ENQRC = 0 then /* No code yet */ * ENQRC = 20; /* Invalid dsname supplied */ * * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable ENQRC */ * /* */ * /*****************************************************************/ * * call next_block; /* Go to next block */ * cvd(count,spfctnw); * unpk(spfctnx,spfctnw); * spfctnx(16) = spfctnx(16) | 'F0'X; * countc = spfctnx(17-length(countc):16); * i = verify(countc,'0'); * if i = 0 then * i = 8; * varname(shvcount) = ''; * varname(shvcount,1::9-i) = countc(i::9-i); * countc = varname(shvcount,1::9-i); * shvcode = shvstore; * shvnama = addr('ENQJOB.0'); * shvnaml = 8; * shvvala = addr(countc); * shvvall = 9 - i; * call next_block; /* Go to next block */ * shvcode = shvstore; * shvnama = addr('ENQTYPE.0'); * shvnaml = 9; * shvvala = addr(countc); * shvvall = 9 - i; * call next_block; /* Go to next block */ * shvcode = shvstore; * shvnama = addr('ENQRNAME.0'); * shvnaml = 10; * shvvala = addr(countc); * shvvall = 9 - i; * call next_block; /* Go to next block */ * shvcode = shvstore; * shvnama = addr('ENQQNAME.0'); * shvnaml = 10; * shvvala = addr(countc); * shvvall = 9 - i; * * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable ENQRC */ * /* */ * /*****************************************************************/ * * call next_block; /* Go to next block */ * cvd(ENQRC,SPFCTNW); * unpk(spfctnx,spfctnw); * spfctnx(16) = spfctnx(16) | 'F0'X; * varnum = spfctnx(17-length(varnum):16); * i = verify(varnum,'0'); * if i = 0 then * i = 8; * varname(shvcount) = ''; * varname(shvcount,1::9-i) = varnum(i::9-i); * varnum = varname(shvcount,1::9-i); * shvcode = shvstore; * shvnaml = 2; * shvnama = addr('RC'); * shvvala = addr(varnum); * shvvall = 9 - i; * writeall = on; * call next_block; /* Go to next block */ *next_block: * proc; /* Go to next block */ * if shvcount = 0 then * do; * substrlen(addr(allblocks)->chars(1:length(allblocks)*dim( * allblocks)),32K) = ''B; * blockp = addr(struc(1)); * end; * if shvcount < dim(allblocks) then * if writeall = off then * do; * if shvcount ^= 0 then * shvnext = addr(allblocks(shvcount+1)); * shvcount = shvcount + 1; * end; * else * ; * else * writeall = on; * if writeall = on then * do; * r0 = r0save; * call emcom('IRXEXCOM',0,0,allblocks); * shvcount = 0; * writeall = off; * substrlen(addr(allblocks)->chars(1:length(allblocks)*dim( * allblocks)),32K) = ''B; * shvcount = 1; * end; * blockp = addr(allblocks(shvcount)); * end next_block; * GEN(DELETE EP=IRXEXCOM); /* REMOVE IRXEXCOM FROM STORAGE */ * rfy * (r0, * r1, * r14, * r15); * * /*****************************************************************/ * /* */ * /* Set variable 'result' or function return */ * /* */ * /*****************************************************************/ * * select (ENQRC); * when (0) * do; * evalblock_evlen = 2; /* Set result to 'ok' */ * evalblock_evdata(1:2) = 'OK'; * end; * when (16) * do; * evalblock_evlen = 19; * evalblock_evdata(1:24) = 'TOO MANY PARAMETERS'; * end; * when (20) * do; * evalblock_evlen = 24; * evalblock_evdata(1:24) = 'RNAME NOT SPECIFIED'; * end; * otherwise * do; * evalblock_evlen = 5; * evalblock_evdata(1:5) = 'ERROR'; * end; * end; * return code(0); /* Always return code zero */ *@eject; * * /*****************************************************************/ * /* */ * /* Findribs : Routine to get the rib control blocks */ * /* */ * /*****************************************************************/ * *findribs: * proc; * rfy * (r0, * r1, * r2, * r3, * r4, /* */ * r14, * r15) rstd; * */*** The following line deleted for ***********************/ */* Gqlst(1:47) = Gqparm(1:47): ** Copy macro expansion to */ */* Dynamic storage */ * * r2 = gqareap; * ribptr = r2; /* Ptr to first rib */ * r3 = length(gqarea); * */*** The following lines changed for **********************/ */* Gen refs (R2,r3) sets (R0,r1,r14) */ */* (Gqscan area=((2),(3)),token=Token,reqlim=Max,mf=(E,gqlst)): */ * * GEN CODE ( MVC GQLST(GQPARML),GQPARM ); * if contention = on then * do; * r4 = 0; * GEN REFS (R2,R3,R4,TOKEN,GQPARM,QNAME,RNAME) SETS (R0,R1,R14, * GQLST,TOKEN); /* */ * GQSCAN RESNAME=(QNAME,RNAME,(R4),GENERIC,0),AREA=((2),(3)), C * TOKEN=TOKEN,REQLIM=MAX,MF=(E,GQLST), X * SCOPE=ALL,WAITCNT=1 *@ENDGEN; * end; * else * do; * r4 = dsnl; /* Set length of rname */ * GEN REFS (R2,R3,R4,TOKEN,GQPARM,QNAME,RNAME) SETS (R0,R1,R14, * GQLST,TOKEN); /* */ * GQSCAN RESNAME=(QNAME,RNAME,(R4)),AREA=((2),(3)),SCOPE=ALL, X * TOKEN=TOKEN,REQLIM=MAX,MF=(E,GQLST) /* */ *@ENDGEN; * end; * gqscanrc = r15; * locrlens = r0; /* Save rib length (1St half word * of r0) and ribe length (2Nd * half word of r0) in variables * riblen and ribelen * respectively */ * ribcnt = r1; /* Save number of ribs returned */ * rfy * (r0, * r1, * r2, * r3, * r4, /* */ * r14, * r15); * end findribs; * end QueryENQ; *---------------------------------------------------------------------* *-------------------- Assembler code starts below --------------------* *---------------------------------------------------------------------* TITLE ' /* (C) COPYRIGHT IBM CORP, 1998, 1999 - ALL RIGHTS RES* ERVED.' QUERYENQ CSECT , QUERYENQ AMODE 31 QUERYENQ RMODE 24 STM 14,12,12(13) LR 12,15 USING QUERYENQ,12 LA 15,0 L 0,DSECT_SZ+4 GETMAIN RU,LV=(0),SP=(15), * LOC=BELOW LR 11,1 LA 10,4095(,11) LA 9,4095(,10) USING @DATD,11 USING @DATD+4095,10 USING @DATD+8190,9 ST 13,4(,11) ST 11,8(,13) LM 15,1,16(13) LR 13,11 MVC INPUTPTRS1(24),0(1) * * /*****************************************************************/ * /* */ * /* Setup */ * /* */ * /*****************************************************************/ * * r0save = r0; ST 0,R0SAVE * dataset = ''; /* Assume no dataset name given */ MVI DATASET,C' ' MVC DATASET+1(45),DATASET * ENQRC = 0; /* Assume no other errors */ SLR 2,2 ST 2,ENQRC * count = 0; /* No ENQs yet */ ST 2,COUNT * shvcount = 0; /* No blocks used yet */ ST 2,SHVCOUNT * contention = off; /* Assume not looking for * contention */ NI CONTENTION,B'01111111' * prefix(1) = ' '; /* Assume no tso prefix */ MVI PREFIX,C' ' * writeall = off; NI WRITEALL,B'01111111' * IF jscbpscb THEN L 3,16 L 4,0(,3) L 5,0(,4) L 2,180(,5) ICM 6,15,260+4(2) BZ LABEL_1 * IF pscbupt THEN ICM 7,15,52(6) BZ LABEL_1 * IF uptprefl THEN /* If user has a tso prefix */ SLR 8,8 IC 8,23(,7) LTR 8,8 BZ LABEL_1 * prefix = uptprefx(1:uptprefl); /* Get tso prefix */ * MVI PREFIX+1,C' ' MVC PREFIX+2(6),PREFIX+1 LR 2,8 BCTR 2,0 EX 2,INSTRUCTION1 -> MVC PREFIX(0),16(7) * /*****************************************************************/ * /* */ * /* Start of mainline code */ * /* */ * /*****************************************************************/ * * GENERATE SETS (R1,R0,R14,R15) (LOAD EP=IRXEXCOM); /* LOAD * IRXEXCOM */ LABEL_1 DS 0H LOAD EP=IRXEXCOM * emcomp = r0; /* Save address for later calls */ * ST 0,EMCOMP * /*****************************************************************/ * /* */ * /* Drop ENQJOB. To clear the whole stem variable */ * /* */ * /*****************************************************************/ * * CALL next_block; BAL 14,NEXT_BLOCK * shvcode = shvdropv; /* Drop variable */ L 8,BLOCKP MVI 8(8),C'D' * shvnaml = 7; /* Name length */ LA 2,7 ST 2,20(,8) * shvnama = addr('ENQJOB.'); /* Variable name (Stem) */ LA 3,=CL16'ENQJOB.' ST 3,16(,8) * CALL next_block; BAL 14,NEXT_BLOCK * shvcode = shvdropv; /* Drop variable */ L 8,BLOCKP MVI 8(8),C'D' * shvnaml = 9; /* Name length */ LA 2,9 ST 2,20(,8) * shvnama = addr('ENQRNAME.'); /* Variable name (Stem) */ LA 3,=CL16'ENQRNAME.' ST 3,16(,8) * CALL next_block; BAL 14,NEXT_BLOCK * shvcode = shvdropv; /* Drop variable */ L 8,BLOCKP MVI 8(8),C'D' * shvnaml = 9; /* Name length */ LA 2,9 ST 2,20(,8) * shvnama = addr('ENQQNAME.'); /* Variable name (Stem) */ LA 3,=CL16'ENQQNAME.' ST 3,16(,8) * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * shvcode = shvdropv; /* Drop variable */ L 7,BLOCKP MVI 8(7),C'D' * shvnaml = 8; /* Name length */ LA 8,8 ST 8,20(,7) * shvnama = addr('ENQTYPE.'); /* Variable name (Stem) */ * LA 8,=CL16'ENQTYPE.' ST 8,16(,7) * /*****************************************************************/ * /* */ * /* Get data set name using tso conventions. */ * /* */ * /*****************************************************************/ * * IF parma(1) = 'FFFFFFFF'X THEN L 6,INPUTPTRS1+16 CLC 0(4,6),=X'FFFFFFFF' BNE LABEL_2 * ENQRC = 20; /* Too few parms */ LA 7,20 ST 7,ENQRC * ELSE * IF (parma(2) ^= 'FFFFFFFF'X & parma(3) ^= 'FFFFFFFF'X) THEN B LABEL_3 LABEL_2 SLR 8,8 BCTR 8,0 CL 8,8(,6) BE LABEL_3 CL 8,16(,6) BE LABEL_3 * ENQRC = 16; /* Too many parms */ LA 7,16 ST 7,ENQRC * IF ENQRC = 0 & /* No error yet */ * parma(1) ^= 'FFFFFFFF'X & parml(1) <= length(rname) & parml(1) > * 0 THEN LABEL_3 ICM 2,15,ENQRC BNZ LABEL_31 SLR 3,3 BCTR 3,0 CL 3,0(,6) BE LABEL_31 L 7,4(,6) LA 2,120 CR 7,2 BH LABEL_31 LTR 7,7 BNP LABEL_31 * DO; * IF parma(2) = 'ffffffff'X | parml(2) = 0 | 'SYSDSN ' = parma(2 * ) -> chars(1:min(parml(2),8)) THEN L 2,8(,6) CLR 2,3 BE LABEL_5 ICM 3,15,4+8(6) BZ LABEL_5 LA 8,8 CR 3,8 BNH LABEL_4 LR 3,8 LABEL_4 BCTR 3,0 LR 8,3 MVI TEMPSTRING1+8,C' ' MVC TEMPSTRING1+9(247),TEMPSTRING1+8 MVC TEMPSTRING1(8),=CL8'SYSDSN ' MVI TEMPSTRING1+257,C' ' MVC TEMPSTRING1+258(254),TEMPSTRING1+257 EX 8,INSTRUCTION2 -> MVC TEMPSTRING1+256(0),0(2) CLC TEMPSTRING1(256),TEMPSTRING1+256 BNE LABEL_11 LABEL_5 DS 0H * DO; * qname = 'SYSDSN '; /* */ MVC QNAME(8),=CL8'SYSDSN ' * rname = parma(1) -> chars(1:parml(1)); L 8,0(,6) MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(254),TEMPSTRING1+1 LR 2,7 BCTR 2,0 EX 2,INSTRUCTION3 -> MVC TEMPSTRING1(0),0(8) MVC RNAME(120),TEMPSTRING1 * rname = translate(rname, /* Upper case data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ', * 'abcdefghijklmnopqrstuvwxyz'); LA 8,25 MVC TEMPSTRING1+120(256),TRTAB1 SLR 2,2 SLR 3,3 LABEL_6 IC 3,=CL26'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(8) IC 2,=CL26'abcdefghijklmnopqrstuvwxyz'(8) STC 3,TEMPSTRING1+120(2) BCTR 8,0 LTR 8,8 BNM LABEL_6 MVC TEMPSTRING1(120),RNAME TR TEMPSTRING1(120),TEMPSTRING1+120 MVC RNAME(120),TEMPSTRING1 * IF 'CONTENTION' = translate(rname(1:10), /* Upper case * data set name */ * 'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz * ) THEN LA 8,25 MVC TEMPSTRING1+10(256),TRTAB1 SLR 2,2 SLR 3,3 LABEL_7 IC 3,=CL26'ABCDEFGHIJKLMNOPQRSTUVWXYZ'(8) IC 2,=CL26'abcdefghijklmnopqrstuvwxyz'(8) STC 3,TEMPSTRING1+10(2) BCTR 8,0 LTR 8,8 BNM LABEL_7 MVC TEMPSTRING1(10),RNAME TR TEMPSTRING1(10),TEMPSTRING1+10 CLC =CL10'CONTENTION'(10),TEMPSTRING1 BNE LABEL_8 * DO; * contention = on; OI CONTENTION,B'10000000' * qnrn = ''; MVI QNRN,C' ' * dsnl = length(rname); LA 8,120 ST 8,DSNL * END; * ELSE * DO; B LABEL_13 LABEL_8 DS 0H * IF rname(1) = '''' THEN /* If fully qualified */ CLI RNAME,C'''' BNE LABEL_9 * DO; /* Set rname for svc 99 */ * mvc(rname(1::44),rname(2::44)); /* Remove left * quote */ MVC RNAME(44),RNAME+1 * i = index(rname,''''); /* Find right quote */ XC TEMPSTRING1(256),TEMPSTRING1 SLR 8,8 IC 8,=CL1'''' LA 2,TEMPSTRING1(8) MVI 0(2),X'01' LR 8,1 LA 1,RNAME LR 3,1 SLR 2,2 TRT 0(120,1),TEMPSTRING1 ALR 1,2 LCR 3,3 ALR 3,1 LR 1,8 ST 3,I * IF i > 0 THEN /* If a trailing quote exists */ LTR 3,3 BNP LABEL_10 * rname(i) = ' '; /* Remove right quote */ LA 8,RNAME-1(3) MVI 0(8),C' ' * END; * ELSE /* Must add prefix */ * IF prefix(1) ^= ' ' THEN /* If prefix exists */ B LABEL_10 LABEL_9 CLI PREFIX,C' ' BE LABEL_10 * DO; * tempdataset = ''; /* Start with blank */ MVI TEMPDATASET,C' ' MVC TEMPDATASET+1(43),TEMPDATASET * tempdataset = prefix; MVI TEMPDATASET+8,C' ' MVC TEMPDATASET+9(35),TEMPDATASET+8 MVC TEMPDATASET(8),PREFIX * tempdataset(uptprefl+1) = '.'; /* Add dot */ L 2,16 L 3,0(,2) L 4,0(,3) L 5,180(,4) L 8,260+4(,5) L 7,52(,8) SLR 6,6 IC 6,23(,7) LA 2,TEMPDATASET(6) MVI 0(2),C'.' * tempdataset(uptprefl+2:length(tempdataset)) = * rname; LA 3,TEMPDATASET+1(6) LA 2,42 SLR 2,6 EX 2,INSTRUCTION4 -> MVC 0(0,3),RNAME * rname = tempdataset; /* Save over original */ MVI RNAME+44,C' ' MVC RNAME+45(75),RNAME+44 MVC RNAME(44),TEMPDATASET * END; * dsnl = index(rname,' ') - 1; /* */ LABEL_10 XC TEMPSTRING1(256),TEMPSTRING1 SLR 8,8 IC 8,=CL1' ' LA 2,TEMPSTRING1(8) MVI 0(2),X'01' LR 8,1 LA 1,RNAME LR 3,1 SLR 2,2 TRT 0(120,1),TEMPSTRING1 ALR 1,2 LCR 3,3 ALR 3,1 LR 1,8 BCTR 3,0 ST 3,DSNL * END; * END; * ELSE * DO; B LABEL_13 LABEL_11 DS 0H * rname = parma(1) -> chars(1:min(parml(1),length(rname))); L 4,0(,6) MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(254),TEMPSTRING1+1 LA 5,120 CR 5,7 BNH LABEL_12 LR 5,7 LABEL_12 BCTR 5,0 EX 5,INSTRUCTION5 -> MVC TEMPSTRING1(0),0(4) MVC RNAME(120),TEMPSTRING1 * qname = parma(2) -> chars(1:min(parml(2),8)); L 2,8(,6) MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(254),TEMPSTRING1+1 EX 8,INSTRUCTION6 -> MVC TEMPSTRING1(0),0(2) MVC QNAME(8),TEMPSTRING1 * dsnl = parml(1); ST 7,DSNL * END; * IF qname = 'SPFUSER' THEN LABEL_13 CLC QNAME(8),=CL8'SPFUSER' BNE LABEL_14 * dsnl = 7; LA 8,7 ST 8,DSNL * r0 = length(gqarea); LABEL_14 L 0,=F'32768' * GENERATE SETS (R1,R0,R14,R15) REFS (R0) * (GETMAIN RU,LV=(0),LOC=BELOW); GETMAIN RU,LV=(0),LOC=BELOW * gqareap = r1; ST 1,GQAREAP * * /*************************************************************/ * /* */ * /* Main processing section */ * /* */ * /*************************************************************/ * * gqscanrc = 8; /* Start with good return code */ LA 6,8 * token = 0; /* Set up for gqscan */ SLR 7,7 ST 7,TOKEN * DO while(gqscanrc=8); /* Loop while ENQUEUES found */ LABEL_15 DS 0H * gqarea = ''X; L 8,GQAREAP LA 2,0(,8) L 3,=F'32768' LA 4,@CB00176 LA 5,0 MVCL 2,4 * CALL findribs; BAL 14,FINDRIBS * IF (gqscanrc ^= 4 & gqscanrc < 9) THEN /* If ENQs found */ L 8,GQSCANRC LA 3,4 CR 8,3 BE LABEL_30 LA 5,9 CR 8,5 BNL LABEL_30 * DO a = 1 to ribcnt; /* Loop through ENQUEUES */ LA 8,1 ST 8,A C 8,RIBCNT BH LABEL_30 LABEL_16 DS 0H * ribeptr = ribptr + ribvlen + riblen; /* First ribe */ L 8,RIBPTR LH 2,28(,8) ALR 2,8 AH 2,RIBLEN ST 2,RIBEPTR * IF /* */ * contention = on /* Looking for contention */ * | /* */ * (ribrnmln = dsnl & /* If dsname same length */ * (ribrname(1:dsnl) /* And they match */ * = rname(1:dsnl) /* */ * & ribqname = qname)) THEN TM CONTENTION,B'10000000' BO LABEL_17 L 3,DSNL SLR 2,2 IC 2,31(,8) CR 3,2 BNE LABEL_29 BCTR 3,0 EX 3,INSTRUCTION7 -> CLC 40(0,8),RNAME BNE LABEL_29 CLC 32(8,8),QNAME BNE LABEL_29 LABEL_17 DS 0H * DO b = 1 to ribnribe; /* Loop through all ribes */ * LA 8,1 ST 8,B L 2,RIBPTR C 8,24(,2) BH LABEL_29 LABEL_18 DS 0H *! if contention = off /* */ *! | (contention = on /* Looking only for *! Contention */ *! & (ribntwe ^= 0 | ribntws ^= 0)) /* And waiters *! Exist */ *! then * * DO; * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * count = count + 1; LA 6,1 AL 6,COUNT ST 6,COUNT * cvd(count,spfctnw); /* Var ENQJOB.COUNT */ CVD 6,SPFCTNW * unpk(spfctnx,spfctnw); UNPK SPFCTNX(16),SPFCTNW(8) * spfctnx(16) = spfctnx(16) | 'F0'X; OI SPFCTNX+15,X'F0' * varnum = spfctnx(17-length(varnum):16); MVC VARNUM(8),SPFCTNX+8 * i = verify(varnum,'0'); MVI TEMPSTRING1,X'01' MVC TEMPSTRING1+1(255),TEMPSTRING1 SLR 8,8 IC 8,=CL1'0' LA 6,TEMPSTRING1(8) MVI 0(6),X'00' LR 8,1 LA 1,VARNUM LR 6,1 SLR 2,2 TRT 0(8,1),TEMPSTRING1 ALR 1,2 LCR 6,6 ALR 6,1 LR 1,8 LR 8,6 * varname(shvcount) = 'ENQJOB.'; LA 6,VARNAME-136(7) MVC 0(16,6),=CL16'ENQJOB.' * varname(shvcount,8::9-i) = varnum(i::9-i); LA 6,9 SLR 6,8 BCTR 6,0 LA 2,VARNAME-129(7) LA 3,VARNUM-1(8) EX 6,INSTRUCTION8 -> MVC 0(0,2),0(3) * shvcode = shvstore; L 4,BLOCKP MVI 8(4),C'S' * shvnaml = 16 - i; LA 5,16 SLR 5,8 ST 5,20(,4) * shvnama = addr(varname(shvcount)); LA 5,VARNAME-136(7) ST 5,16(,4) * varval(shvcount) = ribejbnm; LA 5,VARVAL-136(7) L 2,RIBEPTR MVC 0(8,5),0(2) * shvvala = addr(varval(shvcount)); ST 5,24(,4) * shvvall = length(ribejbnm); LA 7,8 ST 7,28(,4) * shvret = 'ff'X; * MVI 8+1(4),X'FF' *! * * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * varname(shvcount) = 'ENQQNAME.'; LA 2,VARNAME-136(7) MVC 0(16,2),=CL16'ENQQNAME.' * varname(shvcount,10::9-i) = varnum(i::9-i); LA 3,VARNAME-127(7) LA 2,VARNUM-1(8) EX 6,INSTRUCTION9 -> MVC 0(0,3),0(2) * shvcode = shvstore; L 3,BLOCKP MVI 8(3),C'S' * shvnaml = 18 - i; LA 2,18 SLR 2,8 ST 2,@OT00001 ST 2,20(,3) * shvnama = addr(varname(shvcount)); LA 2,VARNAME-136(7) ST 2,16(,3) * shvvala = addr(varqname(shvcount)); LA 2,VARQNAME-136(7) ST 2,24(,3) * shvvall = length(varqname); LA 2,8 ST 2,28(,3) * varqname(shvcount) = ribqname; LA 2,VARQNAME-136(7) L 4,RIBPTR MVC 0(8,2),32(4) * shvret = 'ff'X; * MVI 8+1(3),X'FF' *! * * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * varname(shvcount) = 'ENQRNAME.'; LA 5,VARNAME-136(7) MVC 0(16,5),=CL16'ENQRNAME.' * varname(shvcount,10::9-i) = varnum(i::9-i); LA 2,VARNAME-127(7) LA 3,VARNUM-1(8) EX 6,INSTRUCTION8 -> MVC 0(0,2),0(3) * shvcode = shvstore; L 4,BLOCKP MVI 8(4),C'S' * shvnaml = 18 - i; L 5,@OT00001 ST 5,20(,4) * shvnama = addr(varname(shvcount)); LA 5,VARNAME-136(7) ST 5,16(,4) * shvvala = addr(varrname(shvcount)); LA 5,VARRNAME-136(7) ST 5,24(,4) * shvvall = min(length(varrname),ribrnmln); L 5,RIBPTR SLR 2,2 IC 2,31(,5) LA 3,52 CR 2,3 BNH LABEL_19 LR 2,3 LABEL_19 ST 2,28(,4) * varrname(shvcount) = ribrname(1:min(length(varrname * ),ribrnmln)); LA 3,VARRNAME-136(7) MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(254),TEMPSTRING1+1 BCTR 2,0 EX 2,INSTRUCTION10 -> MVC TEMPSTRING1(0),40(5) MVC 0(52,3),TEMPSTRING1 * shvret = 'ff'X; * MVI 8+1(4),X'FF' *! * * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * varname(shvcount) = 'ENQTYPE.'; LA 4,VARNAME-136(7) MVC 0(16,4),=CL16'ENQTYPE.' * varname(shvcount,9::9-i) = varnum(i::9-i); LA 5,VARNAME-128(7) LA 4,VARNUM-1(8) EX 6,INSTRUCTION11 -> MVC 0(0,5),0(4) * shvcode = shvstore; L 6,BLOCKP MVI 8(6),C'S' * shvnaml = 17 - i; LA 2,17 SLR 2,8 ST 2,20(,6) * shvnama = addr(varname(shvcount)); LA 8,VARNAME-136(7) ST 8,16(,6) * shvvala = addr(ENQTYPE(SHVCOUNT)); LA 8,ENQTYPE-136(7) ST 8,24(,6) * shvvall = length(ENQTYPE); LA 8,34 ST 8,28(,6) * shvret = 'ff'X; MVI 8+1(6),X'FF' * IF ribetype THEN /* Check shr/Old status */ L 6,RIBEPTR TM 30(6),B'10000000' BZ LABEL_20 * shrold(shvcount) = 'SHR'; LA 8,SHROLD-136(7) MVC 0(3,8),=CL3'SHR' * ELSE * shrold(shvcount) = 'OLD'; B LABEL_21 LABEL_20 LA 6,SHROLD-136(7) MVC 0(3,6),=CL3'OLD' * IF ribestat THEN /* User is owner */ LABEL_21 L 8,RIBEPTR TM 32(8),B'10000000' BZ LABEL_22 * ownwait(shvcount) = 'OWN '; LA 6,OWNWAIT-136(7) MVC 0(4,6),=CL4'OWN ' * ELSE * ownwait(shvcount) = 'WAIT'; B LABEL_23 LABEL_22 LA 8,OWNWAIT-136(7) MVC 0(4,8),=CL4'WAIT' * IF ribsyss THEN LABEL_23 L 6,RIBPTR TM 30(6),B'01000000' BZ LABEL_24 * scope(shvcount) = 'SYSTEMS'; LA 8,SCOPE-136(7) MVC 0(8,8),=CL8'SYSTEMS' * ELSE * IF ribsys THEN B LABEL_26 LABEL_24 L 6,RIBPTR TM 30(6),B'10000000' BZ LABEL_25 * scope(shvcount) = 'SYSTEM'; LA 8,SCOPE-136(7) MVC 0(8,8),=CL8'SYSTEM' * ELSE * scope(shvcount) = 'NONSYS'; B LABEL_26 LABEL_25 LA 6,SCOPE-136(7) MVC 0(8,6),=CL8'NONSYS' * system(shvcount) = ribesysn; LABEL_26 LA 8,SYSTEM-136(7) L 6,RIBEPTR MVC 0(8,8),8(6) * IF ribstep THEN L 8,RIBPTR TM 30(8),B'00100000' BZ LABEL_27 * step(shvcount) = 'STEP'; LA 6,STEP-136(7) MVC 0(7,6),=CL7'STEP' * ELSE * step(shvcount) = 'NONSTEP'; B LABEL_28 LABEL_27 LA 8,STEP-136(7) MVC 0(7,8),=CL7'NONSTEP' * ribeptr = ribeptr + ribelen; /* Next ribe */ LABEL_28 LH 8,RIBELEN AL 8,RIBEPTR ST 8,RIBEPTR * END; * END; LA 8,1 AL 8,B ST 8,B L 2,RIBPTR C 8,24(,2) BNH LABEL_18 LABEL_29 DS 0H * ribptr = ribptr + riblen + ribvlen + (ribnribe * ribelen) * ; L 8,RIBPTR LH 2,RIBLEN ALR 2,8 AH 2,28(,8) LH 7,RIBELEN M 6,24(,8) ALR 2,7 ST 2,RIBPTR * END; LA 8,1 AL 8,A ST 8,A C 8,RIBCNT BNH LABEL_16 LABEL_30 DS 0H * END; CLC GQSCANRC(4),=F'8' BE LABEL_15 * r1 = gqareap; L 1,GQAREAP * r0 = length(gqarea); L 0,=F'32768' * GENERATE(FREEMAIN RU,LV=(0),A=(1)); FREEMAIN RU,LV=(0),A=(1) * END; * ELSE /* Parameter error */ * IF ENQRC = 0 THEN /* No code yet */ B LABEL_32 LABEL_31 ICM 8,15,ENQRC BNZ LABEL_32 * ENQRC = 20; /* Invalid dsname supplied */ * LA 8,20 ST 8,ENQRC * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable ENQRC */ * /* */ * /*****************************************************************/ * * CALL next_block; /* Go to next block */ LABEL_32 BAL 14,NEXT_BLOCK * cvd(count,spfctnw); L 6,COUNT CVD 6,SPFCTNW * unpk(spfctnx,spfctnw); UNPK SPFCTNX(16),SPFCTNW(8) * spfctnx(16) = spfctnx(16) | 'F0'X; OI SPFCTNX+15,X'F0' * countc = spfctnx(17-length(countc):16); MVC COUNTC(8),SPFCTNX+8 * i = verify(countc,'0'); MVI TEMPSTRING1,X'01' MVC TEMPSTRING1+1(255),TEMPSTRING1 SLR 8,8 IC 8,=CL1'0' LA 6,TEMPSTRING1(8) MVI 0(6),X'00' LR 8,1 LA 1,COUNTC LR 6,1 SLR 2,2 TRT 0(8,1),TEMPSTRING1 ALR 1,2 LCR 6,6 ALR 6,1 LR 1,8 LTR 8,6 * IF i = 0 THEN BNZ LABEL_33 * i = 8; LA 8,8 * varname(shvcount) = ''; LABEL_33 LA 2,VARNAME-136(7) MVI 0(2),C' ' MVC 1(15,2),0(2) * varname(shvcount,1::9-i) = countc(i::9-i); LA 6,9 SLR 6,8 LR 3,6 BCTR 3,0 LA 4,COUNTC-1(8) EX 3,INSTRUCTION12 -> MVC 0(0,2),0(4) * countc = varname(shvcount,1::9-i); MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(14),TEMPSTRING1+1 EX 3,INSTRUCTION13 -> MVC TEMPSTRING1(0),0(2) MVC COUNTC(8),TEMPSTRING1 * shvcode = shvstore; L 7,BLOCKP MVI 8(7),C'S' * shvnama = addr('ENQJOB.0'); LA 2,=CL8'ENQJOB.0' ST 2,16(,7) * shvnaml = 8; LA 3,8 ST 3,20(,7) * shvvala = addr(countc); LA 4,COUNTC ST 4,24(,7) * shvvall = 9 - i; ST 6,28(,7) * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * shvcode = shvstore; L 7,BLOCKP MVI 8(7),C'S' * shvnama = addr('ENQTYPE.0'); LA 2,=CL9'ENQTYPE.0' ST 2,16(,7) * shvnaml = 9; LA 3,9 ST 3,20(,7) * shvvala = addr(countc); LA 4,COUNTC ST 4,24(,7) * shvvall = 9 - i; ST 6,28(,7) * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * shvcode = shvstore; L 7,BLOCKP MVI 8(7),C'S' * shvnama = addr('ENQRNAME.0'); LA 2,=CL10'ENQRNAME.0' ST 2,16(,7) * shvnaml = 10; LA 3,10 ST 3,20(,7) * shvvala = addr(countc); LA 4,COUNTC ST 4,24(,7) * shvvall = 9 - i; ST 6,28(,7) * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * shvcode = shvstore; L 7,BLOCKP MVI 8(7),C'S' * shvnama = addr('ENQQNAME.0'); LA 2,=CL10'ENQQNAME.0' ST 2,16(,7) * shvnaml = 10; LA 3,10 ST 3,20(,7) * shvvala = addr(countc); LA 4,COUNTC ST 4,24(,7) * shvvall = 9 - i; * ST 6,28(,7) * /*****************************************************************/ * /* */ * /* Create rexx variable rc from local variable ENQRC */ * /* */ * /*****************************************************************/ * * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * cvd(ENQRC,SPFCTNW); L 6,ENQRC CVD 6,SPFCTNW * unpk(spfctnx,spfctnw); UNPK SPFCTNX(16),SPFCTNW(8) * spfctnx(16) = spfctnx(16) | 'F0'X; OI SPFCTNX+15,X'F0' * varnum = spfctnx(17-length(varnum):16); MVC VARNUM(8),SPFCTNX+8 * i = verify(varnum,'0'); MVI TEMPSTRING1,X'01' MVC TEMPSTRING1+1(255),TEMPSTRING1 SLR 8,8 IC 8,=CL1'0' LA 6,TEMPSTRING1(8) MVI 0(6),X'00' LR 8,1 LA 1,VARNUM LR 6,1 SLR 2,2 TRT 0(8,1),TEMPSTRING1 ALR 1,2 LCR 6,6 ALR 6,1 LR 1,8 LTR 8,6 * IF i = 0 THEN BNZ LABEL_34 * i = 8; LA 8,8 * varname(shvcount) = ''; LABEL_34 LA 2,VARNAME-136(7) MVI 0(2),C' ' MVC 1(15,2),0(2) * varname(shvcount,1::9-i) = varnum(i::9-i); LA 6,9 SLR 6,8 LR 3,6 BCTR 3,0 LA 4,VARNUM-1(8) EX 3,INSTRUCTION12 -> MVC 0(0,2),0(4) * varnum = varname(shvcount,1::9-i); MVI TEMPSTRING1+1,C' ' MVC TEMPSTRING1+2(14),TEMPSTRING1+1 EX 3,INSTRUCTION13 -> MVC TEMPSTRING1(0),0(2) MVC VARNUM(8),TEMPSTRING1 * shvcode = shvstore; L 7,BLOCKP MVI 8(7),C'S' * shvnaml = 2; LA 2,2 ST 2,20(,7) * shvnama = addr('RC'); LA 3,=CL2'RC' ST 3,16(,7) * shvvala = addr(varnum); LA 4,VARNUM ST 4,24(,7) * shvvall = 9 - i; ST 6,28(,7) * writeall = on; OI WRITEALL,B'10000000' * CALL next_block; /* Go to next block */ BAL 14,NEXT_BLOCK * GENERATE(DELETE EP=IRXEXCOM); /* REMOVE IRXEXCOM FROM STORAGE */ DELETE EP=IRXEXCOM * RESPECIFY * (r0, * r1, * r14, * r15); * * /*****************************************************************/ * /* */ * /* Set variable 'result' or function return */ * /* */ * /*****************************************************************/ * * SELECT(ENQRC); ICM 8,15,ENQRC BZ LABEL_35 LA 15,16 CR 8,15 BE LABEL_36 LA 1,20 CR 8,1 BNE LABEL_38 B LABEL_37 * WHEN(0) LABEL_35 DS 0H * DO; * evalblock_evlen = 2; /* Set result to 'ok' */ L 8,INPUTPTRS1+20 L 2,0(,8) LA 3,2 ST 3,8(,2) * evalblock_evdata(1:2) = 'OK'; MVC 16(2,2),=CL2'OK' * END; * WHEN(16) B LABEL_39 LABEL_36 DS 0H * DO; * evalblock_evlen = 19; L 8,INPUTPTRS1+20 L 2,0(,8) LA 3,19 ST 3,8(,2) * evalblock_evdata(1:24) = 'TOO MANY PARAMETERS'; MVC 16(24,2),=CL24'TOO MANY PARAMETERS' * END; * WHEN(20) B LABEL_39 LABEL_37 DS 0H * DO; * evalblock_evlen = 24; L 8,INPUTPTRS1+20 L 2,0(,8) LA 3,24 ST 3,8(,2) * evalblock_evdata(1:24) = 'RNAME NOT SPECIFIED'; MVC 16(24,2),=CL24'RNAME NOT SPECIFIED' * END; * OTHERWISE B LABEL_39 LABEL_38 DS 0H * DO; * evalblock_evlen = 5; L 8,INPUTPTRS1+20 L 2,0(,8) LA 3,5 ST 3,8(,2) * evalblock_evdata(1:5) = 'ERROR'; MVC 16(5,2),=CL5'ERROR' * END; * END; LABEL_39 DS 0H * RETURN code(0); /* Always return code zero */ LR 1,11 L 13,4(,13) LA 15,0 L 0,DSECT_SZ+4 FREEMAIN RU,LV=(0),A=(1),SP=(15) SLR 15,15 L 14,12(,13) LM 0,12,20(13) BR 14 * END QueryENQ; INSTRUCTION1 MVC PREFIX(0),16(7) INSTRUCTION2 MVC TEMPSTRING1+256(0),0(2) INSTRUCTION3 MVC TEMPSTRING1(0),0(8) INSTRUCTION4 MVC 0(0,3),RNAME INSTRUCTION5 MVC TEMPSTRING1(0),0(4) INSTRUCTION6 MVC TEMPSTRING1(0),0(2) INSTRUCTION7 CLC 40(0,8),RNAME INSTRUCTION8 MVC 0(0,2),0(3) INSTRUCTION9 MVC 0(0,3),0(2) INSTRUCTION10 MVC TEMPSTRING1(0),40(5) INSTRUCTION11 MVC 0(0,5),0(4) INSTRUCTION12 MVC 0(0,2),0(4) INSTRUCTION13 MVC TEMPSTRING1(0),0(2) *next_block: * PROCEDURE; /* Go to next block */ NEXT_BLOCK STM 14,6,SAVEAREA_3 STM 8,12,SAVEAREA_3+36 * IF shvcount = 0 THEN ICM 8,15,SHVCOUNT BNZ LABEL_40 * DO; * substrlen(addr(allblocks)->chars(1:length(allblocks)*dim( * allblocks)),32K) = ''B; LA 8,ALLBLOCKS LA 2,0(,8) L 3,=F'7638' LA 4,@CB00248 LA 5,0 MVCL 2,4 * blockp = addr(struc(1)); LA 8,STRUC ST 8,BLOCKP * END; * IF shvcount < dim(allblocks) THEN LABEL_40 L 8,SHVCOUNT LA 3,57 CR 8,3 BNL LABEL_42 * IF writeall = off THEN TM WRITEALL,B'10000000' BNZ LABEL_43 * DO; * IF shvcount ^= 0 THEN LTR 8,8 BZ LABEL_41 * shvnext = addr(allblocks(shvcount+1)); LR 4,8 SLA 8,4 ALR 8,4 SLA 8,3 LA 8,ALLBLOCKS(8) L 2,BLOCKP ST 8,0(,2) * shvcount = shvcount + 1; LABEL_41 LA 8,1 AL 8,SHVCOUNT ST 8,SHVCOUNT * END; * ELSE * ; B LABEL_43 * ELSE * writeall = on; LABEL_42 OI WRITEALL,B'10000000' * IF writeall = on THEN LABEL_43 TM WRITEALL,B'10000000' BNO LABEL_44 * DO; * r0 = r0save; L 0,R0SAVE * CALL emcom('IRXEXCOM',0,0,allblocks); LA 8,ALLBLOCKS MVC ADDRLST2(12),ADDRLST1 LA 2,ALLBLOCKS ST 2,ADDRLST2+12 OI ADDRLST2+12,X'80' L 15,EMCOMP LA 1,ADDRLST2 BALR 14,15 * shvcount = 0; SLR 2,2 ST 2,SHVCOUNT * writeall = off; NI WRITEALL,B'01111111' * substrlen(addr(allblocks)->chars(1:length(allblocks)*dim( * allblocks)),32K) = ''B; LA 6,0(,8) L 7,=F'7638' LA 2,@CB00248 LA 3,0 MVCL 6,2 * shvcount = 1; LA 8,1 ST 8,SHVCOUNT * END; * blockp = addr(allblocks(shvcount)); LABEL_44 L 7,SHVCOUNT LR 8,7 SLA 7,4 ALR 7,8 SLA 7,3 LA 6,ALLBLOCKS-136(7) ST 6,BLOCKP * END next_block; LABEL_45 LM 14,6,SAVEAREA_3 LM 8,12,SAVEAREA_3+36 BR 14 * * /*****************************************************************/ * /* */ * /* Findribs : Routine to get the rib control blocks */ * /* */ * /*****************************************************************/ * *findribs: * PROCEDURE; FINDRIBS STM 14,12,SAVEAREA_2 * */*** The following line deleted for ***********************/ */* Gqlst(1:47) = Gqparm(1:47): ** Copy macro expansion to */ */* Dynamic storage */ * * r2 = gqareap; L 2,GQAREAP * ribptr = r2; /* Ptr to first rib */ ST 2,RIBPTR * r3 = length(gqarea); * L 3,=F'32768' */*** The following lines changed for **********************/ */* Gen refs (R2,r3) sets (R0,r1,r14) */ */* (Gqscan area=((2),(3)),token=Token,reqlim=Max,mf=(E,gqlst)): */ * * GENERATE CODE ( MVC GQLST(GQPARML),GQPARM ); MVC GQLST(GQPARML),GQPARM * IF contention = on THEN TM CONTENTION,B'10000000' BNO LABEL_46 * DO; * r4 = 0; SLR 4,4 * GENERATE REFS (R2,R3,R4,TOKEN,GQPARM,QNAME,RNAME) SETS (R0,R1, * R14,GQLST,TOKEN); /* */ GQSCAN RESNAME=(QNAME,RNAME,(4),GENERIC,0),AREA=((2),(3)), C* TOKEN=TOKEN,REQLIM=MAX,MF=(E,GQLST), X* SCOPE=ALL,WAITCNT=1 * END; * ELSE * DO; B LABEL_47 LABEL_46 DS 0H * r4 = dsnl; /* Set length of rname */ L 4,DSNL * GENERATE REFS (R2,R3,R4,TOKEN,GQPARM,QNAME,RNAME) SETS (R0,R1, * R14,GQLST,TOKEN); /* */ GQSCAN RESNAME=(QNAME,RNAME,(4)),AREA=((2),(3)),SCOPE=ALL, X* TOKEN=TOKEN,REQLIM=MAX,MF=(E,GQLST) /* */ * END; * gqscanrc = r15; LABEL_47 ST 15,GQSCANRC * locrlens = r0; /* Save rib length (1St half word * of r0) and ribe length (2Nd * half word of r0) in variables * riblen and ribelen * respectively */ ST 0,LOCRLENS * ribcnt = r1; /* Save number of ribs returned */ ST 1,RIBCNT * RESPECIFY * (r0, * r1, * r2, * r3, * r4, /* */ * r14, * r15); * END findribs; LABEL_48 LM 14,12,SAVEAREA_2 BR 14 ADDRLST1 DS 0A DC A(CL8_IRXEXCOM) DC A(FIXED_0) DC A(FIXED_0) FIXED_0 DC F'0' LTORG CL8_IRXEXCOM DC CL8'IRXEXCOM' @CB00176 DS 0X @CB00248 DS 0B TRTAB1 DC XL256'000102030405060708090A0B0C0D0E0F101112131415161718* 191A1B1C1D1E1F202122232425262728292A2B2C2D2E2F3031323334* 35363738393A3B3C3D3E3F404142434445464748494A4B4C4D4E4F50* 5152535455565758595A5B5C5D5E5F606162636465666768696A6B6C* 6D6E6F707172737475767778797A7B7C7D7E7F808182838485868788* 898A8B8C8D8E8F909192939495969798999A9B9C9D9E9FA0A1A2A3A4* A5A6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0* C1C2C3C4C5C6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DADBDC* DDDEDFE0E1E2E3E4E5E6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8* F9FAFBFCFDFEFF' GQPARM GQSCAN RESNAME=(*-*,*-*,*-*),AREA=(*-*,32768),SCOPE=ALL, X* TOKEN=*-*,REQLIM=MAX,MF=L /* */ GQPARML EQU *-GQPARM /* */ DSECT_SZ DS 0A DC AL1(0) DC AL3(((@ENDDATD-@DATD+7)/8)*8) DC A(((@ENDDATD-@DATD+7)/8)*8) @DATD DSECT SAVEAREA_1 DS 18F INPUTPTRS1 DS 6F DS 15F ORG *-60 SAVEAREA_2 DS 015F SAVEAREA_3 DS 14F ORG , ADDRLST2 DS 4A @OT00001 DS F PSCBPTR DS A UPTPTR DS A TCBPTR DS A ENQRC DS F COUNT DS F SHVCOUNT DS F R0SAVE DS A EMCOMP DS A DSNL DS F GQAREAP DS A TOKEN DS F RIBPTR DS A RIBEPTR DS A RIBCNT DS F BLOCKP DS A A DS F B DS F I DS F GQSCANRC DS F TEMPSTRING1 DS CL512 TEMPDATASET DS CL44 DS CL4 SPFCTNW DS D SPFCTNX DS CL16 PREFIX DS CL8 VARNUM DS CL8 COUNTC DS CL8 QNRN DS 0CL128 RNAME DS CL120 QNAME DS CL8 ORG QNRN+128 CONTENTION DS BL1 WRITEALL DS BL1 DS CL2 LOCRLENS DS 0CL4 RIBLEN DS FL2 RIBELEN DS FL2 ALLBLOCKS DS 0CL134 STRUC DS CL32 ENQTYPE DS 0CL34 SHROLD DS CL3 DS CL1 OWNWAIT DS CL4 DS CL1 SCOPE DS CL8 DS CL1 STEP DS CL7 DS CL1 SYSTEM DS CL8 VARNAME DS CL16 VARRNAME DS 0CL52 VARQNAME DS 0CL8 VARVAL DS CL8 ORG ALLBLOCKS+7752 DATASET DS CL46 GQLST GQSCAN RESNAME=(*-*,*-*,*-*),AREA=(*-*,32768),SCOPE=ALL, X* TOKEN=*-*,REQLIM=MAX,MF=L /* */ ORG *+1-(*-@DATD)/(*-@DATD) @ENDDATD DS 0X END