SHOWMRO TITLE  'Show the currently active MRO regions'
*
* Name: SHOWMRO
*
* Author: David Alcock
*         dave@planetmvs.com
*
* Written: 1997-11-11
*
* Purpose: TSO command that shows all of the current CICS MRO regions.
*
* Reference:
* - LY33-6082 CICS/ESA Diagnosis Reference Version 4 Release 1
* - CICS.SDFHSRC(DFHIRPD) macro source. It is not used by this program
*   for these reasons:
*   - Assembly error for field MCNTL and I didn't look into why
*   - Less things to be dependant on. Don't have to worry when IBM
*     Changes the MACRO at release levels.
*
* Requirements:
* - High Level Assembler
* - MVS version 3 and higher (for entry and exit housekeeping)
* - MVS version 4 and higher (for jobname information and STCKCON)
* - CICS at 4.1.0 and higher
*
         SPACE 2
&DAVRM   SETC  '1.2'
*======================================================================
*
*             M o d i f i c a t i o n   H i s t o r y
*
* Person     Date       Ver Description
* ---------- ---------- --- -------------------------------------------
* DGAlcock   2000-07-31 1.2 Convert TOD stamp to local time&date;
*                           Remove msgids;
* RSchiradin 2000-04-25 1.1 Fix for CICS 5.3/CICS Transaction Server
*                           version 1.3 (thanks to Roland Schiradin);
* DGAlcock   1997-11-11 1.0 Initial program written;
*======================================================================
         PRINT NOGEN
*
** IBM DSECTs
*
         CVT   DSECT=YES,LIST=NO          Communications Vector Table
         IEFJESCT                         JES Communications Table
         IEFJSCVT ,                       Subsystem Comm. Vector table
         IEFJSSVT ,                       Subsystem Vector Table
         IHAASVT ,                        Address Space Vector Table
         IHAASCB ,                        Address Space Control Block
         IHAASSB ,                        Address Space Sec. Block
         IAZJSAB ,
         YREGS ,
         PRINT GEN
*
** CICS: DFHSAB - CICS subsystem Anchor Block
** (Based on CICS 4.1)
*
SAB      DSECT ,
SABCDD   DS    F                          Addr of CEC 'inop' data
SABSCTE  DS    F                          Addr of SCTE
SAB_ID   DS    C'DFHSAB'                  Eyecatcher
         ORG   SAB+X'18'
SABMAPPT DS    F                          Addr of bit map: act CICS
         ORG   ,
SABL     EQU   32
*
** CICS: SCTE - Subsystem Control Table Extension
** (Based on CICS 4.1)
*
SCTE     DSECT ,
SCTELACB DS    F
         DS    F
         DS    F
SCTESVC  DS    X'0A00'
         DS    X'0000'
SCTEL    EQU   *-SCTE
*
** CICS: LCB - Logon Control Block
** (Based on CICS 4.1, updated for 5.3)
*
LCB      DSECT ,
         ORG   LCB+X'60'
LCBAPPLD53 DS  CL8' '
         ORG   ,
         ORG   LCB+X'7C'
LCBAPPLD41 DS  CL8' '
         ORG   ,
LCBLNGTH EQU   X'D8'
*
** CICS: LACB - Logon Address Space Control Block
** (Based on CICS 4.1, updated for 5.3)
*
LACB     DSECT ,
         ORG   LACB+X'08'                                        RS0400
LACBSUD2 DS    F               SUDB ptr for CICS 5.3/CTS 1.3     RS0400
LACBSUDB DS    F               SUDB ptr for CICS 4.1
LACBL    EQU   X'58'
*
LACBE    DSECT ,
LACBENM  DS    CL8
LACBELEN EQU   X'14'
*
** CICS: SUDB - SubSystem User Definition Control Block
** (Based on CICS 4.1)
*
SUDB     DSECT ,
SUDBCHN  DS    A
SUDBLACB DS    A
         ORG   SUDB+X'0E'
         DS    H
         DS    F
SUDBASCB DS    F
SUDBJSB  DS    F
SUDBAWS  DS    F
SUDBLCB  DS    F
         ORG   ,
SUDBLEN  EQU   X'58'
*
** Convert assembly date from format "YYYYMMDD" to "YYYY-MM-DD"
*
         LCLC  &ASMDATE
&ASMDATE SETC  '&SYSDATC'(1,4).'-'.'&SYSDATC'(5,2).'-'.'&SYSDATC'(7,2)
         EJECT
***********************************************************************
***
**       Entry housekeeping
***
***********************************************************************
         SPACE 2
SHOWMRO  CSECT ,
SHOWMRO  AMODE 31
SHOWMRO  RMODE ANY
*
** Standard O/S eyecatcher
*
SM_EC    B    SM_ECL(0,R15)             Bump past EyeCatcher
         DC   AL1(SM_ECE-SM_ECV)        Length of eyecatcher
SM_ECV   DC   C'SHOWMRO v&DAVRM - &ASMDATE &SYSTIME - '
         DC   C'TSO command: Show CICS MRO regions via C.B.s'
SM_ECE   EQU  *
         DS   0H
SM_ECL   EQU  *-SM_EC
*
** Standard ESA entry housekeeping
*
         BAKR  R14,0                    Save regs
         LAE   R12,0(R15,0)             Get base register
         USING SHOWMRO,R12              Get addressibility
         SAC   0
         SYSSTATE ASCENV=P
*
** Obtain Dynamic Save Area for Registers and work areas.
*
         STORAGE OBTAIN,LENGTH=DSAL,LOC=BELOW Obtain storage
         LR    R13,R1                   Point to Save Area
         MVC   4(4,R13),=C'F1SA'        Indicate stack SA
         USING DSA,R13                  Get addressibility to area
         MVI   FLAG1,0                  Ensure flags are not set
         EJECT
***********************************************************************
***
**   Locate to the first SUDB
***
***********************************************************************
         SPACE 2
*
** Find the CICS subsystem and get the SSCTSUSE (DFHSAB) in R4
*
         L     R4,CVTPTR                  -> CVT
         L     R4,CVTJESCT-CVTMAP(R4)     -> JESCT
         L     R4,JESSSCT-JESCT(R4)       -> SSCVT
FSS$L    DS    0H
         CLC   SSCTSNAM-SSCT(4,R4),=C'CICS'  SubSystem Match?
         BE    FSS$LX                        Yes, leave loop
         ICM   R4,B'1111',SSCTSCTA-SSCT(R4)  Check next one out
         BNZ   FSS$L                         Got one, repeat performanc
         B     E$NSS                         SubSystem not found...
FSS$LX   DS    0H                            SubSystem found
         ICM   R4,B'1111',SSCTSUSE-SSCT(R4)  -> DFHSAB
*
** Locate the SCTE and issue the starting message (w/SVC number)
*
         ICM   R5,B'1111',SABSCTE-SAB(R4) Locate SCTE
         BZ    E$NSCTE
         MVC   MSG(MSG0L),MSG0
         TPUT  MSG,MSG0L
         MVI   MSG,C' '
         TPUT  MSG,1
         MVC   MSG(MSG1L),MSG1
* Note: The SVC is in the machine code format "0Axx" or SVC xx
         SLR   R1,R1
         IC    R1,SCTESVC+1-SCTE(R5)      Get the SVC
         CVD   R1,DOUBLE
         UNPK  MSG+MSG1SVCD-1-MSG1(4),DOUBLE+6(2)
         OI    MSG+MSG1SVCD+2-MSG1,C'0'
         MVI   MSG+MSG1SVCD-1-MSG1,C'='
*
         UNPK  MSG+MSG1SVCH-MSG1(3),SCTESVC+1-SCTE(2,R5)
         MVZ   MSG+MSG1SVCH-MSG1(2),=8X'00'
         TR    MSG+MSG1SVCH-MSG1(2),=C'0123456789abcdef'
         MVI   MSG+MSG1SVCF-MSG1,C')'
*
         L     R1,CVTPTR                  -> CVT
         MVC   MSG+MSG1SYS-MSG1(L'CVTSNAME),CVTSNAME-CVTMAP(R1)
         TPUT  MSG,MSG1L
         MVI   MSG,C' '
         TPUT  MSG,1
*
** Locate the LACB (Logon Address Space Control Block)
*
         ICM   R6,B'1111',SCTELACB-SCTE(R5)  Locate LACB
         BZ    E$NLACB
*
** Locate the first SUDB
*
         ICM   R7,B'1111',LACBSUDB-LACB(R6) Locate SUDB
         BZ    E$NSUDB
         CLC   4(4,R6),=F'0'                CICS 5.3/CTS 1.3?  RS0400
         BNE   FSS$LXX                      No                 RS0400
         OI    FLAG1,$F1_53                 Turn on Flag
         ICM   R7,B'1111',LACBSUD2-LACB(R6) Locate SUDB        RS0400
         BZ    E$NSUDB                      None!              RS0400
FSS$LXX  DS    0H                                              RS0400
* Note: After this point R4, R5, R6 are freed up. Only R7 matters.
         EJECT
***********************************************************************
***
**       Process all of the SUDBs
***
***********************************************************************
         SPACE 2
         XC    PS_MROC(4),PS_MROC           Ensure we start at zero
PS$L     DS    0H
         ICM   R1,B'1111',SUDBCHN-SUDB(R7)  On the last one?
         BZ    PS$X                         Yes, Leave
*
         ICM   R8,B'1111',SUDBLCB-SUDB(R7)  LCB pointer
         BZ    PS$LB                        None, skip this entry
*
         L     R1,PS_MROC                   Get MRO region count
         LA    R1,1(R1)                     Bump by one
         ST    R1,PS_MROC                   Save for later
*
         LA    R15,MSG
         MVC   0(MSG2L,R15),MSG2
*
         ST    R7,SAVEREGS
         UNPK  MSG2SUDB-MSG2(9,R15),SAVEREGS(5)
         MVZ   MSG2SUDB-MSG2(8,R15),=8X'00'
         TR    MSG2SUDB-MSG2(8,R15),=C'0123456789ABCDEF'
         MVI   MSG2SUDB-MSG2+8(R15),C' '
*
         ICM   R9,B'1111',SUDBASCB-SUDB(R7) ASCB pointer
         L     R9,ASCBASSB-ASCB(,R9)        -> ASSB
         L     R9,ASSBJSAB-ASSB(,R9)        -> JSAB
         MVC   MSG2JOBI-MSG2(8,R15),JSABJBID-JSAB(R9)
         MVC   MSG2JOBN-MSG2(8,R15),JSABJBNM-JSAB(R9)
*
         TM    FLAG1,$F1_53                 At 5.3 or higher?
         BO    M2A53
         MVC   MSG2APPL-MSG2(8,R15),LCBAPPLD41-LCB(R8)
         B     M2A53X
M2A53    DS    0H
         MVC   MSG2APPL-MSG2(8,R15),LCBAPPLD53-LCB(R8)
M2A53X   DS    0H
*
** Get the CICS region start time and date
*
         STM   R2,R7,SAVEREGS      We eat up dem registers!
         ICM   R9,B'1111',SUDBASCB-SUDB(R7) ASCB pointer
         LM    R2,R3,ASCBINTS-ASCB(R9) Get start time
*
** Adjust the TOD stamp for GMT
*
*-This code was "liberated" from SYS1.V2R5M0.SHASSRC(HASCSRIC):
*        LR    R2,R0               Save high order TOD value
*        LR    R3,R1               Save low order TOD value
         SPACE 1
         L     R5,CVTPTR           Get CVT addressability
         L     R5,CVTEXT2-CVT(,R5)  Get address of extension
         LM    R14,R15,CVTLDTO-CVTXTNT2(R5)  Time zone diff
         LM    R6,R7,CVTLSO-CVTXTNT2(R5)  Get leap seconds
         SPACE 1
         ALR   R3,R15              Add low order time offset
         BC    12,PS$ATODV         Branch if no overflow
         AL    R2,=F'1'            Carry the 1
PS$ATODV ALR   R2,R14              Add high order words
         SPACE 1
         SLR   R3,R7               Subtract low-order leap seconds
         BC    3,PS$ATODB          Branch if no borrow
         BCTR  R2,0                Subtract one for borrow
PS$ATODB SLR   R2,R6               Subtract high-order leap seconds
         STM   R2,R3,PS_TOD        Save adjusted time
*ST R8,DOUBLE
*LA R15,MSG+MSG2APPL-MSG2
*UNPK 0(9,R15),DOUBLE(5)
*MVZ 0(8,R15),=8X'00'
*TR  0(8,R15),=C'0123456789ABCDEF'
*MVI 8(R15),C' '
         LM    R2,R7,SAVEREGS
*
** Convert the region start time and date
*
         STCKCONV STCKVAL=PS_TOD,         Convert this TOD Stamp       @
               CONVVAL=PS_SOUT,           ..Into these date/time areas @
               TIMETYPE=DEC,              ..Output time format         @
               DATETYPE=YYYYMMDD,         ..Output Date format         @
               MF=(E,PARMLIST)
         LTR   R15,R15                    STCKCONV worked?
         BNZ   PS$SCE                     Failed: give up
         LA    R15,MSG+(MSG2DATE-MSG2)
*                            0  1  2  3  4  5  6  7  8  9  0
*                               Y  Y  Y  Y  -  M  M  -  D  D
         MVC   0(11,R15),=X'40,21,20,20,20,60,20,20,60,20,20'
         ED    0(11,R15),PS_SOUT+8        Edit it to " ccyy-mm-dd"
         OI    6(R15),X'F0'               Ensure leading zero
         OI    9(R15),X'F0'               Ensure leading zero
         LA    R15,MSG+(MSG2TIME-MSG2)
*                             H H : M M
         MVC   0(6,R15),=X'F021207A2020'
         ED    0(6,R15),PS_SOUT
         MVI   0(R15),C' '
         B     PS$SCX
PS$SCE   DS    0H
         LA    R15,MSG+MSG2L              Locate output area
         MVI   0(R15),C' '
         MVC   1(21,R15),0(R15)
PS$SCX   DS    0H
*
** Print message
*
         TPUT  MSG,MSG2L
*
** Bump to next SUDB
*
PS$LB    DS    0H
         ICM   R7,B'1111',SUDBCHN-SUDB(R7)
         BNZ   PS$L
*
** The end of the SUDB chain - print number of MRO regions found
*
PS$X     DS    0H
         MVI   MSG,C' '
         TPUT  MSG,1
         MVC   MSG(MSG3L),MSG3
         LA    R15,MSG+MSG3L-1
         ICM   R1,B'1111',PS_MROC
         CVD   R1,DOUBLE
         UNPK  0(4,R15),DOUBLE+6(2)
         OI    3(R15),C'0'
         MVI   MSG+MSG3L-1,C'='
         TPUT  MSG,MSG3L+3
         EJECT
***********************************************************************
***
**       Exit Housekeeping
**
**       Release resources and return to caller
***
***********************************************************************
         SPACE 2
EXIT     DS    0H
         LR    R2,R13                     Get storage address
         STORAGE RELEASE,LENGTH=DSAL,ADDR=(R2) Release storage
         SLR   R15,R15                    Set return code
         PR                               Return to caller
         EJECT ,
***********************************************************************
***
**       Error routines
***
***********************************************************************
         SPACE 2
*
** SUDB not found
*
E$NSUDB  DS    0H
         MVC   MSG(MSG96L),MSG96
         TPUT  MSG,MSG96L
         B     EXIT
*
** LACB not found
*
E$NLACB  DS    0H
         MVC   MSG(MSG97L),MSG97
         TPUT  MSG,MSG97L
         B     EXIT
*
** SCTE not found
*
E$NSCTE  DS    0H
         MVC   MSG(MSG98L),MSG98
         TPUT  MSG,MSG98L
         B     EXIT
*
** Sub system for CICS not found
*
E$NSS    DS    0H
         MVC   MSG(MSG99L),MSG99
         TPUT  MSG,MSG99L
         B     EXIT
         EJECT
***********************************************************************
***
**       Constants
***
***********************************************************************
         SPACE 2
         LTORG ,
MSG0     DC    C'SHOWMRO - V&DAVRM - Freeware! - Show CICS MRO '
         DC    C'regions'
MSG0L    EQU   *-MSG0
*
MSG1     DC    C'CICS SRB SVC '
MSG1SVCD DC    C'xxx'
         DC    C' ('
MSG1SVCH DC    C'xx'
MSG1SVCF DC    C')  - System=' '
MSG1SYS  DS    CL(L'CVTSNAME)
         DC    C' - active MRO regions:'
MSG1L    EQU   *-MSG1
*
MSG2     EQU   *
MSG2JOBI DC    CL8' '
         DC    C' '
MSG2JOBN DC    CL8' '
         DC    C' - APPL='
MSG2APPL DC    CL8' '
         DC    C' -'
MSG2DATE DC    C' 2000-07-31'
MSG2TIME DC    C' HH:MM'
         DC    C' - SUDB='
MSG2SUDB DC    CL8' '
MSG2L    EQU   *-MSG2
*
MSG3     DC    C'The number of MRO regions='
MSG3L    EQU   *-MSG3
*
MSG96    DC    C'Error: SUDB not found '
MSG96L   EQU   *-MSG96
*
MSG97    DC    C'Error: LACB not found '
MSG97L   EQU   *-MSG97
*
MSG98    DC    C'Error: SCTE not found '
MSG98L   EQU   *-MSG98
*
MSG99    DC    C'Error: CICS subsystem not found '
MSG99L   EQU   *-MSG99
         EJECT
***********************************************************************
***
**       GETMAINed work area
***
***********************************************************************
         SPACE 2
DSA      DSECT ,
         DS    18F                      Register Save Area
PARMLIST DS    XL64                     Work area for parm lists
         DS    0D                       Process_SUDBs:
PS_TOD   DS    D                        ..TOD (STCK) area
PS_SOUT  DS    XL16                     ..STCKCON output area
PS_MROC  DS    F                        ..Count of MRO regions
SAVEREGS DS    6F                       Save registers for routine
         DS    0D
DOUBLE   DS    D                        Work area
FLAG1    DS    B'00000000'              Flag 1
$F1_53   EQU   B'10000000'              ..At 5.3?
*
MSG      DS    79C' '                   Message area
         DS    0D
DSAL     EQU   *-DSA
         END