//MARKA JOB (0),'ASSSEMBLE',MSGLEVEL=1,CLASS=A,MSGCLASS=A //ASM EXEC PGM=IFOX00, // PARM='DECK,LOAD,TERM,TEST,SYSPARM((NOSP,NODEBUG)),XREF(SHORT)', // REGION=4096K,COND=(0,NE) //SYSLIB DD DISP=SHR,DSN=SYS1.MACLIB // DD DISP=SHR,DSN=SYS1.AMODGEN // DD DISP=SHR,DSN=SYS1.ATSOMAC //SYSUT1 DD SPACE=(CYL,(25,5)),UNIT=3350 //SYSUT2 DD SPACE=(CYL,(25,5)),UNIT=3350 //SYSUT3 DD SPACE=(CYL,(25,5)),UNIT=3350 //SYSTERM DD SYSOUT=* //SYSPRINT DD SYSOUT=* //SYSPUNCH DD SYSOUT=* //SYSGO DD DISP=(MOD,PASS,DELETE),UNIT=SYSDA, // DSN=&&OBJLIB,SPACE=(TRK,(2,2)) //SYSIN DD DATA,DLM=ZZ * DUMPDS: * * Dump out a card image PDS file as an IEBUPDTE format * card deck. Used for backup purposes. * * Sample JCL, output to sysout or file; * PDS - The DD to allocate the PDS * SYSPUNCH - Where the CARD images are punched * * //STEP1 EXEC PGM=DUMPPDS * //PDS DD DSN=SOME.PDS.FILE,DISP=SHR * //SYSPUNCH DD SYSOUT=* * * //STEP1 EXEC PGM=DUMPPDS * //PDS DD DSN=SOME.PDS.FILE,DISP=SHR * //SYSPUNCH DD DSN=SOME.CARD.FILE,DISP=(NEW,CATLG,DELETE), * // UNIT=3330,VOL=SER=TSO001,SPACE=(CYL,(1,1),RLSE), * // DCB=(DSORG=PS,RECFM=FB,LRECL=80,BLKSIZE=1600) * * * IMPORTANT NOTES: * 1. As we are generating IEBUPDTE statements any IEBUPDTE cards we * find in the PDS members we are processing are changed from * ./ to +/ to ensure they don't interfere with the job deck * we are creating. * 2. The job deck we create uses a DLM=ZZ so any cards we find * in input PDS members that are ZZ cards we change to @@ cards. * -- After a PDS has been rebuilt from the jobstream created here * it is the users responsibility to go through any reloaded * PDS and correct these changes (the PDSSCAN program could * help here). * * Credits: * Program author: Mark Dickinson * Other: This is heavily based on the PDSSCAN utility * written by Khalid S Alturairi, 1990 (as provided * to Xephon). My modifications were to discard all * the string searching functionality so it dumps * every card in the PDS rather than just the cards * found from a scan, and to put in the JCL wrappers * and IEBUPDTE statements around the members dumped. * DUMPPDS CSECT STM R14,R12,12(R13) SAVE REGISTERS BALR R12,0 LOAD BASE REGISTER USING *,R12 ESTABLISH ADDRESSABILITY ST 13,SAVEAREA+4 STORE CALLER'S S/A @ IN OUR S/A LR 14,13 SAVE CALLER'S S/A @ IN R14 LA 13,SAVEAREA POINT R13 TO OUR SAVE AREA ST 13,8(14) STORE OUR S/A @ IN CALLER'S S/A OPEN (RPT$FILE,OUTPUT) * Build the start of the JOB with all the JCL to * do run the IEBUPDTE job to reaload this PDS file. PUT RPT$FILE,JCL0 PUT RPT$FILE,JCL1 PUT RPT$FILE,JCL2 PUT RPT$FILE,JCL3 RDJFCB DIR$FILE INSERT THE DATASET NAME INTO MVC JCLDD+7(44),JFCBAREA THE JCL STREAM PUT RPT$FILE,JCLDD PUT RPT$FILE,JCL4 PUT RPT$FILE,JCLDD PUT RPT$FILE,JCL5 * Find the dataset name and move if to JCLDD * Then write out the JCL cards OPEN (PDS$FILE,INPUT,DIR$FILE,INPUT) LA R2,PDS$FILE EXTRACT BLK & REC LENGTH LH R0,62(R2) R0 = BLK LNGTH LH R4,82(R2) R4 = LRECLNGTH GETMAIN RU,LV=(0) R1 = AREA ADDRS, R0 = STORG SIZE LR R5,R0 R5 = BLK LNGTH , R0 IS FREE LR R3,R1 R3 = AREA ADDRESS , R1 IS FREE LA R6,4 TEST FOR STORAGE AVAILABILITY CR R15,R6 TEST RETURN CODE FOR 4 BNE STORGOK IF NOT 4, STORAGE WAS OBTAINED. PUT RPT$FILE,MSG03 ELSE SEND ERRMSG AND EXIT. B EOF STORGOK DS 0H STORG FOR DATASET BLK OBTAINED AR R5,R3 R5=HI BLK ADDRS=STRG ADRS+BLKLNGTH ST R5,HIBLKAD SAVE HIGH BLOCK ADDRESS SR R5,R4 R5=LOOP LIMIT=HI BLK ADDRS-LRECL GETNEXT DS 0H READ D1,SF,DIR$FILE,DIRBLK READ A DIRECTORY BLOCK CHECK D1 LA R6,DIRBLK SET R6 TO THE BEGINNING OF DIRBLK A R6,TWO SKIP LENGTH FIELD(2 BYTES) NXTMMBR CLC NULENTRY,0(R6) NO MORE ENTRIES IN DIRECTORY BLK? BE TSTLSTDB YES, TEST FOR LAST BLOCK. CLC YES,0(R6) IS IT LAST DIRECTORY BLOCK? BE DIREND YES, SEND END MSG & EXIT. MVC MEMBER(8),0(R6) NO, FETCH MBR NAME FOR PROCESSING MVC PRNTLIN1+12(8),MEMBER ALSO WRITE IEBUPDTE CARD FOR MEMBR PUT RPT$FILE,PRNTLIN1 TO THE CARD FILE. * S C A N L O G I C * R4 = LRECLNGTH R3 = SAVED AREA ADDRESS LA R8,1 R8 = CHAR INCREMNT = 1 FIND PDS$FILE,MEMBER,D LOCATE THE MEMBER. NEXTBLK L R9,HIBLKAD SET R9 TO HI BLK ADDR. BCTR R9,R0 LR R2,R3 SET R2 TO THE BEGINNING OF BLOCK INITBLK NI 0(R2),X'00' RESET BLOCK TO BINARY ZEROS. BXLE R2,R8,INITBLK READ D2,SF,PDS$FILE,(R3) READ A BLOCK FROM MEMBER. CHECK D2 * MID: Dunno if I need the below LR R9,R3 PREPARE R9 TO BE USED AS A LOOP SR R9,R10 LIMIT WHEN SCANNING A RECORD BCTR R9,R0 R9=RECORD LOOP LIMIT=LRECL=TEXTLEN * MID: end dunno LR R11,R3 R11= ADDRESS OF MEMBER BLOCK NEXTREC LR R2,R11 R2 = BEGINNING OF NEW RECORD AR R9,R4 R9 =HI RCRD ADDRS=RCRD LOOP LMT CLI 0(R11),X'00' SKIP NULLS AT END OF BLOCK BE SKIPBLNK MVC PRNTLIN2(80),0(R11) PRINT THE RECORD TEXT CLC PRNTLIN2(2),IEBCARD AFTER REPLACING ANY IEBUPDTE BNE TEST4ZZ STATEMENTS ON IT MVC PRNTLIN2(2),IEBREPL ./ BECOMES +/ TEST4ZZ CLC PRNTLIN2(2),CARDZZ BNE PRNTREC MVC PRNTLIN2(2),REPLZZ ZZ BECOMES $$ PRNTREC PUT RPT$FILE,PRNTLIN2 PRINT NOW SKIPBLNK BXLE R11,R4,NEXTREC GO THRU BLOCK RECORD BY RECORD. B NEXTBLK GO THRU ALL MEMBER BLOCKS. ********************** E N D O F S C A N L O G I C ************ EOFMMBR DS 0H ICM R7,B'1111',8(R6) SET R6 TO POINT TO THE NEXT A R6,TWELVE MEMBER ENTRY N R7,MASK1 SLL R7,1 AR R6,R7 LA R8,12 PLACE FOR MORE ENTRIES IN THE BLK? CR R6,R8 BL TSTLSTDB NO, TEST FOR LAST DIRECTORY BLK. B NXTMMBR YES, READ NEXT MEMBER TSTLSTDB CLC LAST,YES IS BLOCK READ LAST DIRECTORY BLK? CLC LAST,YES IS BLOCK READ LAST DIRECTORY BLK? BE DIREND YES, END THE SCAN PROCESS. B GETNEXT NO, CONTINUE WITH THE NEXT BLOCK. DIREND DS 0H DIRECTORY ENDED. EOF DS 0H PUT RPT$FILE,PRNTLIN3 THE ./ ENDUP, ZZ and // CARDS PUT RPT$FILE,JCL6 PUT RPT$FILE,JCL7 CLOSE (DIR$FILE,,RPT$FILE,,PDS$FILE) CLOSE FILES L 13,SAVEAREA+4 LOAD CALLER'S R13 LM 14,12,12(13) RESTORE THE REGISTERS LA 15,0(0,0) LOAD RETURN CODE BR 14 RETURN * * D A T A A R E A B I T S * SAVEAREA DS 18F SAVE AREA DIRBLK DS 0CL256 DIRBLK, AREA IS BELOW LAST DC 8CL1' ' DC 248CL1' ' END DIRBLK AREA HIBLKAD DC 4X'00' TO SAVE HI BLOCK ADDRESS. MEMBER DC 8C' ' TO SAVE CURRENT MEMBER NAME. MASK1 DC X'0000000F' USED IN LOGICAL AND OPERATION. NULENTRY DC 8X'00' TWO DC F'2' TWELVE DC F'12' YES DC 8X'FF' PRNTLIN1 DC CL80'./ ADD NAME= ' PRNTLIN2 DC 80C' ' PRNTLIN3 DC CL80'./ ENDUP' BLNKLINE DC 80C' ' IEBCARD DC CL2'./' IEBREPL DC CL2'+/' * Bugger, putting ZZ at the start of the variable name * triggers the DLM=ZZ to stop an assemble. * So move ZZ to the ned here. CARDZZ DC CL2'ZZ' REPLZZ DC CL2'@@' MSG03 DC CL80'*** NO STORAGE AVAILABLE ***' * * Added to generate the basic JCL for the card images * JCL0 DC CL80'//MARKJ001 JOB (0),MSGLEVEL=1,CLASS=A,MSGCLASS=A' JCL1 DC CL80'//STEPX EXEC PGM=IEBUPDTE,COND=(0,NE) ' JCL2 DC CL80'//SYSPRINT DD SYSOUT=* ' JCL3 DC CL80'//SYSUT1 DD DISP=SHR, ' JCL4 DC CL80'//SYSUT2 DD DISP=SHR, ' JCLDD DC CL80'// DSN= ' JCL5 DC CL80'//SYSIN DD DATA,DLM=ZZ ' JCL6 DC CL80'ZZ ' JCL7 DC CL80'// ' * * D C B B I T S * DIR$FILE DCB DDNAME=PDS,DSORG=PS,MACRF=R,EODAD=EOF, X RECFM=F,BLKSIZE=256,EXLST=EXLST PDS$FILE DCB DDNAME=PDS,DSORG=PO,MACRF=R,EODAD=EOFMMBR RPT$FILE DCB DDNAME=SYSPUNCH,DSORG=PS,MACRF=PM,LRECL=80,BLKSIZE=800, X RECFM=FB EXLST DS 0F DC X'87',AL3(JFCBAREA) FUNCTION,AREA JFCBAREA DC 176X'00' JFCB AREA * * And the 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 R9 EQU 9 R10 EQU 10 R11 EQU 11 R12 EQU 12 R13 EQU 13 R14 EQU 14 R15 EQU 15 END ZZ //LKED1 EXEC PGM=IEWL, // PARM='XREF,LIST,LET,TEST,AC=0', // REGION=1024K,COND=(0,NE) //SYSLMOD DD DSN=MARK.LIB.LOAD(DUMPPDS),DISP=SHR //SYSLIN DD DSN=&&OBJLIB,DISP=(OLD,PASS,DELETE) //SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(8,1)) //SYSPRINT DD SYSOUT=* //LKED2 EXEC PGM=IEWL, // PARM='XREF,LIST,LET,TEST,AC=0', // REGION=1024K,COND=(0,NE) //SYSLMOD DD DSN=MARK.LIB.LOAD,DISP=SHR //SYSUT1 DD UNIT=SYSDA,SPACE=(CYL,(8,1)) //SYSPRINT DD SYSOUT=* //SYSLIN DD * INCLUDE SYSLMOD(DUMPPDS) ENTRY DUMPPDS NAME DUMPPDS(R) /* //