steve-myers
Active Member
Joined: 30 Nov 2013 Posts: 917 Location: The Universe
|
|
|
|
This is really an ISPF query.
I went through the TSO/ISPF forum. Just a couple of notes -- If a data set or PDS member is in the PACK ON format it will stay in the PACK ON format until you enter the PACK OFF and SAVE commands, no matter what the PROFILE states.
- Somewhere in the TSO/ISPF forum is a Rexx EXEC that will change every member in a PDS to the PACK OFF format.
The following program will list all members in the PACK ON format.
Code: |
TESTPACK CSECT Define program CSECT
PUSH PRINT
PRINT NOGEN
DCBD DSORG=(PS,PO),DEVD=DA
IHADECB
POP PRINT
TESTPACK CSECT Return to program CSECT
USING *,12 Establish program addressability
SAVE (14,12),,'TESTPACK &SYSDATE &SYSTIME' Save registers
LR 12,15 Prepare program base register
LA 15,SAVEAREA Compute new save area address
ST 13,4(,15) Add new save area to the
ST 15,8(,13) save area chain
LR 13,15 Prepare new save area pointer
OPEN MF=(E,OPARM) Open the data sets
LTR 15,15 Data sets open?
BNZ EXIT No
GETBUF MDCB,(5) Allocate an I/O buffer
ST 5,(DECBAREA-DECB)+MDECB Store the address in the DECB
LA 9,OUTLINE+OUTLINEL Initialize current line position
LH 10,(DCBLRECL-IHADCB)+PRINT Load the max record size
LA 10,OUTLINE(10) Compute addr of the end of line
DSCAN100 GET DDCB Read a directory block
LH 3,0(,1) Load number of used bytes
AR 3,1 Compute addr of last used byte
BCTR 3,0 in the directory block
LA 4,2(,1) Compute addr of first member
DSCAN200 CLC =FL8'-1',0(4) End of directory?
BE DEOF Yep
MVC TTR(3),8(4) Copy disk addr of the first block
FIND MDCB,TTR,C Prepare to read the member
READ MDECB,SF,MDCB,*-*,'S' Read the first block
CHECK MDECB Wait for I/O to complete
LR 15,5 Copy the block address to reg 15
MVC 12(1,13),(DCBRECFM-IHADCB)+MDCB Copy data set RECFM
NI 12(13),DCBRECL Isolate the record type bits
CLI 12(13),DCBRECV RECFM = V?
BNE *+L'*+4 No
LA 15,8(,5) Compute addr of first logical rec
CLC =X'000140',0(15) Test if ISPF packed data
BNE DSCAN300 Br if not packed data
MVI SWITCH,1
TRTR 7(8,4),FINDNBL Find end of the member name
BZ DSCAN300 Ignore if all blanks
LA 8,1(,1) Compute end of member name
SR 8,4 Compute length of member name
BNP DSCAN300 Br if math problem
LA 0,1(8,9) Compute end of member cell
CR 0,10 Compare end of cell w/ end of line
BNH ADDMEMB Br if member will fit on this line
LA 0,OUTLINE Write the line
SR 9,0
SLL 9,16
STCM 9,B'1111',OUTLINE
PUT PRINT,(0)
LA 9,OUTLINE+5 Prepare new line start
ADDMEMB MVI 0(9),C' ' Build member cell in line
BCTR 8,0
EX 8,MOVENAME Copy member name to the output line
LA 9,2(8,9) Compute addr of next member cell
DSCAN300 IC 2,11(,4) Load C byte in member entry
N 2,=A(X'1F') Isolate user data bits
LA 2,12(2,2) Compute length of member entry
BXLE 4,2,DSCAN200
B DSCAN100
MOVENAME MVC 1(*-*,9),0(4) ** EX only **
DEOF TM SWITCH,X'FF'
BNZ WLAST
PUT PRINT,NOPACK
B EXIT
WLAST LA 0,OUTLINE Write the last output line
SR 9,0
BP STORERDW
DC H'0'
STORERDW SLL 9,16
STCM 9,B'1111',OUTLINE
PUT PRINT,(0)
EXIT LA 2,CPARM Close the data sets
CLOSE MF=(E,(2))
FREEP100 L 1,0(,2) Load a DCB address
N 1,=A(X'FFFFFF') Isolate the 24-bit DCB address
TM (DCBBUFCB-IHADCB)+3(1),1 DCB have a buffer pool?
BO FREEP200 No
FREEPOOL (1) Free the buffer pool
FREEP200 TM 0(2),X'80' End of parm list
LA 2,4(,2) Compute addr of next DCB pointer
BZ FREEP100 Br if not end of parm list
L 13,4(,13) Load addr of the higher save area
RETURN (14,12),T,RC=0 Restore regs & return
SAVEAREA DC 9D'0'
FINDNBL DC 0XL256'0',(C' ')X'04',X'00',(256-(*-FINDNBL))X'04'
PUSH PRINT
PRINT NOGEN
OPARM OPEN (PRINT,OUTPUT,DDCB,INPUT,MDCB,INPUT),MF=L
CPARM CLOSE (PRINT,,DDCB,,MDCB),MF=L
PRINT DCB DSORG=PS,MACRF=PM,DDNAME=SYSPRINT,RECFM=VBA,LRECL=121
DDCB DCB DSORG=PS,MACRF=GL,DDNAME=SYSUT1,EODAD=DEOF, ->
RECFM=F,LRECL=256,BLKSIZE=256
MDCB DCB DSORG=PO,MACRF=R,DDNAME=SYSUT1,EODAD=DSCAN300,BUFNO=1
POP PRINT
TTR DC F'0'
DC 0D'0'
LTORG ,
OUTLINE DC AL2(OUTLINEL,0),C' THE FOLLOWING MEMBERS HAVE ISPF PACKE>
D DATA -'
OUTLINEL EQU *-OUTLINE
DC CL(125-(*-OUTLINE))' ',0D'0'
SWITCH DC AL1(0)
NOPACK DC AL2(NOPACKL,0),C' NO MEMBERS ARE IN THE PACK ON FORMAT'
NOPACKL EQU *-NOPACK
END TESTPACK |
|
|