Data Collector Program Examples
This topic contains three data collector programs that you can use as examples to help you write your own programs as explained in Data-Collector-Programs.
Data Collector Program Showing Module Identification
*********************************************************************
* *
* STRBTSMD - SAMPLE DATA COLLECTOR FOR STROBE *
* *
* THE PURPOSE OF THIS DATA COLLECTOR IS TO GIVE AN EXAMPLE OF *
* A DATA COLLECTOR THAT IDENTIFIES THE NAME OF A MODULE, WITH *
* ACTIVITY/WAIT, IN A SYSTEM THAT PERFORMS ITS OWN CONTENTS *
* SUPERVISION. *
* *
* IF THE MODULE NAME HAS NOT BEEN IDENTIFIED BY STROBE, THEN *
* THIS DATA COLLECTOR WILL RUN THE CONTROL BLOCK STRUCTURES, *
* ASSOCIATED WITH THIS SUBSYSTEM, THAT REPRESENT WHERE PROGRAMS *
* WERE LOADED INTO STORAGE AND ATTEMPT TO IDENTIFY THE PSW *
* THAT WAS PASSED IN THE PARAMETER LIST. *
* *
* FOR STROBE REL. 2.2.1 AND HIGHER, THIS EXIT MUST BE CODED *
* RE-ENTERANT, AND THE LOAD MODULE MUST BE MARKED WITH THE *
* RENT (RE-ENTERANT) ATTRIBUTE. BE SURE TO SPECIFY OPTION *
* ’RENT’ IN THE LINKAGE EDITOR STEP FOR THIS MODULE. *
* *
* REVISION HISTORY: *
* *
* REV DATE CHANGE BY *
* --- ------- -------------------------------------------- --- *
* 00 27NOV06 NEW MODULE XXX *
* *
*********************************************************************
STRBTSMD CSECT
STRBTSMD AMODE 31
STRBTSMD RMODE 24
R0 EQU 0 BRANCH WORK REGISTER
R1 EQU 1 BRANCH WORK REGISTER
R2 EQU 2 WORK REGISTER
R3 EQU 3 WORK REGISTER
R4 EQU 4 WORK REGISTER
R5 EQU 5 WORK REGISTER
R6 EQU 6 WORK REGISTER
R7 EQU 7 WORK REGISTER
R8 EQU 8 WORK REGISTER
R9 EQU 9 WORK REGISTER
R10 EQU 10 WORK REGISTER
R11 EQU 11 A(DCILCOMM)
R12 EQU 12 BASE REGISTER
R13 EQU 13 A(INPUT SAVEAREA)
R14 EQU 14 BRANCH WORK REGISTER
R15 EQU 15 BRANCH WORK REGISTER
SPACE
B BEGIN-STRBTSMD(R15) BRANCH AROUND HEADER
DC AL1(FILL-*-1) LENGTH OF IDENTIFIER
DC CL17'STROBE COLLECTOR '
DC CL1' '
DC CL8'STRBTSMD'
DC CL1' '
GENID DC CL4'V-00'
IDSIZE EQU *-STRBTSMD CALC SIZE OF HEADER
FILL DC XL(64-IDSIZE)'00' FILL TO EP+64
*
* THE FOLLOWING TABLE MUST BEGIN AT ENTRY POINT +64 BYTES.
*
ADDRLIST DS 0F
DC 3A(0) UNUSED
DCCPCST DC A(PCSECTBL) A(PSEUDO-CSECT TABLE)
DC AL1(0) UNUSED
DCCLIST DC AL3(PROGRAMS) LIST OF PROGRAMS SUPPORTED
*
* PSEUDO-CSECT TABLE
*
PCSECTBL DS 0F
DC CL7'TSMSYST' USE PSEUDO NAME TSMSYST
DC CL3'TSM' FOR ALL MODS TSM*
DC X'FF' MARK END OF TABLE
*
* LIST OF SUPPORTED PROGRAMS
*
PROGRAMS DS 0F
DC CL8'TSMDRIVR' RUN WHENEVER INVOKED
DC X'80' MARK END OF TABLE
*
* START OF COLLECTOR CODE
*
BEGIN DS 0H
STM R14,R12,12(R13) SAVE REGS
LR R12,R15 SET NEW BASE
USING STRBTSMD,R12 ESTABLISH ADDRESSABILITY
LR R11,R1 GET A(DCILCOMM)
USING DCILCOMM,R11 ESTABLISH ADDRESSABILITY
*
* CHECK TO SEE IF THE MODULE HAS ALREADY BEEN IDENTIFIED.
*
L R3,DCILCNMA GET A(MODULE NAME)
LTR R3,R3 IS IT THERE?
BZ IDMOD NO, TRY TO ID MODULE
CLI 0(R3),X'00' MODULE NAME SUPPLIED?
BNE EXIT YES, NOTHING TO DO
*
* ATTEMPT TO ID THE MODULE. IN ORDER TO DO THIS WE MUST FIRST GET
* ADDRESSABILITY TO TSMANCH, THE TSM SYSTEM COMMON ANCHOR CONTROL
* BLOCK, WHICH SHOULD BE POINTED TO VIA THE R7 SAVED IN THE CURRENT
* TCB.
*
IDMOD DS 0H
L R3,DCILCTCB @(CURRENT TCB)
SLL R3,8 CLEAN FOR A
SRL R3,8 24-BIT ADDRESS
L R3,TCBGRS7-TCB(R3) GET SAVED R7
USING TSMANCH,R3 ESTABLISH ADDRESSABILITY
CLC TSMEYEC,=CL8'TSMANCH' IS IT THE ANCHOR CB?
BNE EXIT NO, NOT INTERESTED
*
* GET THE ADDRESS OF THE FIRST TSMPROG, TSM SYSTEM LOADED PROGRAM
* CONTROL BLOCK, AND RUN THE CHAIN ATTEMPTING TO IDENTIFY THE PSW
* ADDRESS PASSED IN THE PARAMETER LIST.
*
L R4,TSMPROGL GET A(1ST TSMPROG CB)
LTR R4,R4 IS IT THERE?
BZ EXIT NO, CAN'T ID PSW
DROP R3 DROP ADDRESS - TSMANCH
USING TSMPROG,R4 ESTABLISH ADDRESSABILITY
L R1,DCILCPSW GET PSW FROM PARMLIST
LA R1,0(R1) AND CLEAR HIGH-ORDER BIT
B TSMPLOOP+4 ENTER LOOP
TSMPLOOP DS 0H
L R4,TPROGNXT @(NEXT TSMPROG CB)
LTR R4,R4 ADDRESS FOUND?
BZ EXIT NO, CAN'T ID PSW
L R2,TPROGADD GET A(LOADED PROGRAM)
LA R2,0(R2) AND CLEAR HIGH-ORDER BIT
CR R1,R2 PSW ABOVE PROGRAM START
BL TSMPLOOP NO, TRY NEXT TSMPROG CB
L R3,TPROGLN GET LENGTH OF LOADED PROG
LA R4,0(R2,R3) CALC END OF LOADED PROG
CR R1,R4 PSW IN LOADED PROGRAM?
BNL TSMPLOOP NO, TRY NEXT TSMPROG CB
*
* THE CURRENT TSMPROG CONTROL BLOCK REPRESENTS THE PROGRAM WITH
* OBSERVED ACTIVITY/WAIT. SAVE THE ADDRESS OF THE PROGRAM NAME, THE
* BASE ADDRESS OF THE PROGRAM, AND THE PROGRAM LENGTH IN THE
* PARAMETER LIST.
*
LA R15,TPROGNAM GET A(LOADED PROGRAM NAME)
ST R15,DCILCNMA AND SAVE IN PARMLIST
ST R2,DCILCBAS SAVE BASE ADDR IN PARMLIST
ST R3,DCILCSIZ SAVE SIZE IN PARMLIST
DROP R3 DROP ADDRESS - TSMPROG
*
* PROGRAM EXIT
*
EXIT DS 0H
LM R14,R12,12(R13) RESTORE REGS
BR R14 RETURN TO CALLER
DROP R11 DROP ADDRESS - DCILCOMM
DROP R12 DROP ADDRESS - BASE REG
EJECT
*
DC2_LEN EQU *-STRBTSMD LENGTH OF CSECT
*
* DATA COLLECTOR COMMUNICATION AREA DSECT
*
DCILCOMM DSECT, UDC=Y
EJECT
*
* MVS DSECTS
*
PRINT NOGEN
IKJTCB TCB
EJECT
*
* TSM SYSTEM CONTROL BLOCKS
*
PRINT GEN
TSMANCH TSM SYSTEM ANCHOR CB
TSMPROG TSM SYSTEM LOADED PROG CB
END
* *
* STRBTSMD - SAMPLE DATA COLLECTOR FOR STROBE *
* *
* THE PURPOSE OF THIS DATA COLLECTOR IS TO GIVE AN EXAMPLE OF *
* A DATA COLLECTOR THAT IDENTIFIES THE NAME OF A MODULE, WITH *
* ACTIVITY/WAIT, IN A SYSTEM THAT PERFORMS ITS OWN CONTENTS *
* SUPERVISION. *
* *
* IF THE MODULE NAME HAS NOT BEEN IDENTIFIED BY STROBE, THEN *
* THIS DATA COLLECTOR WILL RUN THE CONTROL BLOCK STRUCTURES, *
* ASSOCIATED WITH THIS SUBSYSTEM, THAT REPRESENT WHERE PROGRAMS *
* WERE LOADED INTO STORAGE AND ATTEMPT TO IDENTIFY THE PSW *
* THAT WAS PASSED IN THE PARAMETER LIST. *
* *
* FOR STROBE REL. 2.2.1 AND HIGHER, THIS EXIT MUST BE CODED *
* RE-ENTERANT, AND THE LOAD MODULE MUST BE MARKED WITH THE *
* RENT (RE-ENTERANT) ATTRIBUTE. BE SURE TO SPECIFY OPTION *
* ’RENT’ IN THE LINKAGE EDITOR STEP FOR THIS MODULE. *
* *
* REVISION HISTORY: *
* *
* REV DATE CHANGE BY *
* --- ------- -------------------------------------------- --- *
* 00 27NOV06 NEW MODULE XXX *
* *
*********************************************************************
STRBTSMD CSECT
STRBTSMD AMODE 31
STRBTSMD RMODE 24
R0 EQU 0 BRANCH WORK REGISTER
R1 EQU 1 BRANCH WORK REGISTER
R2 EQU 2 WORK REGISTER
R3 EQU 3 WORK REGISTER
R4 EQU 4 WORK REGISTER
R5 EQU 5 WORK REGISTER
R6 EQU 6 WORK REGISTER
R7 EQU 7 WORK REGISTER
R8 EQU 8 WORK REGISTER
R9 EQU 9 WORK REGISTER
R10 EQU 10 WORK REGISTER
R11 EQU 11 A(DCILCOMM)
R12 EQU 12 BASE REGISTER
R13 EQU 13 A(INPUT SAVEAREA)
R14 EQU 14 BRANCH WORK REGISTER
R15 EQU 15 BRANCH WORK REGISTER
SPACE
B BEGIN-STRBTSMD(R15) BRANCH AROUND HEADER
DC AL1(FILL-*-1) LENGTH OF IDENTIFIER
DC CL17'STROBE COLLECTOR '
DC CL1' '
DC CL8'STRBTSMD'
DC CL1' '
GENID DC CL4'V-00'
IDSIZE EQU *-STRBTSMD CALC SIZE OF HEADER
FILL DC XL(64-IDSIZE)'00' FILL TO EP+64
*
* THE FOLLOWING TABLE MUST BEGIN AT ENTRY POINT +64 BYTES.
*
ADDRLIST DS 0F
DC 3A(0) UNUSED
DCCPCST DC A(PCSECTBL) A(PSEUDO-CSECT TABLE)
DC AL1(0) UNUSED
DCCLIST DC AL3(PROGRAMS) LIST OF PROGRAMS SUPPORTED
*
* PSEUDO-CSECT TABLE
*
PCSECTBL DS 0F
DC CL7'TSMSYST' USE PSEUDO NAME TSMSYST
DC CL3'TSM' FOR ALL MODS TSM*
DC X'FF' MARK END OF TABLE
*
* LIST OF SUPPORTED PROGRAMS
*
PROGRAMS DS 0F
DC CL8'TSMDRIVR' RUN WHENEVER INVOKED
DC X'80' MARK END OF TABLE
*
* START OF COLLECTOR CODE
*
BEGIN DS 0H
STM R14,R12,12(R13) SAVE REGS
LR R12,R15 SET NEW BASE
USING STRBTSMD,R12 ESTABLISH ADDRESSABILITY
LR R11,R1 GET A(DCILCOMM)
USING DCILCOMM,R11 ESTABLISH ADDRESSABILITY
*
* CHECK TO SEE IF THE MODULE HAS ALREADY BEEN IDENTIFIED.
*
L R3,DCILCNMA GET A(MODULE NAME)
LTR R3,R3 IS IT THERE?
BZ IDMOD NO, TRY TO ID MODULE
CLI 0(R3),X'00' MODULE NAME SUPPLIED?
BNE EXIT YES, NOTHING TO DO
*
* ATTEMPT TO ID THE MODULE. IN ORDER TO DO THIS WE MUST FIRST GET
* ADDRESSABILITY TO TSMANCH, THE TSM SYSTEM COMMON ANCHOR CONTROL
* BLOCK, WHICH SHOULD BE POINTED TO VIA THE R7 SAVED IN THE CURRENT
* TCB.
*
IDMOD DS 0H
L R3,DCILCTCB @(CURRENT TCB)
SLL R3,8 CLEAN FOR A
SRL R3,8 24-BIT ADDRESS
L R3,TCBGRS7-TCB(R3) GET SAVED R7
USING TSMANCH,R3 ESTABLISH ADDRESSABILITY
CLC TSMEYEC,=CL8'TSMANCH' IS IT THE ANCHOR CB?
BNE EXIT NO, NOT INTERESTED
*
* GET THE ADDRESS OF THE FIRST TSMPROG, TSM SYSTEM LOADED PROGRAM
* CONTROL BLOCK, AND RUN THE CHAIN ATTEMPTING TO IDENTIFY THE PSW
* ADDRESS PASSED IN THE PARAMETER LIST.
*
L R4,TSMPROGL GET A(1ST TSMPROG CB)
LTR R4,R4 IS IT THERE?
BZ EXIT NO, CAN'T ID PSW
DROP R3 DROP ADDRESS - TSMANCH
USING TSMPROG,R4 ESTABLISH ADDRESSABILITY
L R1,DCILCPSW GET PSW FROM PARMLIST
LA R1,0(R1) AND CLEAR HIGH-ORDER BIT
B TSMPLOOP+4 ENTER LOOP
TSMPLOOP DS 0H
L R4,TPROGNXT @(NEXT TSMPROG CB)
LTR R4,R4 ADDRESS FOUND?
BZ EXIT NO, CAN'T ID PSW
L R2,TPROGADD GET A(LOADED PROGRAM)
LA R2,0(R2) AND CLEAR HIGH-ORDER BIT
CR R1,R2 PSW ABOVE PROGRAM START
BL TSMPLOOP NO, TRY NEXT TSMPROG CB
L R3,TPROGLN GET LENGTH OF LOADED PROG
LA R4,0(R2,R3) CALC END OF LOADED PROG
CR R1,R4 PSW IN LOADED PROGRAM?
BNL TSMPLOOP NO, TRY NEXT TSMPROG CB
*
* THE CURRENT TSMPROG CONTROL BLOCK REPRESENTS THE PROGRAM WITH
* OBSERVED ACTIVITY/WAIT. SAVE THE ADDRESS OF THE PROGRAM NAME, THE
* BASE ADDRESS OF THE PROGRAM, AND THE PROGRAM LENGTH IN THE
* PARAMETER LIST.
*
LA R15,TPROGNAM GET A(LOADED PROGRAM NAME)
ST R15,DCILCNMA AND SAVE IN PARMLIST
ST R2,DCILCBAS SAVE BASE ADDR IN PARMLIST
ST R3,DCILCSIZ SAVE SIZE IN PARMLIST
DROP R3 DROP ADDRESS - TSMPROG
*
* PROGRAM EXIT
*
EXIT DS 0H
LM R14,R12,12(R13) RESTORE REGS
BR R14 RETURN TO CALLER
DROP R11 DROP ADDRESS - DCILCOMM
DROP R12 DROP ADDRESS - BASE REG
EJECT
*
DC2_LEN EQU *-STRBTSMD LENGTH OF CSECT
*
* DATA COLLECTOR COMMUNICATION AREA DSECT
*
DCILCOMM DSECT, UDC=Y
EJECT
*
* MVS DSECTS
*
PRINT NOGEN
IKJTCB TCB
EJECT
*
* TSM SYSTEM CONTROL BLOCKS
*
PRINT GEN
TSMANCH TSM SYSTEM ANCHOR CB
TSMPROG TSM SYSTEM LOADED PROG CB
END
Data Collector Program Showing 4GL Attribution
*********************************************************************
* *
* STRBDC1 - SAMPLE DATA COLLECTOR FOR STROBE *
* *
* THE PURPOSE OF THIS DATA COLLECTOR IS TO GIVE AN EXAMPLE OF *
* A DATA COLLECTOR THAT SUPPLIES PROGRAM NAME AND STATEMENT *
* NUMBER FOR THE 4GL PROGRAM THAT ORIGINATED THE OBSERVED *
* ACTIVITY/WAIT. *
* *
* IF THE OBSERVED ACTIVITY/WAIT IS IN A MVS LOADED MODULE, *
* TINTERPT (A FICTIONAL INTERPRETER), THEN THE DATA COLLECTOR *
* WILL NAVIGATE FROM THE R8 SAVED IN THE TCB THROUGH A SERIES *
* OF SUBSYSTEM SPECIFIC CONTROL BLOCKS TO THE STRUCTURE THAT *
* REPRESENTS THE USER WRITTEN 4GL PROGRAM THAT IS CURRENTLY *
* EXECUTING. *
* *
* ONCE THE CONTROL BLOCK REPRESENTING THE 4GL PROGRAM IN CONTROL *
* IS LOCATED, THE PROGRAM NAME AND STATEMENT NUMBER WILL BE *
* EXTRACTED AND SAVED AS THE TRANSACTION NAME AND PROGRAM NAME *
* RESPECTIVELY. *
* *
* THIS TYPE OF RECORDING WILL CAUSE THE FULL IMPACT OF A SINGLE *
* PROGRAM ON THE WHOLE SYSTEM TO BE ASSESSED IN THE 'TRANSACTION *
* USAGE SUMMARY' REPORT AND THE BREAK DOWN OF THE IMPACT ON EACH *
* STATEMENT WITHIN A PARTICULAR PROGRAM IN THE 'TRANSACTION *
* USAGE BY CONTROL SECTION' REPORT. *
* *
* FOR STROBE REL. 2.2.1 AND HIGHER, THIS EXIT MUST BE CODED *
* RE-ENTERANT, AND THE LOAD MODULE MUST BE MARKED WITH THE *
* RENT (RE-ENTERANT) ATTRIBUTE. BE SURE TO SPECIFY OPTION *
* ’RENT’ IN THE LINKAGE EDITOR STEP FOR THIS MODULE. *
* *
* *
* *
* REVISION HISTORY: *
* *
* REV DATE CHANGE BY *
* --- ------- -------------------------------------------- --- *
* 00 27NOV06 NEW MODULE XXX *
* *
*********************************************************************
STRBDC1 CSECT
STRBDC1 AMODE 31
STRBDC1 RMODE 24
R0 EQU 0 BRANCH WORK REGISTER
R1 EQU 1 BRANCH WORK REGISTER
R2 EQU 2 WORK REGISTER
R3 EQU 3 WORK REGISTER
R4 EQU 4 WORK REGISTER
R5 EQU 5 WORK REGISTER
R6 EQU 6 WORK REGISTER
R7 EQU 7 WORK REGISTER
R8 EQU 8 WORK REGISTER
R9 EQU 9 WORK REGISTER
R10 EQU 10 A(LOCAL WORK AREA)
R11 EQU 11 A(DCILCOMM)
R12 EQU 12 BASE REGISTER
R13 EQU 13 A(SAVEAREA)
R14 EQU 14 BRANCH WORK REGISTER
R15 EQU 15 BRANCH WORK REGISTER
SPACE
B BEGIN-STRBDC1(R15) BRANCH AROUND HEADER
DC AL1(FILL-*-1) LENGTH OF IDENTIFIER
DC CL17'STROBE COLLECTOR '
DC CL1' '
DC CL8'STRBDC1'
DC CL1' '
GENID DC CL4'V-00'
IDSIZE EQU *-STRBDC1 CALC SIZE OF HEADER
FILL DC XL(64-IDSIZE)'00' FILL TO EP+64
*
* THE FOLLOWING TABLE MUST BEGIN AT ENTRY POINT +64 BYTES.
*
ADDRLIST DS 0F
DC 3A(0) UNUSED
DCCPCST DC A(PCSECTBL) A(PSEUDO-CSECT TABLE)
DC AL1(0) UNUSED
DCCLIST DC AL3(PROGRAMS) LIST OF PROGRAMS SUPPORTED
*
* PSEUDO-CSECT TABLE
*
PCSECTBL DS 0F
DC X'FF' MARK END OF TABLE
*
* LIST OF SUPPORTED PROGRAMS
*
PROGRAMS DS 0F
DC CL8'********' RUN WHENEVER INVOKED
DC X'80' MARK END OF TABLE
*
* START OF COLLECTOR CODE
*
BEGIN DS 0H
STM R14,R12,12(R13) SAVE REGS
LR R12,R15 SET NEW BASE
USING STRBDC1,R12 ESTABLISH ADDRESSABILITY
LR R11,R1 GET A(DCILCOMM)
USING DCILCOMM,R11 ESTABLISH ADDRESSABILITY
*
* GET THE ADDRESS OF THE LOCAL WORK AREA. IF IT HASN'T BEEN
* ALLOCATED THEN ALLOCATE AND INITIALIZE IT.
*
USING LWA,R10 ESTABLISH ADDRESSABILITY
L R10,DCILCOLA GET A(LWA)
LTR R10,R10 UNALLOCATED?
BZ ALLOCLWA YES, GO ALLOCATE IT
CLC LWA(4),DC1EYEC OUR EYECATCH THERE?
BE GOT_LWA YUP, WE ALREADY HAVE IT
ALLOCLWA DS 0H
LA R2,0 CLEAR REGISTER 2
IPK 0 GET PSW KEY INTO R2
LA R3,LWALEN LENGTH LWA STORAGE
STORAGE OBTAIN, ACQUIRE LWA STORAGE X
LENGTH=(R3), LENGTH X
LOC=(ANY), ABOVE THE LINE X
SP=130, SUBPOOL 130 X
KEY=(R2), IN USER’S KEY X
COND=NO MUST GET IT
LTR R15,R15 DID WE GET IT?
BNZ EXITNCHN NO, GO EXIT
LR R10,R1 @(ACQUIRED STORAGE)
LR R4,R10 CLEAR
LA R5,LWALEN THE
LA R6,DC1EYEC LOCAL
LA R7,L'DC1EYEC WORK
MVCL R4,R6 AREA
GOT_LWA DS 0H
ST R13,SAVEAREA+4 CHAIN
LA R13,SAVEAREA SAVEAREA
*
* MAKE SURE THE ACTIVITY/WAIT IN TINTERPT, THE 4GL INTERPRETER.
*
L R1,DCILCPSW GET THE CURRENT PSW
LA R1,0(R1) AND CLEAN IT UP
BAL R14,CHKFORTI GO CHECK FOR TINTERPT
LTR R15,R15 IS THIS IT?
BNZ EXIT NO, WE AREN'T INTERESTED
*
* GET R8 FROM THE CURRENT TCB AND VERIFY THAT ITS IT TMAINCB, THE
* INTERPRETER ANCHOR CONTROL BLOCK.
*
L R3,DCILCTCB @(CURRENT TCB)
SLL R3,8 CLEAN FOR A
SRL R3,8 24-BIT ADDRESS
L R3,TCBGRS8-TCB(R3) GET SAVED R8
CLC 0(8,R3),=CL8'TMAINCB' IS IT TMAINCB?
BNE EXIT NO, NOT INTERESTED
*
* NAVIGATE FROM TMAINCB TO THE CURRENT TASK CONTROL BLOCK, TCURTASK,
* AND THEN TO THE CURRENT TASK'S PROGRAM CONTROL BLOCK, TCURPROG.
* TCURPROG CONTAINS THE NAME OF THE PROGRAM AND STATEMENT NUMBER
* CURRENTLY BEING PROCESSED BY THE INTERPRETER.
*
L R3,X'138'(R3) @(TCURTASK)
LTR R3,R3 ADDRESS FOUND?
BZ EXIT NO, NOT INTERESTED
L R3,X'24'(R3) @(TCURPROG)
LTR R3,R3 ADDRESS FOUND?
BZ EXIT NO, NOT INTERESTED
*
* R3 CURRENTLY POINTS AT THE TCURPROG CONTROL BLOCK. EXTRACT THE
* ADDRESS OF THE PROGRAM NAME AND STATEMENT NUMBER BEING PROCESSED BY
* THE INTERPRETER AND SAVE THE INFORMATION INTO DCILCOMM.
*
LA R15,X'18'(R3) GET A(8-CHAR PROG NAME)
ST R15,DCILCNMA AND SAVE AS TRAN NAME
MVC LWASTMTN(2),=CL2' ' SET 1ST 2-CHARS TO SPACES
MVC LWASTMTN+2(6),X'20'(R3) GET 6-CHAR STMT #
LA R15,LWASTMTN GET A(8-CHAR STMT NUMBER)
ST R15,DCILCNMA AND SAVE AS PROG NAME
*
* PROGRAM EXIT
*
EXIT DS 0H
LA R13,4(R13) GET A(ENTRY SAVEAREA)
EXITNCHN DS 0H
LM R14,R12,12(R13) RESTORE REGS
BR R14 RETURN TO CALLER
EJECT
**********************************************************************
* *
* SEARCH THE JPQ TO VERIFY THAT THE PSW ADDRESS PASSED IN R1 *
* REPRESENTS ACTIVIY/WAIT IN TINTERPT, THE TEST INTERPRETER. *
* *
* REGS ON ENTRY: *
* R1 - ADDRESS TO BE IDENTIFIED. THIS ADDRESS IS ASSUMED TO *
* BE ALREADY 'CLEANED' FOR EITHER A 24- OR 31-BIT ADDRESS *
* PRIOR TO INVOKING THIS ROUTINE *
* R11 - A(DCILCOMM) *
* R12 - BASE REG *
* R13 - A(INPUT SAVEAREA) *
* R14 - RETURN ADDRESS *
* *
* EXIT REGS: (ONLY CHANGED REGS) *
* R15 - 0, IF THE PSW ADDRESS PASSED IN R1 REPRESENTS ACTIVITY/ *
* WAIT IN TINTERPT. *
* R15 - 4, IF THE PSW ADDRESS PASSED IN R1 DOES NOT REPRESENT *
* ACTIVITY/WAIT IN TINTERPT. *
* *
**********************************************************************
CHKFORTI DS 0H
STM R14,R12,12(R13) SAVE REGS
LTR R1,R1 ADDRESS PASSED?
BZ CFTIRC4 NO, RETURN W/RC=4
L R15,DCILCTCB @(CURRENT TCB)
L R15,TCBJSTCB-TCB(R15) @(JSTCB)
L R15,TCBJPQ-TCB(R15) @(1ST CDE)
B CFTILOOP+4 ENTER LOOP
CFTILOOP DS 0H
L R15,CDCHAIN-CDENTRY(R15) @(NEXT CDE)
LTR R15,R15 IS IT THERE?
BZ CFTIRC4 NO, RETURN W/RC=4
TM CDATTR2-CDENTRY(R15),CDXLE XTLST BUILT?
BZ CFTILOOP NO, TRY NEXT CDE
TM CDATTR-CDENTRY(R15),CDMIN MINOR CDE?
BO CFTILOOP YES, TRY NEXT CDE
TM CDATTRB-CDENTRY(R15),CDIDENTY ALIAS?
BO CFTILOOP YES, TRY NEXT CDE
L R3,CDXLMJP-CDENTRY(R15) @(XTLST)
LTR R3,R3 IS IT THERE?
BZ CFTILOOP NO, TRY NEXT CDE
L R2,XTLMSBAD-XTLST(R3) GET A(LOAD MODULE) AND
LA R2,0(R2) TURN OFF HIGH-ORDER BIT
CR R1,R2 ADDR BEFORE A(LOAD MOD)?
BL CFTILOOP YUP, TRY THE NEXT CDE
L R3,XTLMSBLA-XTLST(R3) GET LOAD MODULE LENGTH
SLL R3,8 AND CLEAN OFF THE
SRL R3,8 FIRST BYTE
LA R2,0(R3,R2) CALC END ADDR OF LOAD MOD
CR R1,R2 ADDRESS IN LOAD MOD?
BNL CFTILOOP NO, TRY NEXT CDE
CLC CDNAME-CDENTRY(8,R15),=CL8'TINTERPT' IS IT TINTERPT?
BNE CFTIRC4 NO, RETURN W/RC=4
LA R15,0 YES, SET RC=0
B CFTIEXIT AND GO RETURN
CFTIRC4 DS 0H
LA R15,4 SET RC TO NOT TINTERPT
CFTIEXIT DS 0H
L R14,12(R13) RESTORE R14
LM R0,R12,20(R13) R0-R12
BR R14 RETURN TO CALLER
DROP R10 DROP ADDRESS - LWA
DROP R11 DROP ADDRESS - DCILCOMM
DROP R12 DROP ADDRESS - BASE REG
*
* CONSTANTS
*
DC1EYEC DC CL4'DC1 ' LWA EYECATCH
*
DCOM_LEN EQU *-STRBDC1 LENGTH OF CSECT
*
* DATA COLLECTOR COMMUNICATION AREA DSECT
*
STR$DCIL TYPE=DSECT,UDC=Y
EJECT
*
* LOCAL WORK AREA DSECT
*
LWA DSECT
SAVEAREA DS 18F SAVEAREA 18 FULLWORDS
LWASTMTN DS CL8 ID'D MODULE NAME
LWALEN EQU *-LWA
EJECT
*
* MVS DSECTS
*
PRINT NOGEN
IKJTCB TCB
IHARB RB
IHACDE CDE
IHAXTLST XTLST
END
* *
* STRBDC1 - SAMPLE DATA COLLECTOR FOR STROBE *
* *
* THE PURPOSE OF THIS DATA COLLECTOR IS TO GIVE AN EXAMPLE OF *
* A DATA COLLECTOR THAT SUPPLIES PROGRAM NAME AND STATEMENT *
* NUMBER FOR THE 4GL PROGRAM THAT ORIGINATED THE OBSERVED *
* ACTIVITY/WAIT. *
* *
* IF THE OBSERVED ACTIVITY/WAIT IS IN A MVS LOADED MODULE, *
* TINTERPT (A FICTIONAL INTERPRETER), THEN THE DATA COLLECTOR *
* WILL NAVIGATE FROM THE R8 SAVED IN THE TCB THROUGH A SERIES *
* OF SUBSYSTEM SPECIFIC CONTROL BLOCKS TO THE STRUCTURE THAT *
* REPRESENTS THE USER WRITTEN 4GL PROGRAM THAT IS CURRENTLY *
* EXECUTING. *
* *
* ONCE THE CONTROL BLOCK REPRESENTING THE 4GL PROGRAM IN CONTROL *
* IS LOCATED, THE PROGRAM NAME AND STATEMENT NUMBER WILL BE *
* EXTRACTED AND SAVED AS THE TRANSACTION NAME AND PROGRAM NAME *
* RESPECTIVELY. *
* *
* THIS TYPE OF RECORDING WILL CAUSE THE FULL IMPACT OF A SINGLE *
* PROGRAM ON THE WHOLE SYSTEM TO BE ASSESSED IN THE 'TRANSACTION *
* USAGE SUMMARY' REPORT AND THE BREAK DOWN OF THE IMPACT ON EACH *
* STATEMENT WITHIN A PARTICULAR PROGRAM IN THE 'TRANSACTION *
* USAGE BY CONTROL SECTION' REPORT. *
* *
* FOR STROBE REL. 2.2.1 AND HIGHER, THIS EXIT MUST BE CODED *
* RE-ENTERANT, AND THE LOAD MODULE MUST BE MARKED WITH THE *
* RENT (RE-ENTERANT) ATTRIBUTE. BE SURE TO SPECIFY OPTION *
* ’RENT’ IN THE LINKAGE EDITOR STEP FOR THIS MODULE. *
* *
* *
* *
* REVISION HISTORY: *
* *
* REV DATE CHANGE BY *
* --- ------- -------------------------------------------- --- *
* 00 27NOV06 NEW MODULE XXX *
* *
*********************************************************************
STRBDC1 CSECT
STRBDC1 AMODE 31
STRBDC1 RMODE 24
R0 EQU 0 BRANCH WORK REGISTER
R1 EQU 1 BRANCH WORK REGISTER
R2 EQU 2 WORK REGISTER
R3 EQU 3 WORK REGISTER
R4 EQU 4 WORK REGISTER
R5 EQU 5 WORK REGISTER
R6 EQU 6 WORK REGISTER
R7 EQU 7 WORK REGISTER
R8 EQU 8 WORK REGISTER
R9 EQU 9 WORK REGISTER
R10 EQU 10 A(LOCAL WORK AREA)
R11 EQU 11 A(DCILCOMM)
R12 EQU 12 BASE REGISTER
R13 EQU 13 A(SAVEAREA)
R14 EQU 14 BRANCH WORK REGISTER
R15 EQU 15 BRANCH WORK REGISTER
SPACE
B BEGIN-STRBDC1(R15) BRANCH AROUND HEADER
DC AL1(FILL-*-1) LENGTH OF IDENTIFIER
DC CL17'STROBE COLLECTOR '
DC CL1' '
DC CL8'STRBDC1'
DC CL1' '
GENID DC CL4'V-00'
IDSIZE EQU *-STRBDC1 CALC SIZE OF HEADER
FILL DC XL(64-IDSIZE)'00' FILL TO EP+64
*
* THE FOLLOWING TABLE MUST BEGIN AT ENTRY POINT +64 BYTES.
*
ADDRLIST DS 0F
DC 3A(0) UNUSED
DCCPCST DC A(PCSECTBL) A(PSEUDO-CSECT TABLE)
DC AL1(0) UNUSED
DCCLIST DC AL3(PROGRAMS) LIST OF PROGRAMS SUPPORTED
*
* PSEUDO-CSECT TABLE
*
PCSECTBL DS 0F
DC X'FF' MARK END OF TABLE
*
* LIST OF SUPPORTED PROGRAMS
*
PROGRAMS DS 0F
DC CL8'********' RUN WHENEVER INVOKED
DC X'80' MARK END OF TABLE
*
* START OF COLLECTOR CODE
*
BEGIN DS 0H
STM R14,R12,12(R13) SAVE REGS
LR R12,R15 SET NEW BASE
USING STRBDC1,R12 ESTABLISH ADDRESSABILITY
LR R11,R1 GET A(DCILCOMM)
USING DCILCOMM,R11 ESTABLISH ADDRESSABILITY
*
* GET THE ADDRESS OF THE LOCAL WORK AREA. IF IT HASN'T BEEN
* ALLOCATED THEN ALLOCATE AND INITIALIZE IT.
*
USING LWA,R10 ESTABLISH ADDRESSABILITY
L R10,DCILCOLA GET A(LWA)
LTR R10,R10 UNALLOCATED?
BZ ALLOCLWA YES, GO ALLOCATE IT
CLC LWA(4),DC1EYEC OUR EYECATCH THERE?
BE GOT_LWA YUP, WE ALREADY HAVE IT
ALLOCLWA DS 0H
LA R2,0 CLEAR REGISTER 2
IPK 0 GET PSW KEY INTO R2
LA R3,LWALEN LENGTH LWA STORAGE
STORAGE OBTAIN, ACQUIRE LWA STORAGE X
LENGTH=(R3), LENGTH X
LOC=(ANY), ABOVE THE LINE X
SP=130, SUBPOOL 130 X
KEY=(R2), IN USER’S KEY X
COND=NO MUST GET IT
LTR R15,R15 DID WE GET IT?
BNZ EXITNCHN NO, GO EXIT
LR R10,R1 @(ACQUIRED STORAGE)
LR R4,R10 CLEAR
LA R5,LWALEN THE
LA R6,DC1EYEC LOCAL
LA R7,L'DC1EYEC WORK
MVCL R4,R6 AREA
GOT_LWA DS 0H
ST R13,SAVEAREA+4 CHAIN
LA R13,SAVEAREA SAVEAREA
*
* MAKE SURE THE ACTIVITY/WAIT IN TINTERPT, THE 4GL INTERPRETER.
*
L R1,DCILCPSW GET THE CURRENT PSW
LA R1,0(R1) AND CLEAN IT UP
BAL R14,CHKFORTI GO CHECK FOR TINTERPT
LTR R15,R15 IS THIS IT?
BNZ EXIT NO, WE AREN'T INTERESTED
*
* GET R8 FROM THE CURRENT TCB AND VERIFY THAT ITS IT TMAINCB, THE
* INTERPRETER ANCHOR CONTROL BLOCK.
*
L R3,DCILCTCB @(CURRENT TCB)
SLL R3,8 CLEAN FOR A
SRL R3,8 24-BIT ADDRESS
L R3,TCBGRS8-TCB(R3) GET SAVED R8
CLC 0(8,R3),=CL8'TMAINCB' IS IT TMAINCB?
BNE EXIT NO, NOT INTERESTED
*
* NAVIGATE FROM TMAINCB TO THE CURRENT TASK CONTROL BLOCK, TCURTASK,
* AND THEN TO THE CURRENT TASK'S PROGRAM CONTROL BLOCK, TCURPROG.
* TCURPROG CONTAINS THE NAME OF THE PROGRAM AND STATEMENT NUMBER
* CURRENTLY BEING PROCESSED BY THE INTERPRETER.
*
L R3,X'138'(R3) @(TCURTASK)
LTR R3,R3 ADDRESS FOUND?
BZ EXIT NO, NOT INTERESTED
L R3,X'24'(R3) @(TCURPROG)
LTR R3,R3 ADDRESS FOUND?
BZ EXIT NO, NOT INTERESTED
*
* R3 CURRENTLY POINTS AT THE TCURPROG CONTROL BLOCK. EXTRACT THE
* ADDRESS OF THE PROGRAM NAME AND STATEMENT NUMBER BEING PROCESSED BY
* THE INTERPRETER AND SAVE THE INFORMATION INTO DCILCOMM.
*
LA R15,X'18'(R3) GET A(8-CHAR PROG NAME)
ST R15,DCILCNMA AND SAVE AS TRAN NAME
MVC LWASTMTN(2),=CL2' ' SET 1ST 2-CHARS TO SPACES
MVC LWASTMTN+2(6),X'20'(R3) GET 6-CHAR STMT #
LA R15,LWASTMTN GET A(8-CHAR STMT NUMBER)
ST R15,DCILCNMA AND SAVE AS PROG NAME
*
* PROGRAM EXIT
*
EXIT DS 0H
LA R13,4(R13) GET A(ENTRY SAVEAREA)
EXITNCHN DS 0H
LM R14,R12,12(R13) RESTORE REGS
BR R14 RETURN TO CALLER
EJECT
**********************************************************************
* *
* SEARCH THE JPQ TO VERIFY THAT THE PSW ADDRESS PASSED IN R1 *
* REPRESENTS ACTIVIY/WAIT IN TINTERPT, THE TEST INTERPRETER. *
* *
* REGS ON ENTRY: *
* R1 - ADDRESS TO BE IDENTIFIED. THIS ADDRESS IS ASSUMED TO *
* BE ALREADY 'CLEANED' FOR EITHER A 24- OR 31-BIT ADDRESS *
* PRIOR TO INVOKING THIS ROUTINE *
* R11 - A(DCILCOMM) *
* R12 - BASE REG *
* R13 - A(INPUT SAVEAREA) *
* R14 - RETURN ADDRESS *
* *
* EXIT REGS: (ONLY CHANGED REGS) *
* R15 - 0, IF THE PSW ADDRESS PASSED IN R1 REPRESENTS ACTIVITY/ *
* WAIT IN TINTERPT. *
* R15 - 4, IF THE PSW ADDRESS PASSED IN R1 DOES NOT REPRESENT *
* ACTIVITY/WAIT IN TINTERPT. *
* *
**********************************************************************
CHKFORTI DS 0H
STM R14,R12,12(R13) SAVE REGS
LTR R1,R1 ADDRESS PASSED?
BZ CFTIRC4 NO, RETURN W/RC=4
L R15,DCILCTCB @(CURRENT TCB)
L R15,TCBJSTCB-TCB(R15) @(JSTCB)
L R15,TCBJPQ-TCB(R15) @(1ST CDE)
B CFTILOOP+4 ENTER LOOP
CFTILOOP DS 0H
L R15,CDCHAIN-CDENTRY(R15) @(NEXT CDE)
LTR R15,R15 IS IT THERE?
BZ CFTIRC4 NO, RETURN W/RC=4
TM CDATTR2-CDENTRY(R15),CDXLE XTLST BUILT?
BZ CFTILOOP NO, TRY NEXT CDE
TM CDATTR-CDENTRY(R15),CDMIN MINOR CDE?
BO CFTILOOP YES, TRY NEXT CDE
TM CDATTRB-CDENTRY(R15),CDIDENTY ALIAS?
BO CFTILOOP YES, TRY NEXT CDE
L R3,CDXLMJP-CDENTRY(R15) @(XTLST)
LTR R3,R3 IS IT THERE?
BZ CFTILOOP NO, TRY NEXT CDE
L R2,XTLMSBAD-XTLST(R3) GET A(LOAD MODULE) AND
LA R2,0(R2) TURN OFF HIGH-ORDER BIT
CR R1,R2 ADDR BEFORE A(LOAD MOD)?
BL CFTILOOP YUP, TRY THE NEXT CDE
L R3,XTLMSBLA-XTLST(R3) GET LOAD MODULE LENGTH
SLL R3,8 AND CLEAN OFF THE
SRL R3,8 FIRST BYTE
LA R2,0(R3,R2) CALC END ADDR OF LOAD MOD
CR R1,R2 ADDRESS IN LOAD MOD?
BNL CFTILOOP NO, TRY NEXT CDE
CLC CDNAME-CDENTRY(8,R15),=CL8'TINTERPT' IS IT TINTERPT?
BNE CFTIRC4 NO, RETURN W/RC=4
LA R15,0 YES, SET RC=0
B CFTIEXIT AND GO RETURN
CFTIRC4 DS 0H
LA R15,4 SET RC TO NOT TINTERPT
CFTIEXIT DS 0H
L R14,12(R13) RESTORE R14
LM R0,R12,20(R13) R0-R12
BR R14 RETURN TO CALLER
DROP R10 DROP ADDRESS - LWA
DROP R11 DROP ADDRESS - DCILCOMM
DROP R12 DROP ADDRESS - BASE REG
*
* CONSTANTS
*
DC1EYEC DC CL4'DC1 ' LWA EYECATCH
*
DCOM_LEN EQU *-STRBDC1 LENGTH OF CSECT
*
* DATA COLLECTOR COMMUNICATION AREA DSECT
*
STR$DCIL TYPE=DSECT,UDC=Y
EJECT
*
* LOCAL WORK AREA DSECT
*
LWA DSECT
SAVEAREA DS 18F SAVEAREA 18 FULLWORDS
LWASTMTN DS CL8 ID'D MODULE NAME
LWALEN EQU *-LWA
EJECT
*
* MVS DSECTS
*
PRINT NOGEN
IKJTCB TCB
IHARB RB
IHACDE CDE
IHAXTLST XTLST
END
Data Collector Program for Transaction Profiling in CICS
********************************* Top of Data ********************************
TITLE 'IBM Data Areas'
IKJTCB
DFHAFCD
DFHKERN TYPE=OFFSETS
COPY DFHTCADS
TITLE 'Data Collector Communication Area'
STR$DCIL TYPE=DSECT,LABL=UDCA,UDC=Y
TITLE 'STRBUDCS - Strobe User Data Collector Sample'
STRBUDCS CSECT
STRBUDCS AMODE 31
STRBUDCS RMODE ANY
*
USING STRBUDCS,R15 Temporary base
B UDCS_00
*********************************************************************
* *
* STRBUDCS - User Data Collector Sample *
* *
* This instance modifies ONLY the transaction name via an *
* update to UDCACTRA. Field UDCACNMA is not modified along *
* with related fields UDCACBAS and UDCACSIZ. *
* *
* Using the IBM-supplied DSECTs it can have CICS version *
* dependencies. *
* *
* There exists code to replace the CICS transaction ID with a *
* four character diagnostic ID because the CICS TWA will not *
* always be available even when the CICS transaction is defined *
* with a TWA. Using these diagnostic codes is entirely optional. *
* *
*********************************************************************
*
R0 EQU 0 Work
R1 EQU 1 Work
R2 EQU 2 Work
R3 EQU 3 Work
R4 EQU 4 Various control blocks and TWA
R5 EQU 5 Work
R6 EQU 6 Work
R7 EQU 7 Work
R8 EQU 8 Work
R9 EQU 9 Work
R10 EQU 10 Work
R11 EQU 11 UDCA Base
R12 EQU 12 Program Base
R13 EQU 13 A(Save Area)
R14 EQU 14 Work
R15 EQU 15 Work
*
DC AL1(FILL-*-1)
DC CL17'STROBE COLLECTOR ' Required
DC CL1' '
DC CL8'STRBUDCS'
DC CL1' '
GENID DC CL4'V-00'
FILL DC XL(64-(*-STRBUDCS))'00' Fill to +64 bytes
EJECT
********************************************************************
***
** Test User Data Collector - Preamble
** -The following MUST be located at A(entry point+64).
*
ADDRLIST DS 0F
DC 3A(0) - Unused -
*
DCCPCST DC A(0) A(pseudo-csect table)
DCCSW DC AL1(0) - Unused -
*
DCCLIST DC A(PROGRAMS) List of programs supported
*
***********************************************************************
***
** List of supported programs
*
PROGRAMS DS 0F
DC CL8'********' Run whenever invoked
DC X'80' Mark end of table
DROP R15
EJECT
***********************************************************************
***
** Start of data collector code
*
USING UDCA,R11 Establish addressability
USING STRBUDCS,R12 Establish addressability
UDCS_00 DS 0H
STM R14,R12,12(R13) Save Strobe's registers
LR R12,R15 STRBUDCS base
LR R11,R1 UDCA base
TM UDCACFLG,UDCACPTWA Is this TWA call?
BO UDCS_60 -Yes, TWA provided
*
* Requires Strobe parameter UDCCDSS=YES to capture at CPU sample time
TM UDCACFLG,UDCACPSAM Is this sample time?
BNO UDCS_99 -No, just exit
ICM R9,B'1111',UDCACOLA Have Ptr-> UDCS work area?
BM UDCS_99 -No, had prior failure
BP UDCS_40 -Yes, have UDCA work go find TWA
L R9,=F'-1' Fail ALL future calls if
ST R9,UDCACOLA STORAGE OBTAIN fails.
XR R2,R2 Clear again
IPK , Extract PSW key
LA R3,UDCS_WAL Workarea size
STORAGE OBTAIN, Get a workarea -
LENGTH=(R3), -
LOC=(ANY), -
KEY=(R2), -
SP=130, -
COND=NO
LTR R9,R1 Success?
BZ UDCS_99 -No, bail
LR R0,R1 Clear out
LR R1,R3 our new
XR R14,R14 work area
XR R15,R15
MVCL R0,R14
ST R9,UDCACOLA Keep it for next time
USING UDCS_WA,R9 Address our work area
MVC UDCS_Eye,UDCSEye Set eyecatcher
*----------------------------------------------------------------------
* Find TWA address from CICS TCB address
*----------------------------------------------------------------------
UDCS_40 DS 0H Have to locate the TWA
CLC UDCS_Eye,UDCSEYE Validate integrity
BNE UDCS_99 Something is wrong
DROP R9 Lose UDCS_WA
ST R13,4(,R9) Back link
ST R9,8(,R13) Forward link
LR R13,R9
USING UDCS_WA,R13 Address our work area
LLGT R4,UDCACTCB Load Ptr-> CICS TCB
LTR R4,R4 Have it?
BZ UDCS_50 -No, debug
ICM R4,15,TCBEXT2-TCB(R4) Load Ptr-> TCBEXT2
BZ UDCS_51 -None, debug
ICM R4,15,TCBCAUF-TCBXTNT2(R4) Load Ptr-> AFCB
BZ UDCS_52 -None, debug
AH R4,AFLENG-DFHAFCB(,R4) +Length to DWORD table
LA R4,AFPFXLEN(,R4) +Prefix length
ICM R4,15,AFTKTCB-AFTSTART(R4) Load Ptr-> KTCB
BZ UDCS_53 -None, debug
LLGT R4,KTCB_ACTIVE_TASK_OFFSET(,R4) Load Ptr-> Task entry
LTGR R4,R4 Have it?
BZ UDCS_55 -None, debug
LLGT R4,TAS_TCA_ADDRESS_OFFSET(,R4) Load Ptr-> User TCA
LTGR R4,R4 Have it?
BZ UDCS_54 -None, debug
USING DFHTCADS,R4 Address UTCA
ICM R0,15,TCATWALN TCATWALN > 0?
BZ UDCS_56 -No, debug
ICM R4,15,TCATWAAD Load Ptr-> tran TWA
BZ UDCS_56 -None, debug
DROP R4 Lose DFHTCADS
USING TWADS,R4 Address TWA
LA R15,ALIAS Load Ptr-> replacement tranID
OC ALIAS,ALIAS Tran ID there?
BZ UDCS_58 -No, flag it
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
DROP R4 Loase TWADS
*-----------------------------------------------------------------------------
* Diagnostics when finding the TWA from CICS TCB
*-----------------------------------------------------------------------------
UDCS_50 DS 0H
LA R15,UDCSNOTC Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_51 DS 0H
LA R15,UDCSNOTX Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_52 DS 0H
LA R15,UDCSNCAU Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_53 DS 0H
LA R15,UDCSNKTC Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_54 DS 0H
LA R15,UDCSNTAS Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_55 DS 0H
LA R15,UDCSNTCA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_56 DS 0H
LA R15,UDCSNTWA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_58 DS 0H
LA R15,UDCSNOAL Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90
DROP R13 Lose UDCS_WA
*----------------------------------------------------------------------
* TWA address provided by Strobe, if no TWA should not get here.
*----------------------------------------------------------------------
UDCS_60 DS 0H When TWA provided come here
LA R9,UDCAUWRK Load Ptr-> UDC work area
USING UDCS_CW,R9 Address CW provided work area
*
ICM R4,15,UDCACTCB Load Ptr-> TWA
BZ UDCS_70 -Ensure no abend
USING TWADS,R4 Address TWA
LA R15,ALIAS Load Ptr-> replacement tranID
OC ALIAS,ALIAS Tran ID there?
BZ UDCS_80 -No, flag it
DROP R4,R9 Lose TWADS, UDCS_CW
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99 Continue
*----------------------------------------------------------------------
* Diagnostics when called with TWA.
*----------------------------------------------------------------------
UDCS_70 DS 0H
LA R15,UDCSNTWA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99 Continue
UDCS_80 DS 0H
LA R15,UDCSNOAL Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99
EJECT
UDCS_90 DS 0H Exit having obtained workarea
L R13,4(,R13) Point to caller's save area
UDCS_99 DS 0H
LM R14,R12,12(R13) Restore Strobe's registers
BR R14 Return
DROP R11 Lose UDCA
EJECT
***********************************************************************
***
** Static data areas
*
DS 0D
UDCSEYE DC CL8'STRBUDCS' UDCS work area eyecatcher
UDCSNOTC DC CL8'NTCB ' No TCB
UDCSNOTX DC CL8'NTCX ' No TCBEXT2
UDCSNCAU DC CL8'NCAU ' No AFCB
UDCSNKTC DC CL8'NKTC ' No KTCB
UDCSNTAS DC CL8'NTAS ' No TASENTRY
UDCSNTCA DC CL8'NTCA ' No TCA
UDCSNTWA DC CL8'NTWA ' No TWA
UDCSNOAL DC CL8'NOAL ' No alias in TWA
LTORG
*
EJECT
***********************************************************************
***
** Collector obtained work area
*
UDCS_WA DSECT
*
DS 18F Save area
*
UDCS_Eye DS CL(L'UDCSEYE) Eyecatcher
DS (512-(*-UDCS_WA))XL1 Available
*
UDCS_WAL EQU *-UDCS_WA Work area length
EJECT
***********************************************************************
***
** Strobe provided work area 256 bytes fixed
*
UDCS_CW DSECT
UDCS_WRK DS (UDCAUWRL)XL1 Available
UDCS_CWL EQU *-UDCS_CW Work area length
*
* Sample CICS TWA
TWADS DSECT
ALIAS DS CL4
DS (256-(*-TWADS))XL1 Unused
TWADSLEN EQU *-TWADS
END
******************************** Bottom of Data ******************************
TITLE 'IBM Data Areas'
IKJTCB
DFHAFCD
DFHKERN TYPE=OFFSETS
COPY DFHTCADS
TITLE 'Data Collector Communication Area'
STR$DCIL TYPE=DSECT,LABL=UDCA,UDC=Y
TITLE 'STRBUDCS - Strobe User Data Collector Sample'
STRBUDCS CSECT
STRBUDCS AMODE 31
STRBUDCS RMODE ANY
*
USING STRBUDCS,R15 Temporary base
B UDCS_00
*********************************************************************
* *
* STRBUDCS - User Data Collector Sample *
* *
* This instance modifies ONLY the transaction name via an *
* update to UDCACTRA. Field UDCACNMA is not modified along *
* with related fields UDCACBAS and UDCACSIZ. *
* *
* Using the IBM-supplied DSECTs it can have CICS version *
* dependencies. *
* *
* There exists code to replace the CICS transaction ID with a *
* four character diagnostic ID because the CICS TWA will not *
* always be available even when the CICS transaction is defined *
* with a TWA. Using these diagnostic codes is entirely optional. *
* *
*********************************************************************
*
R0 EQU 0 Work
R1 EQU 1 Work
R2 EQU 2 Work
R3 EQU 3 Work
R4 EQU 4 Various control blocks and TWA
R5 EQU 5 Work
R6 EQU 6 Work
R7 EQU 7 Work
R8 EQU 8 Work
R9 EQU 9 Work
R10 EQU 10 Work
R11 EQU 11 UDCA Base
R12 EQU 12 Program Base
R13 EQU 13 A(Save Area)
R14 EQU 14 Work
R15 EQU 15 Work
*
DC AL1(FILL-*-1)
DC CL17'STROBE COLLECTOR ' Required
DC CL1' '
DC CL8'STRBUDCS'
DC CL1' '
GENID DC CL4'V-00'
FILL DC XL(64-(*-STRBUDCS))'00' Fill to +64 bytes
EJECT
********************************************************************
***
** Test User Data Collector - Preamble
** -The following MUST be located at A(entry point+64).
*
ADDRLIST DS 0F
DC 3A(0) - Unused -
*
DCCPCST DC A(0) A(pseudo-csect table)
DCCSW DC AL1(0) - Unused -
*
DCCLIST DC A(PROGRAMS) List of programs supported
*
***********************************************************************
***
** List of supported programs
*
PROGRAMS DS 0F
DC CL8'********' Run whenever invoked
DC X'80' Mark end of table
DROP R15
EJECT
***********************************************************************
***
** Start of data collector code
*
USING UDCA,R11 Establish addressability
USING STRBUDCS,R12 Establish addressability
UDCS_00 DS 0H
STM R14,R12,12(R13) Save Strobe's registers
LR R12,R15 STRBUDCS base
LR R11,R1 UDCA base
TM UDCACFLG,UDCACPTWA Is this TWA call?
BO UDCS_60 -Yes, TWA provided
*
* Requires Strobe parameter UDCCDSS=YES to capture at CPU sample time
TM UDCACFLG,UDCACPSAM Is this sample time?
BNO UDCS_99 -No, just exit
ICM R9,B'1111',UDCACOLA Have Ptr-> UDCS work area?
BM UDCS_99 -No, had prior failure
BP UDCS_40 -Yes, have UDCA work go find TWA
L R9,=F'-1' Fail ALL future calls if
ST R9,UDCACOLA STORAGE OBTAIN fails.
XR R2,R2 Clear again
IPK , Extract PSW key
LA R3,UDCS_WAL Workarea size
STORAGE OBTAIN, Get a workarea -
LENGTH=(R3), -
LOC=(ANY), -
KEY=(R2), -
SP=130, -
COND=NO
LTR R9,R1 Success?
BZ UDCS_99 -No, bail
LR R0,R1 Clear out
LR R1,R3 our new
XR R14,R14 work area
XR R15,R15
MVCL R0,R14
ST R9,UDCACOLA Keep it for next time
USING UDCS_WA,R9 Address our work area
MVC UDCS_Eye,UDCSEye Set eyecatcher
*----------------------------------------------------------------------
* Find TWA address from CICS TCB address
*----------------------------------------------------------------------
UDCS_40 DS 0H Have to locate the TWA
CLC UDCS_Eye,UDCSEYE Validate integrity
BNE UDCS_99 Something is wrong
DROP R9 Lose UDCS_WA
ST R13,4(,R9) Back link
ST R9,8(,R13) Forward link
LR R13,R9
USING UDCS_WA,R13 Address our work area
LLGT R4,UDCACTCB Load Ptr-> CICS TCB
LTR R4,R4 Have it?
BZ UDCS_50 -No, debug
ICM R4,15,TCBEXT2-TCB(R4) Load Ptr-> TCBEXT2
BZ UDCS_51 -None, debug
ICM R4,15,TCBCAUF-TCBXTNT2(R4) Load Ptr-> AFCB
BZ UDCS_52 -None, debug
AH R4,AFLENG-DFHAFCB(,R4) +Length to DWORD table
LA R4,AFPFXLEN(,R4) +Prefix length
ICM R4,15,AFTKTCB-AFTSTART(R4) Load Ptr-> KTCB
BZ UDCS_53 -None, debug
LLGT R4,KTCB_ACTIVE_TASK_OFFSET(,R4) Load Ptr-> Task entry
LTGR R4,R4 Have it?
BZ UDCS_55 -None, debug
LLGT R4,TAS_TCA_ADDRESS_OFFSET(,R4) Load Ptr-> User TCA
LTGR R4,R4 Have it?
BZ UDCS_54 -None, debug
USING DFHTCADS,R4 Address UTCA
ICM R0,15,TCATWALN TCATWALN > 0?
BZ UDCS_56 -No, debug
ICM R4,15,TCATWAAD Load Ptr-> tran TWA
BZ UDCS_56 -None, debug
DROP R4 Lose DFHTCADS
USING TWADS,R4 Address TWA
LA R15,ALIAS Load Ptr-> replacement tranID
OC ALIAS,ALIAS Tran ID there?
BZ UDCS_58 -No, flag it
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
DROP R4 Loase TWADS
*-----------------------------------------------------------------------------
* Diagnostics when finding the TWA from CICS TCB
*-----------------------------------------------------------------------------
UDCS_50 DS 0H
LA R15,UDCSNOTC Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_51 DS 0H
LA R15,UDCSNOTX Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_52 DS 0H
LA R15,UDCSNCAU Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_53 DS 0H
LA R15,UDCSNKTC Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_54 DS 0H
LA R15,UDCSNTAS Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_55 DS 0H
LA R15,UDCSNTCA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_56 DS 0H
LA R15,UDCSNTWA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90 Continue
UDCS_58 DS 0H
LA R15,UDCSNOAL Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_90
DROP R13 Lose UDCS_WA
*----------------------------------------------------------------------
* TWA address provided by Strobe, if no TWA should not get here.
*----------------------------------------------------------------------
UDCS_60 DS 0H When TWA provided come here
LA R9,UDCAUWRK Load Ptr-> UDC work area
USING UDCS_CW,R9 Address CW provided work area
*
ICM R4,15,UDCACTCB Load Ptr-> TWA
BZ UDCS_70 -Ensure no abend
USING TWADS,R4 Address TWA
LA R15,ALIAS Load Ptr-> replacement tranID
OC ALIAS,ALIAS Tran ID there?
BZ UDCS_80 -No, flag it
DROP R4,R9 Lose TWADS, UDCS_CW
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99 Continue
*----------------------------------------------------------------------
* Diagnostics when called with TWA.
*----------------------------------------------------------------------
UDCS_70 DS 0H
LA R15,UDCSNTWA Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99 Continue
UDCS_80 DS 0H
LA R15,UDCSNOAL Load Ptr-> debug tranID
ST R15,UDCACTRA Save Ptr-> replacement tranID
B UDCS_99
EJECT
UDCS_90 DS 0H Exit having obtained workarea
L R13,4(,R13) Point to caller's save area
UDCS_99 DS 0H
LM R14,R12,12(R13) Restore Strobe's registers
BR R14 Return
DROP R11 Lose UDCA
EJECT
***********************************************************************
***
** Static data areas
*
DS 0D
UDCSEYE DC CL8'STRBUDCS' UDCS work area eyecatcher
UDCSNOTC DC CL8'NTCB ' No TCB
UDCSNOTX DC CL8'NTCX ' No TCBEXT2
UDCSNCAU DC CL8'NCAU ' No AFCB
UDCSNKTC DC CL8'NKTC ' No KTCB
UDCSNTAS DC CL8'NTAS ' No TASENTRY
UDCSNTCA DC CL8'NTCA ' No TCA
UDCSNTWA DC CL8'NTWA ' No TWA
UDCSNOAL DC CL8'NOAL ' No alias in TWA
LTORG
*
EJECT
***********************************************************************
***
** Collector obtained work area
*
UDCS_WA DSECT
*
DS 18F Save area
*
UDCS_Eye DS CL(L'UDCSEYE) Eyecatcher
DS (512-(*-UDCS_WA))XL1 Available
*
UDCS_WAL EQU *-UDCS_WA Work area length
EJECT
***********************************************************************
***
** Strobe provided work area 256 bytes fixed
*
UDCS_CW DSECT
UDCS_WRK DS (UDCAUWRL)XL1 Available
UDCS_CWL EQU *-UDCS_CW Work area length
*
* Sample CICS TWA
TWADS DSECT
ALIAS DS CL4
DS (256-(*-TWADS))XL1 Unused
TWADSLEN EQU *-TWADS
END
******************************** Bottom of Data ******************************
Tip: For faster searching, add an asterisk to the end of your partial query. Example: cert*