MACRO &N BEGIN &R,&R2,&RENT=N,&VER= * ******************************************************************* * * * * B E G I N * * * * GENERATE A CSECT STATEMENT, SPECIFY AND LOAD THE BASE * * REGISTERS, GENERATE STANDARD LINKAGE WITH SAVE AREA. * * * LCLC ®,&LAB,®2,®3,®4,&BASE2,&VERSION GBLC &RENTGBL AIF (K'&VER GT 8).VERERR AIF (K'&VER NE 0).VEROK &VERSION SETC '1.0' AGO .VERCNT .VEROK ANOP &VERSION SETC '&VER' .VERCNT ANOP AIF (K'&N NE 0).LABOK &LAB SETC 'NONAME' MNOTE 4,'***** NO CSECT NAME SPECIFIED, NONAME USED *********' AGO .LABCNT .LABOK ANOP &LAB SETC '&N' .LABCNT ANOP AIF (K'&R NE 0).REGOK ® SETC '12' MNOTE 4,'***** NO BASE REGISTER SPECIFIED, 12 USED **********' AGO .REGCNT .REGOK ANOP AIF ('&R'(1,1) NE 'R').NUMB ® SETC '&R'(2,2) AGO .COMP .NUMB ANOP ® SETC '&R' .COMP ANOP AIF ('®' LT '2').E1 AIF ('®' GT '12').E1 ® SETC '&R' .REGCNT ANOP ®2 SETC '® USE ® AS BASE REGISTER' &BASE2 SETC '1' AIF (K'&R2 EQ 0).BASE1 &BASE2 SETC '2' AIF ('&R2'(1,1) NE 'R').NUMB2 ®3 SETC '&R2'(2,2) AGO .COMP2 .NUMB2 ANOP ®3 SETC '&R2' .COMP2 ANOP AIF ('®3' LT '2').E12 AIF ('®3' GT '12').E12 ®3 SETC '&R2' AIF ('®3' EQ '®').E12 ®4 SETC '®3 USE ®3 AS 2ND BASE REGISTER' MNOTE '***** THIS PROGRAM WILL HAVE 2 BASE REGISTERS ******' .BASE1 ANOP &RENTGBL SETC 'N' AIF ('&RENT'(1,1) NE 'Y').NOTRENT &RENTGBL SETC 'Y' .NOTRENT ANOP &LAB CSECT * BAKR R14,R0 LINKAGE STACK LAE ®,0(R15,0) SET ® AS BASE USING &LAB,®2 ADDRESS IT STM 14,12,12(13) SAVE REGISTERS IN CALLERS AREA * AIF ('&BASE2' EQ '1').AONE LAE ®3,2048(R15,0) SET ®3 AS SECOND BASE LAE ®3,2048(®3,0) SET ®3 AS SECOND BASE USING &LAB+4096,®4 * .AONE ANOP AIF ('&RENTGBL' EQ 'N').ANOTR GETMAIN R,LV=72,LOC=BELOW STORAGE FOR SAVE AREA * ST 13,4(1) PUT ADDRESS OF HIS SAVE AREA IN YOURS * ST 1,8(13) PUT ADDRESS OF YOUR SAVE AREA IN HIS * XR 13,1 * * XR 1,13 *EXCHANGE REGISTERS 1 AND R13 * XR 13,1 * * BAS 1,PRGMSAVE BRANCH PASSED ASSEMBLY INFORMATION * * * MNOTE '====> RE-ENTRANT VERSION OF EOJ WILL BE USED <==== *' * * AGO .INFO .ANOTR ANOP LR 15,13 * BAS 13,PRGMSAVE+END_EYECATCHER * PRGMSAVE DC 18F'0' * .INFO ANOP * * * ASSEMBLY INFORMATION - DATE, TIME AND CSECT NAME FOLLOW * * * ASLCSECT DC CL8'&LAB' ********* CSECT NAME *********** * ASLMODV DC CL8'&VERSION' **** VERSION INFORMATION **** * * * DC CL24'WRITTEN BY K E FERGUSON ' * DC CL36'COPYRIGHT - ABBYDALE SYSTEMS LLC. ' * * * ASLASMD DC CL8'&SYSDATE' **** ASSEMBLY DATE (MM/DD/YY) **** * ASLASMT DC CL6' &SYSTIME' **** ASSEMBLY TIME (HH.MM) **** * * * END_EYECATCHER EQU *-PRGMSAVE * * * AIF ('&RENTGBL' EQ 'N').ANOTR2 PRGMSAVE L 1,4(13) RELOAD ADDRESS OF HIS SAVE AREA * LM 0,1,20(1) RESET REGISTERS 0 AND 1 * AGO .EXIT .ANOTR2 ANOP ST 13,8(15) * ST 15,4(13) * .EXIT ANOP * K.F. * * ******************************************************************* * SPACE 1 MEXIT .E12 MNOTE 8,' -- VALUE FOR SECOND BASE REGISTER INVALID -- ' .E1 MNOTE 8,'IMPROPER REGISTER SPECIFIED, NO STATEMENTS GENERATED' .VERERR MNOTE 8,'LENGTH ERROR FOR THE VER PARAMETER > 8' MEND MACRO 00000008 &N EOJ &C=0 00000009 LCLC &A,&B GBLC &RENTGBL * ******************************************************************* * 00000010 * * 00000011 * E O J * 00000012 * * 00000013 * GENERATE STANDARD RETURN LINKAGE AND RETURN CODE. * 00000014 * * 00000015 AIF ('&N' EQ '').GO &N DS 0H .GO AIF ('&C'(1,1) EQ '(').REGCODE LA 15,&C PUT CONDITION CODE INTO REG 15 * AGO .RESTORE .REGCODE ANOP 00000025 AIF ('&C'(3,1) EQ ')').MOVE1 00000026 AIF ('&C'(4,1) EQ ')').MOVE2 00000026 AIF ('&C'(5,1) EQ ')').MOVE3 00000026 .MERROR ANOP MNOTE 16,'*** INVALID REGISTER PASSED AS RETURN CODE REGISTER' MEXIT .MOVE3 ANOP &A SETC '&C'(2,3) 00000027 AGO .CONT 00000028 .MOVE2 ANOP 00000029 &A SETC '&C'(2,2) 00000030 AGO .CONT 00000028 .MOVE1 ANOP 00000029 &A SETC '&C'(2,1) 00000030 .CONT ANOP 00000031 AIF ('&A'(1,1) EQ 'R').RVALUE AIF ('&A' GT '15').MERROR AGO .LOADIT .RVALUE ANOP &B SETC '&A'(2,2) AIF ('&B' GT '15').MERROR .LOADIT ANOP LR 15,&A LOAD REGISTER 15 WITH CODE * .RESTORE ANOP AIF ('&RENTGBL' EQ 'Y').YESRENT PR AGO .EXIT .YESRENT ANOP LR 2,15 LR 1,13 PUT ADDRESS OF GOTTEN INTO REG 1 * L 13,4(1) PUT HIS SAVE AREA ADDRESS IN REG 13* FREEMAIN R,LV=72,A=(1) FREE STORAGE * LR 15,2 PR .EXIT ANOP * * K.F. * * ******************************************************************* * MEND PRINT NOGEN QMGRWAIT START 0 QMGRWAIT AMODE 31 QMGRWAIT RMODE ANY GBLC &ASLCPY,&ASLCPL,&ASLVER &ASLCPL SETC 'This product contains restricted materials of Abbydale SX ystems LLC.' &ASLCPY SETC 'Abbydale Systems LLC.' &ASLVER SETC 'VERSION 6.1' *********************************************************************** * A S L E Q U C * *********************************************************************** * REGISTER EQUATES * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * R0 EQU 0 * R1 EQU 1 * R2 EQU 2 * R3 EQU 3 * R4 EQU 4 * R5 EQU 5 * R6 EQU 6 * R7 EQU 7 * R8 EQU 8 A S L E Q U C * R9 EQU 9 * R10 EQU 10 EQUATE PREFIX TO NUMERIC SYMBOLS IN ORDER * R11 EQU 11 TO MAKE THE USE OF REGISTER OPERANDS IN * R12 EQU 12 INSTRUCTIONS SELF EXPLANITORY.THIS ALSO * R13 EQU 13 CREATES ENTRIES IN CROSS REFERENCE. * R14 EQU 14 * R15 EQU 15 * FPR0 EQU 0 * FPR2 EQU 2 * FPR4 EQU 4 * FPR6 EQU 6 * EJECT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * MISCELLANEOUS EQUATES * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * EQUHOBON EQU X'80000000' SET HIGH ORDER BIT ON * PACKDIG EQU X'0F' PACK DIGIT * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * DCB Offsets in ASLDCBS * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * SYSPRINT_OFFSET EQU 0 Offset to SYSPRINT DCB * SYSIN_OFFSET EQU 4 Offset to SYSIN DCB * INPUT_OFFSET EQU 8 Offset to INPUT DCB * DIRIN_OFFSET EQU 12 Offset to DIRIN DCB * SNAP_OFFSET EQU 16 Offset to SNAP DCB * ASLPRINT_OFFSET EQU 20 Offset to ASLPRINT DCB * CORRELID_OFFSET EQU 24 Offset to CORRELID DCB * LONGMSG_OFFSET EQU 28 Offset to LONGMSG DCB * INTRDR_OFFSET EQU 32 Offset to INTRDR DCB * * K.E.F. * * ******************************************************************* * * COPY ASLEQUC Register equates QMGRWAIT TITLE 'QMGRWAIT - Issue reply retry, wait or cancel' *---------------------------------------------------------------------* * QMGRWAIT * *---------------------------------------------------------------------* * * * Description : Issues a reply RETRY, WAIT or CANCEL message. This * * is designed to be called by MQ enabled program that * * detect that the Qmgr is quiescing. * * * * Created on : 6 July 2006 * * Created by : Kevin Ferguson * * : Userid MIT001 * * : Using ABBYDALE.DEVL.SOURCE(QMGRWAIT) * * * * Called by : MQ programs * * * * Calls : Nothing * * * * Change Activity : * * * *---------------------------------------------------------------------* * ©Copyright of Abbydale Systems LLC. * *---------------------------------------------------------------------* QMGRWAIT BEGIN R12,VER=6.1 L R1,0(R1) Pick up Queue Manager name LA R10,2(R1) address of Queue manager name XR R7,R7 Clear R7 LH R7,0(R1) Get length CH R7,=H'4' Is length 4 ? BE Start Yes - Skip CH R7,=H'6' Is length 6 ? BE Start Yes - Skip C R7,=F'0' Is length 0? BNE Length_Error No - go to start WTO 'QMGRW01E : NO PARMS PASSED. RC=16' ABEND DS 0H LA R15,16 Set return code 16 ... B EXIT_ERROR ... and go and error out Length_Error DS 0H WTO 'QMGRW02E : INVALID PARM PASSED. RC=16' B ABEND Now fail START DS 0H EXTRACT TIOTADDR,FIELDS=TIOT L R3,TIOTADDR Load TIOT address into R3 MVC REALJOB,0(R3) Move our jobname to message MVC WTOR+27(8),8(R3) ... and into message area * ** Establish default values * MVI WTOR_NEEDED,C'Y' Set flag off NO_DCB DS 0H DEVTYPE =CL8'NOWTOR ',CVBAREA Do we need a WTOR? LTR R15,R15 Did we find a NOWTOR? BNZ NO_WTOR No - Skip to NO_NOWTOR MVI WTOR_NEEDED,C'N' Set flag off NO_WTOR DS 0H XR R1,R1 Clear R1 LA R2,CIBAREA Load target address EXTRACT (R2),FIELDS=(COMM) Extract COMMID L R2,CIBAREA Get return address ... USING COMLIST,R2 ... adnd establish addressability L R5,COMCIBPT Get address of CIB ... USING CIBNEXT,R5 ... and address it MVC DATAAREA(16),CIBDATA Populate the Dataarea CLI CIBVERB,CIBSTART First CIB (Start command) ? BNE SETLIMIT No - Go and set the limit. QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB LTR R15,R15 Did it work ? BZ SETLIMIT Yes - Go set some limits WTO 'QMGRW03I : FREE OF START CIB UNSUCCESSFUL' SETLIMIT DS 0H QEDIT ORIGIN=COMCIBPT,CIBCTR=2 Set Command limit to 2 L R4,COMECBPT Pointer to the com ECB ST R4,ECBADDR Save the COM ECB in the ECBLIST Issue_it DS 0H MVC JOBNAME,0(R10) Move qmgr name to error message Re_issue_it DS 0H CLI WTOR_NEEDED,C'Y' WTOR needed? BE ISSUE_WTOR If yes - go issue it MVC Mess+7(1),=C'I' Set to informational MVC WTO+8(56),MESS If not move message to WTO WTO WTO '1234567890123456789012345678901234567890123456789012345* 6 ', * ROUTCDE=(2,11),DESC=(2) ST R1,SAVER1 Save R1 for DOM B wait Now go wait for response ISSUE_WTOR DS 0H MVC WTOR+16(56),MESS Move message to WTOR MVC WTOR+72(34),Tail_end Move message to WTOR WTOR WTOR '1234567890123456789012345678901234567890123456789012345* 6789012345678901234567890123456789', * REPLYFLD,8,REPLY_ECB ST R1,SAVER1 Save R1 for DOM WAIT DS 0H LA R4,REPLY_ECB Address of REPLY_ECB in R4 ST R4,Lastone Save it in list OI Lastone+0,x'80' Flag end of list WAIT 1,ECBLIST=ECBADDR,LONG=YES WAIT for ECB to pop TM REPLY_ECB,X'40' Was it a reply pop? BNO TRYMOD No - Try modify NI REPLY_ECB,X'00' Reset ECB TR REPLYFLD,TRTABLE Make it reponse uppercase CLC REPLYFLD(5),=C'RETRY' Was it "RETRY"? BE Issue_retry If yes - then go retry it CLC REPLYFLD(6),=C'CANCEL' Was is "CANCEL"? BE CANCEL_OUT If Yes - then go cancel out CLC REPLYFLD(4),=C'WAIT' Was it "WAIT"? BNE WTOR If not - re-issue WTOR CLC REPLYFLD+5(3),=c' ' Clear reply fielde BE Now_Wait Now go and issue wait LA R6,REPLYFLD+4 Load R6 with end of WAIT BAS R11,CHECK_Wait Go validate the wait value Now_wait DS 0H STIMER WAIT,BINTVL=DELAY Wait for 60 seconds B exit Now try again TRYMOD DS 0H L R2,CIBAREA Reload R2 L R5,COMCIBPT Obtain CIB address CLI CIBVERB,CIBMODFY Was it a modify? BNE COMMAND_INVALID No - Then is must be invalid CLC CIBDATA(5),=C'RETRY' Is it a "RETRY" command? BNE TRY_CANCEL No _ skip to try cancel L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB Issue_retry DS 0H WTO 'QMGRW05I : Retry command accepted' B EXIT TRY_CANCEL DS 0H CLC CIBDATA(6),=C'CANCEL' Is it a cancel? BE Cancel_out Yep - Go cancel out then CLC CIBDATA(4),=C'WAIT' Is it a WAIT? BNE COMMAND_INVALID No - Then it must be invalid Clc CIBDATLN,=h'4' Check for Valid wait BE SKip_wait_check Invalid length - Then skip LA R6,WORK Load R6 with Work address XR R0,R0 Clear R0 LH R0,CIBDATLN Load our length into R0 BCTR R0,0 Take one off EX R0,Move_it And move in the length BAS R11,CHECK_Wait Now go and validate it SKip_wait_check DS 0H L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB B NOW_WAIT And go and wait COMMAND_INVALID DS 0H CLI CIBVERB,CIBSTOP Is it a STOP(P) Command? BE Cancel_out No - Forget it WTO 'QMGRW06E : Invalid command' L R1,SAVER1 Restore R1 for DOM DOM MSG=(R1) Delete previous message QEDIT ORIGIN=COMCIBPT,BLOCK=(R5) Free CIB B Re_Issue_it and go re-issue the message *---------------------------------------------------------------------* *** This subroutine checks the wait value passed *** *---------------------------------------------------------------------* CHECK_WAIT DS 0H MVC WORK(4),0(r6) Move passed value in work area TR work,TRTABLE Make '40' low values L R6,WORK Load R6 with modified wait LTR R6,R6 Is it 0? BZ Exit_wait_routine Yes - Stay with default and exit Next_attempt DS 0H * CLI Work+3,x'00' * Drop low order low values BNE Done_messing * SRL R6,8 * ST R6,WORK * B Next_attempt * Done_messing DS 0H ST R6,WORK Save R6 MVI Start_flag,C'N' Set Start indicator LA r3,4 Maximum Loop count LA R6,Work-1 Point to one byte before WORK Next_Digit DS 0H LA R6,1(R6) Up R6 to next byte CLI 0(r6),x'00' Low values? BE Test_Flag Yes - Go check start flag CLI 0(R6),C'0' Make sure it is a number BL SET_20 No - Go Set default CLI 0(R6),C'9' Make sure it is a number BH SET_20 No - Go Set default MVI Start_flag,C'Y' Set flag to indicate we started BCT r3,Next_Digit and go check next digit PACK WORK,WORK Pack the validated number L R6,WORK and load it into R6 SRL R6,4 Drop the F...... SLL R6,12 ...and shuffle it along for * because we need binary 100ths ST R6,WORK Save it back OI WORK+3,X'0F' now reset the pack digit again CVB R6,DOUBLE Convert it ST R6,DELAY and save new value as delay B Exit_Wait_Routine Now get the heck out Test_flag DS 0H BCTR R3,0 Subtract 1 CLI Start_flag,c'N' Have we hit a start yet? BE Next_Digit No - Then process next digit Set_20 DS 0H WTO 'QMGRW07E : Invalid wait value. Set to 60 seconds' MVC Delay,=F'6000' Set Default Exit_wait_routine DS 0H BR R11 *-------------------------------------------------------------------* EXIT DS 0H EXIT_PROCESS DS 0H XR R15,R15 Clear R0 for cond code EXIT_ERROR DS 0H EOJ C=(R15) and exit CANCEL_OUT DS 0H MVC DUMPWTO+19(8),realjob Move our jobname to wto dumpwto WTO 'QMGRW08I : xxxxxxxx Job Cancelled' LA R15,8 Set return code 8 B Exit_Error Now dump * * Executed instructions * Move_it MVC WORK+0(*-*),CIBDATA+4 Move wait value TRANSIT TR 0(*-*,R10),TRTABLE Make it uppercase * * End of Executed instructions * CVBAREA DS D DOUBLE DS 0D DS F WORK DS F DATAAREA DS 4F SAVER1 DS F CIBAREA DS F * * Flags * SYSIN DS CL1 INPUT DD card found flag WTOR_NEEDED DS CL1 WTOR required flag Start_Flag DS CL1 * REPLYFLD DS CL8 Reply field for WTOR DS 0H MESS DS 0CL56 DC CL11'QMGRW04A : ' REALJOB DS CL8 DC CL19' has detected that ' JOBNAME DS CL4 DC CL14' is quiescing.' * DC CL24' ' Tail_End DC CL34' Reply ''RETRY'',''WAIT'' or ''CANCEL''.' *********************************************************************** * | THIS IS THE DEFAULT WAIT TIME * V DELAY DC F'6000' Wait for 60 seconds * ** Here are the ECB's to be waited on * TIOTADDR DC F'0' REPLY_ECB DC F'0' ECBADDR DC A(0) lastone DC A(reply_ecb) * TRTABLE DS 0CL256 * 0 1 2 3 4 5 6 7 8 9 A B C D E F DC X'40000000000000000000000000000000' 00-0F DC X'00000000000000000000000000000000' 10-1F DC X'00000000000000000000000000000000' 20-2F DC X'00000000000000000000000000000000' 30-3F DC X'00000000000000000000000000000000' 40-4F DC X'0000000000000000000000005C000000' 50-5F DC X'00000000000000000000000000000000' 60-6F DC X'00000000000000000000000000000000' 70-7F DC X'00C1C2C3C4C5C6C7C8C9000000000000' 80-8F DC X'00D1D2D3D4D5D6D7D8D9000000000000' 90-9F DC X'00E1E2E3E4E5E6E7E8E9000000000000' A0-AF DC X'00000000000000000000000000000000' B0-BF DC X'00C1C2C3C4C5C6C7C8C9000000000000' C0-CF DC X'00D1D2D3D4D5D6D7D8D9000000000000' D0-DF DC X'00E1E2E3E4E5E6E7E8E9000000000000' E0-EF DC X'F0F1F2F3F4F5F6F7F8F9000000000040' F0-FF ORG LTORG DSECT IEZCOM DSECT IEZCIB *---------------------------------------------------------------------* * End of QMGRWAIT * *---------------------------------------------------------------------* LTORG END QMGRWAIT PUNCH ' MODE AMODE(31)' BINDER AMODE STATEMENT. PUNCH ' MODE RMODE(ANY)' BINDER RMODE STATEMENT. PUNCH ' ENTRY QMGRWAIT' MODULE ENTRY POINT. PUNCH ' NAME QMGRWAIT(R)' MODULE NAME. END ,