TITLE ' E M P T Y ' ************************************************************ * * * 'EMPTY' TSO COMMAND * * * ************************************************************ SPACE * ATTRIBUTES. RE-ENTRANT. * DESCRIPTION. * THIS TSO COMMAND EMPTIES A PARTITIONED DATA SET * OR A SEQUENTIAL DATA SET. ALL MEMBERS OF A PDS * ARE DELETED. * * SYNTAX - * EMPTY 'DSNAME' (FOR PDS OR SEQ) * EMPTY 'DSNAME' DIR(NNN) (FOR PDS CHANGE) * EMPTY 'DDNAME' FILE (FOR SEQ) * EMPTY 'DDNAME' FILE DIR (FOR PDS) * EMPTY 'DDNAME' FILE DIR(NNN) (FOR PDS CHANGE) * * THE 'DIR' KEYWORD IS REQUIRED ONLY WHEN THE 'FILE' * KEYWORD IS SPECIFIED FOR A DDNAME PRE-ALLOCATED TO A PDS. * * THE 'DIR(NNN)' KEYWORD ALLOWS THE NUMBER OF DIRECTORY * BLOCKS TO BE SPECIFIED. THE DEFAULT IS THE EXISTING * NUMBER OF DIRECTORY BLOCKS. * * IF AN UNQUALIFIED DATA SET NAME IS ENTERED, THE * CATALOG MUST BE READ TWICE, ONCE TO APPEND A * TRAILING QUALIFIER IF NECESSARY, AND AGAIN DURING * ALLOCATION. THE USER CAN ELIMINATE THE FIRST BY USING * THE FULLY QUALIFIED NAME, PREFIX AND ALL, IN QUOTES, * OR BY ENTERING ALL BUT THE PREFIX, WITHOUT QUOTES, * PLUS THE KEYWORD 'Q'. THE LATTER IS MUCH SIMPLER * AND GIVES THE SAME PERFORMANCE IMPROVEMENT AS A * FULLY QUALIFIED NAME. * * THE 'FILE' KEYWORD IS USED FOR EMPTYING TEMPORARY * DATA SETS. IT TELLS THE COMMAND TO TREAT THE FIRST * OPERAND AS A FILENAME (DDNAME) INSTEAD OF A DSNAME. * WHATEVER DATA SET IS CURRENTLY ALLOCATED TO THE * FILENAME WILL BE EMPTIED. WHEN 'FILE' IS SPECIFIED * THE COMMAND USES THE PRESENCE OR ABSENCE OF THE 'DIR' * KEYWORD TO DETERMINE IF THE DATA SET IS PARTITIONED. * * THIS COMMAND WILL TERMINATE PREMATURELY WITH A * SYSTEM D37 ABEND IF THE NUMBER OF DIRECTORY BLOCKS * SPECIFIED WILL NOT FIT IN THE DATA SET. IF THIS * HAPPENS, THE ATTRIBUTES OF THE DATA SET (RECFM, * LRECL, BLKSIZE, KEYLEN) WILL BE LEFT DIFFERENT * FROM WHAT THEY ORIGINALLY WERE. * SPACE * INTERCEPT 'LINK' MACROS IMBEDDED IN PUTLINE & STACK * TO MAKE SF=(E,LINKAREA) THE DEFAULT. MACRO &NAME LINK &EP=,&SF=(E,LINKAREA) &NAME LA 15,&SF(2) LA 0,*+8 B *+12 DC CL8'&EP' ST 0,0(0,15) SVC 6 ISSUE LINK SVC MEND SPACE GBLB &MVS &MVS SETB 1 1 - MVS 0 - SVS,MVT SPACE EMPTY START USING *,R12,R11 B @PROLOG-*(,R15) DC AL1(11),CL11'EMPTY ' DC CL16' &SYSDATE &SYSTIME ' @SIZE DC 0F'0',AL1(1),AL3(@DATAL) @PROLOG STM 14,12,12(13) LR R12,R15 BASE LA R15,1 LA R11,4095(R15,R12) BASE LR R2,R1 USING CPPL,R2 L R0,@SIZE GETMAIN R,LV=(0) LR R9,R1 USING @DATA,R9 ST 13,4(,1) CHAIN SAVEAREA ST 1,8(,13) CHAIN SAVEAREA LR 13,1 NEW SAVEAREA SPACE 1 MVI STATUS,0 XC LINKAREA(8),LINKAREA SLR R15,R15 STH R15,RC SET RC = 0 ST R15,KOUNT STH R15,SAVLRECL STH R15,SAVBLKSI STC R15,SAVRECFM SPACE ************************************************************ * * * SET UP IOPL FOR PUTLINE * * * ************************************************************ SPACE LA R15,MYIOPL USING IOPL,R15 MVC IOPLUPT(4),CPPLUPT MVC IOPLECT(4),CPPLECT LA R0,MYECB ST R0,IOPLECB XC MYECB,MYECB LA R0,MYPTPB ST R0,IOPLIOPB DROP R15 IOPL SPACE AIF (NOT &MVS).SKIP1 L R15,16 LOAD CVT POINTER TM 444(R15),X'80' IS PUTLINE LOADED? (VS2) BNO PUTLOAD NO - BRANCH TO LOAD L R15,444(,R15) YES - USE CVTPUTL B PUTLOADX BRANCH AROUND LOAD .SKIP1 ANOP PUTLOAD LA R0,=CL8'IKJPUTL ' LOAD EPLOC=(0) LR R15,R0 GET ENTRY ADDRESS LA R15,0(,R15) CLEAR HI BYTE FOR DELETE ROUTINE PUTLOADX ST R15,MYPUTLEP SAVE PUTLINE ENTRY ADDRESS SPACE ************************************************************ * * * SET UP PPL FOR PARSE * * * ************************************************************ SPACE LA R15,MYPPL USING PPL,R15 MVC PPLUPT(4),CPPLUPT MVC PPLECT(4),CPPLECT LA R0,MYECB ST R0,PPLECB XC MYECB,MYECB * L R0,=A(EMPTYPCL) LA R0,PCLADDR ST R0,PPLPCL LA R0,MYANS ST R0,PPLANS XC MYANS(4),MYANS MVC PPLCBUF(4),CPPLCBUF ST R9,PPLUWA DROP R15 PPL SPACE 1 ************************************************************ * * * CALL THE PARSE SERVICE ROUTINE * * * ************************************************************ SPACE 1 LR R1,R15 POINT TO PPL AIF (NOT &MVS).SKIP2 L R15,16 CVTPTR TM 524(R15),X'80' IF HI ORDER BIT NOT ON BNO PARSELNK THEN DO LINK, NOT CALL L R15,524(,R15) CVTPARS BALR R14,R15 CALL IKJPARS B PARSEEXT SKIP AROUND LINK PARSELNK EQU * .SKIP2 ANOP LINK EP=IKJPARS,SF=(E,LINKAREA) PARSEEXT EQU * SPACE 1 LTR R15,R15 BZ PARSEOK LA R1,MSG01 LA R0,L'MSG01 BAL R14,PUTMSG LA R15,12 B EXIT PARSEOK EQU * SPACE L R3,MYANS USING IKJPARMD,R3 SPACE ************************************************************ * * * GET THE SPECIFIED NUMBER OF DIRECTORY BLOCKS * * * ************************************************************ SPACE LA R6,DIR TM 6(R6),X'80' IS THE OPERAND PRESENT BZ DIRX NO, BRANCH L R15,0(,R6) LOAD PTR TO VALUE LH R1,4(,R6) GET NUMBER OF DIGITS BCTR R1,0 MINUS 1 FOR EX B *+10 PACK DOUBLE,0(0,R15) (EXECUTED) EX R1,*-6 PACK THE DIGITS CVB R1,DOUBLE LTR R1,R1 VALUE ZERO BZ DIRINV YES, ERROR CH R1,=H'4096' ARBITRARY LIMIT EXCEEDED BH DIRINV YES, ERROR ST R1,KOUNT STORE VALUE B DIRX DIRINV LA R1,MSG10 LA R0,L'MSG10 BAL R14,PUTMSG LA R1,1 ST R1,KOUNT DIRX EQU * SPACE ************************************************************ * * * QUALIFY THE DSNAME IF NECESSARY * * * ************************************************************ SPACE LA R6,DSN TM 6(R6),X'80' IS DATASET NAME SPECIFIED? BO OKDSN YES - BRANCH LA R1,MSG05 NO - JUST MEMBER NAME LA R0,L'MSG05 BAL R14,PUTMSG LA R15,12 B NEXTDSN OKDSN EQU * LA R15,DSNAME+2 MVI 0(R15),C' ' BLANK THE DSNAME AREA MVC 1(43,R15),0(R15) SLR R1,R1 STH R1,DSNAME ZERO DSNAME LENGTH TM 6(R6),X'40' IS DSN QUOTED? BO NOPREF YES, SKIP PREFIXING CLI FILEKW+1,1 DSN TO BE TREATED AS DDNAME BE NOPREF YES, SKIP PREFIXING AIF (NOT &MVS).SKIPP PREFIX WITH PREFIX L R14,CPPLUPT POINT TO UPT USING UPT,R14 IC R1,UPTPREFL GET LENGTH OF PREFIX LTR R1,R1 IS IT ZERO BZ NOPREF YES, SKIP PREFIXING B *+10 MVC 0(0,R15),UPTPREFX DROP R14 UPT .SKIPP AIF (&MVS).SKIPU PREFIX WITH USERID L R14,CPPLPSCB POINT TO PSCB USING PSCB,R14 IC R1,PSCBUSRL GET LENGTH OF USERID LTR R1,R1 IS IT ZERO BZ NOPREF YES, SKIP PREFIXING B *+10 MVC 0(0,R15),PSCBUSER DROP R14 PSCB .SKIPU ANOP EX R1,*-6 MOVE USERID TO DSNAME AREA LA R15,0(R1,R15) POINT PAST USERID MVI 0(R15),C'.' APPEND PERIOD LA R15,1(,R15) POINT PAST PERIOD LA R1,1(,R1) ADD 1 TO LENGTH STH R1,DSNAME STORE LENGTH OF USERID PLUS 1 NOPREF EQU * LH R1,4(,R6) GET LENGTH LR R0,R1 AH R0,DSNAME ADD LENGTH OF PREFIX OR ZERO STH R0,DSNAME SET COMBINED LENGTH L R14,0(,R6) POINT TO DSN VALUE BCTR R1,0 LENGTH MINUS 1 FOR EX B *+10 BRANCH AROUND EXECUTED MVC MVC 0(0,R15),0(R14) (EXECUTED) EX R1,*-6 MOVE DSN TO DSNAME (AFTER PREFIX) SPACE ************************************************************ * * * IF 'FILE' KEYWORD IS SPECIFIED, * * GET DSNAME FROM JFCB USING FILE NAME. * * * ************************************************************ SPACE CLI FILEKW+1,1 'FILE' SPECIFIED? BNE NOFILE NO, BRANCH CLI DSNAME+1,8 IS LENGTH 8 OR LESS BH FILERR1 NO, BRANCH DEVTYPE DSNAME+2,DEVDATA GET DEVICE TYPE LTR R15,R15 WAS FILENAME VALID BNZ FILERR2 NO, BRANCH TM DEVDATA+2,X'20' DIRECT ACCESS BZ FILERR3 NO, BRANCH LA R4,PDSDCBW MVC 0(PDSDCBL,R4),PDSDCB LA R0,JFCB LA R1,PDSEXLST ST R0,0(,R1) MVI 0(R1),X'87' ST R1,36(,R4) DCBEXLST MVC 40(8,R4),DSNAME+2 DCBDDNAM MVC DDSAVE,DSNAME+2 MVI OPEND,X'80' RDJFCB ((R4)),MF=(E,OPEND) MVC DSNAME+2(44),JFCB LA R1,DSNAME+45 LAST CHAR OF DSNAME LA R0,44 INITIAL LENGTH FILEA CLI 0(R1),C' ' IS THIS LAST NONBLANK BNE FILEB YES, BRANCH BCTR R1,0 BACK UP 1 CHARACTER BCT R0,FILEA DECREMENT LENGTH AND BRANCH FILEB STH R0,DSNAME STORE LENGTH OF DSNAME * MVC VOLUME(6),JFCB+118 GET VOLUME FROM JFCB MVI DSORG,X'40' DSORG=PS CLI DIRKW+1,1 WAS 'DIR' SPECIFIED BNE *+8 NO, SKIP NEXT INSTR MVI DSORG,X'02' DSORG=PO B FILESPEC FILERR1 LA R0,MSG14A B FILERR FILERR2 LA R0,MSG14B B FILERR FILERR3 LA R0,MSG14C FILERR MVC MSGWK(L'MSG14),MSG14 LA R15,MSGWK+L'MSG14 LA R14,DSNAME LH R1,0(,R14) BCTR R1,0 B *+10 MVC MSGWK+L'MSG14(0),2(R14) EX R1,*-6 LA R15,1(R1,R15) LR R14,R0 POINT TO MSG14A, B, OR C MVC 0(L'MSG14A,R15),0(R14) LA R0,L'MSG14+L'MSG14A+1(,R1) LA R1,MSGWK BAL R14,PUTMSG B NEXTD12 NOFILE EQU * TM 6(R6),X'40' IS IT QUOTED? BO DEFX YES - SKIP DEFAULT SERVICE CLI QUICKW+1,1 QUICK SPECIFIED BE DEFX YES, USER ENTERED ALL BUT PREFIX SPACE LA R15,MYIOPL USING IOPL,R15 LA R14,MYDFPB ST R14,IOPLIOPB USING DFPB,R14 XC 0(20,R14),0(R14) LA R0,DSNAME ST R0,DFPBDSN OI DFPBCODE,X'04' SEARCH CAT AND PROMPT IF MULTI MVC DFPBPSCB,CPPLPSCB * MVI DFPBCNTL,X'20' PREFIX THE DSNAME DROP R14 DFPB SPACE LA R1,MYIOPL SPACE LR R1,R15 POINT TO IOPL AIF (NOT &MVS).SKIP4 L R15,16 CVTPTR TM 736(R15),X'80' IF HI ORDER BIT NOT ON BNO EHDEFLNK THEN DO LINK, NOT CALL L R15,736(,R15) CVTEHDEF BALR R14,R15 CALL IKJEHDEF B EHDEFEXT SKIP AROUND LINK EHDEFLNK EQU * .SKIP4 ANOP LINK EP=IKJEHDEF,SF=(E,LINKAREA) EHDEFEXT EQU * SPACE B DEFCODE(R15) DEFCODE B DEF00 SUCCESS B NEXTDSN MSG ALREADY ISSUED B DEF08 INVALID NAME GT 44 B NEXTDSN MSG ALREADY ISUED B DEF16 NOT IN CATALOG B DEF20 NOT IN CATALOG B DEF24 IMPOSSIBLE B DEF28 COMMAND SYSTEM ERROR B DEF32 IMPOSSIBLE B DEF36 ? DEF08 EQU * DEF16 EQU * B DEF24 DEF20 EQU * LOCERR EQU * MVC MSGWK(L'MSG02),MSG02 LA R15,MSGWK+L'MSG02 LA R14,DSNAME LH R1,0(,R14) BCTR R1,0 B *+10 MVC MSGWK+L'MSG02(0),2(R14) EX R1,*-6 LA R15,1(R1,R15) MVC 0(L'MSG02A,R15),MSG02A LA R0,L'MSG02+L'MSG02A+1(,R1) LA R1,MSGWK BAL R14,PUTMSG B NEXTDSN DEF24 EQU * DEF28 EQU * DEF32 EQU * DEF36 EQU * LA R1,MSG03 LA R0,L'MSG03 BAL R14,PUTMSG B NEXTDSN SPACE DEF00 EQU * DEFX EQU * SPACE ************************************************************ * * * ALLOCATE THE DATASET * * * ************************************************************ SPACE LA R1,MYDAPL USING DAPL,R1 MVC DAPLUPT(4),CPPLUPT MVC DAPLECT(4),CPPLECT LA R0,MYECB ST R0,DAPLECB MVC DAPLPSCB(4),CPPLPSCB LA R15,MYDAPB ST R15,DAPLDAPB DROP R1 DAPL USING DAPB08,R15 XC 0(84,R15),0(R15) MVI DA08CD+1,X'08' LA R0,DSNAME ST R0,DA08PDSN MVC DA08DDN(8),=CL8' ' MVC DA08UNIT,=CL8' ' MVC DA08SER,=CL8' ' MVC DA08MNM,=CL8' ' MVC DA08PSWD,=CL8' ' MVI DA08DSP1,DA08SHR MVI DA08DPS2,DA08KEEP MVI DA08DPS3,DA08KEP TM 14(R6),X'80' MEMBER SPECIFIED? BZ MEMBX NO - BRANCH * LH R1,12(,R6) GET LENGTH OF MEMBER * BCTR R1,0 MINUS 1 FOR EX * L R14,8(,R6) GET ADDRESS OF MEMBER NAME * B *+10 * MVC DA08MNM(0),0(R14) MOVE MEMBER NAME * EX R1,*-6 LA R1,MSG07 LA R0,L'MSG07 BAL R14,PUTMSG B NEXTD12 MEMBX EQU * TM 22(R6),X'80' PASSWORD SPECIFIED? BZ PASSX NO - BRANCH LH R1,20(,R6) GET LENGTH OF PSWD BCTR R1,0 MINUS 1 FOR EX L R14,16(,R6) GET ADDRESS OF PSWD B *+10 MVC DA08PSWD(0),0(R14) MOVE PSWD EX R1,*-6 PASSX EQU * LA R1,MYDAPL SPACE BAL R14,CALLDAIR LTR R15,R15 BZ OKDAIR BAL R14,DAIRFAIL LA R15,12 B NEXTDSN OKDAIR EQU * OI STATUS,X'40' TELL CLEANUP TO FREE IT LA R15,MYDAPB MVC DDSAVE,DA08DDN MVC DSORG,DA08DSO TM DSORG,X'40' IS DSORG SEQUENTIAL? BO OKDSORG YES - BRANCH TM DSORG,X'02' IS DSORG PARTITIONED? BO OKDSORGP YES, BRANCH * * DSORG IS NEITHER PS NOR PO * ISAM=X'80' DA=X'20' VSAM=X'00' NONE=X'00' * ERRDSORG LA R1,MSG06 LA R0,L'MSG06 BAL R14,PUTMSG LA R15,12 B NEXTDSN OKDSORGP EQU * OKDSORG EQU * DROP R15 DAPB08 SPACE ************************************************************ * * * READ FORMAT-1 DSCB FOR DCB ATTRIBUTES * * * ************************************************************ SPACE L R1,16 CVTPTR L R1,0(,R1) TCB WORDS L R1,4(,R1) CURRENT TCB L R1,12(,R1) TIOT LA R1,24(,R1) TOIENTRY DDLOOP CLI 0(R1),0 END OF TIOT BE NEXTDSN YES, BRANCH (NEVER HAPPENS) CLC 4(8,R1),DDSAVE DOES DDNAME MATCH BE DDFOUND SLR R15,R15 IC R15,0(,R1) LA R1,0(R15,R1) B DDLOOP DDFOUND L R15,16(,R1) TIOEFSRT-1, PTR TO UCB TM 18(R15),X'20' DIRECT ACCESS DEVICE? BZ OBTX NO, BYPASS OBTAIN TM 0(R15),X'80' VIO BO OBTX YES, BYPASS OBTAIN MVC VOLSER,28(R15) UCBVOLI OBTDSCB LA R1,OBTAINW MVC 0(OBTAINL,R1),OBTAIN LA R0,DSNAME+2 DSN FOR OBTAIN ST R0,4(,R1) LA R0,VOLSER VOLUME FOR OBTAIN ST R0,8(,R1) LA R0,MYDSCB ANSWER AREA FOR OBTAIN ST R0,12(,R1) OBTAIN (1) LTR R15,R15 WAS OBTAIN SUCCESSFUL BZ OKDSCB YES, BRANCH SPACE * OBTAIN HAS FAILED. HOW CAN THAT HAPPEN WHEN * DYNAMIC ALLOCATION WAS SUCCESSFUL? ONE WAY IT * CAN HAPPEN IS IF THE DSNAME IS AN ALIAS ENTRY * IN A VSAM CATALOG. IF IT IS, A 'LOCATE' WILL * PUT THE TRUE NAME IN THE DSNAME FIELD, SO NOW * WE ISSUE A LOCATE, AND TRY THE OBTAIN AGAIN. SPACE TM STATUS,X'08' HAS LOCATE BEEN TRIED ALREADY? BZ ALIAS NO, GO TRY IT ERROBT LA R1,MSG09 UNABLE TO OBTAIN DSCB LA R0,L'MSG09 BAL R14,PUTMSG LA R15,12 B NEXTDSN ALIAS OI STATUS,X'08' TRIP THE SWITCH LA R1,LOCATEW MVC 0(LOCATEL,R1),LOCATE LA R0,DSNAME+2 DSNAME FOR LOCATE ST R0,4(,R1) LA R0,LOCBUF ANSWER AREA FOR LOCATE ST R0,12(,R1) LOCATE (1) LTR 15,15 WAS LOCATE SUCCESSFUL? BZ OBTDSCB YES, GO OBTAIN AGAIN B ERROBT NO, ISSUE MESSAGE SPACE OKDSCB NI STATUS,255-X'08' TURN OFF LOCATE SWITCH TM MYDSCB-44+X'52',X'42' DSORG = PS OR PO BZ ERRDSORG MVC SAVRECFM,MYDSCB-44+X'54' MVC SAVLRECL,MYDSCB-44+X'58' MVC SAVBLKSI,MYDSCB-44+X'56' * MVC SAVOPTCD,MYDSCB-44+X'55' 1 BYTE * MVC SAVKEYLE,MYDSCB-44+X'5A' 1 BYTE * MVC SAVRKEYP,MYDSCB-44+X'5B' 2 BYTES OBTX EQU * FILESPEC EQU * SPACE ************************************************************ * * * OPEN AND CLOSE THE PDS * * * ************************************************************ SPACE USING IHADCB,R4 TM DSORG,X'40' SEQUENTIAL BO SEQ YES, BRANCH * * IF THE DCB ATTRIBUTES HAVE NOT BEEN * DETERMINED, THEN OPEN AND CLOSE THE DATA SET, * SAVING THE ATTRIBUTES IN THE DCB OPEN EXIT. * CLC SAVBLKSI,=H'0' ARE THE ATTRIBUTES KNOWN BNE GOTATTR YES, BRANCH LA R4,PDSDCBW MVC PDSDCBW(PDSDCBL),PDSDCB MVC DCBDDNAM(8),DDSAVE LA R15,PDSEXLST IC R0,DCBEXLSA-1 ST R15,DCBEXLSA-1 STC R0,DCBEXLSA-1 LA R1,PDSDCBEX ST R1,0(,R15) MVI 0(R15),X'85' SPACE MVI OPEND,X'80' OPEN ((R4),OUTPUT),MF=(E,OPEND) TM DCBOFLGS,X'10' BO PDSOPEN LA R1,MSG04 LA R0,L'MSG04 BAL R14,PUTMSG LA R15,12 B NEXTDSN SPACE PDSDCBEX EQU * MVC SAVRECFM,DCBRECFM MVC SAVLRECL,DCBLRECL MVC SAVBLKSI,DCBBLKSI BR R14 SPACE PDSOPEN EQU * MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) GOTATTR EQU * SPACE ************************************************************ * * * COUNT THE DIRECTORY BLOCKS * * * ************************************************************ SPACE LA R4,DIRDCBW MVC DIRDCBW(DIRDCBL),DIRDCB MVC DCBDDNAM(8),DDSAVE SPACE LA R15,DIREOD IC R0,DCBEODAD-1 ST R15,DCBEODAD-1 STC R0,DCBEODAD-1 SPACE LA R15,DIRSYNAD IC R0,DCBSYNAD-1 ST R15,DCBSYNAD-1 STC R0,DCBSYNAD-1 SPACE L R1,KOUNT LTR R1,R1 WAS DIR(NNN) SPECIFIED BNZ COUNTX YES, BYPASS COUNT SPACE MVI OPEND,X'80' OPEN ((R4),INPUT),MF=(E,OPEND) TM DCBOFLGS,X'10' BO OKOPEN ERROPEN LA R1,MSG04 LA R0,L'MSG04 BAL R14,PUTMSG LA R15,12 B NEXTDSN SPACE OKOPEN EQU * OI STATUS,X'80' TELL CLEANUP TO CLOSE DCB SPACE MVC DIRDECB(DIRDECBL),DIRDECBR READLOOP EQU * MVI SYNADSW,0 SET SYNAD SWITCH OFF SPACE READ DIRDECB,SF,(R4),BLOCK,MF=E SPACE CHECK DIRDECB SPACE CLI SYNADSW,0 WAS SYNAD EXIT TAKEN? BE OKGET NO - BRANCH ERRSYNAD LA R1,SYNADMSG LA R0,78 BAL R14,PUTMSG LA R15,12 B NEXTDSN OKGET EQU * LA R14,1 A R14,KOUNT ST R14,KOUNT B READLOOP SPACE DIREOD EQU * MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) L R1,KOUNT LTR R1,R1 WERE THERE ANY PRESENT BNZ COUNTX YES, BRANCH MVI KOUNT+3,1 NONE PRESENT, MAKE 1 COUNTX EQU * SPACE ************************************************************ * * * WRITE THE EMPTY DIRECTORY BLOCKS * * * ************************************************************ SPACE MVI OPEND,X'80' OPEN ((R4),OUTPUT),MF=(E,OPEND) MVC DIRDECB(DIRDECBL),DIRDECBW SPACE XC BLOCK,BLOCK XC BLOCK+8(256),BLOCK+8 MVC BLOCK(18),BLOCK1 FIRST BLOCK HAS FF VALUES SPACE L R0,KOUNT WRTELOOP EQU * ST R0,DKOUNT MVI SYNADSW,0 SET SYNAD SWITCH OFF SPACE WRITE DIRDECB,SF,(R4),BLOCK,MF=E SPACE CHECK DIRDECB SPACE CLI SYNADSW,0 WAS SYNAD EXIT TAKEN? BNE ERRSYNAD YES, BRANCH XC BLOCK(18),BLOCK ZERO ALL BLOCKS EXCEPT FIRST L R0,DKOUNT BCT R0,WRTELOOP MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) SPACE ************************************************************ * * * ADD AND DELETE A NULL MEMBER * * * ************************************************************ SPACE LA R4,PDSDCBW MVC PDSDCBW(PDSDCBL),PDSDCB MVC DCBDDNAM(8),DDSAVE MVC DCBRECFM,SAVRECFM OI DCBRECFM,X'01' KEYLEN SPECIFIED MVC DCBLRECL,SAVLRECL MVC DCBBLKSI,SAVBLKSI MVI OPEND,X'80' OPEN ((R4),OUTPUT),MF=(E,OPEND) MVC MEMBERW,MEMBER STOW (R4),MEMBERW,A LTR R15,R15 BNZ STOWERR STOW (R4),MEMBERW,D LTR R15,R15 BNZ STOWERR MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) LA R15,0 B NEXTDSN SPACE STOWERR LA R1,MSG08 LA R0,L'MSG08 BAL R14,PUTMSG LA R15,12 B NEXTDSN SPACE ************************************************************ * * * EMPTY A SEQUENTIAL DATA SET * * * ************************************************************ SPACE SEQ LA R4,SEQDCBW MVC SEQDCBW(SEQDCBL),SEQDCB MVC DCBDDNAM(8),DDSAVE MVI OPEND,X'80' OPEN ((R4),OUTPUT),MF=(E,OPEND) TM DCBOFLGS,X'10' BNO ERROPEN MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) LA R15,0 B NEXTDSN SPACE ************************************************************ * * * SET UP FOR NEXT DATA SET * * * ************************************************************ SPACE NEXTD12 LA R15,12 SPACE NEXTDSN CH R15,RC BNH *+8 STH R15,RC SET HIGHEST RC TM STATUS,X'80' BZ NOCLOSE TM DCBOFLGS,X'10' IS IT OPEN? BZ NOCLOSE NO, BRANCH MVI CLOSED,X'80' CLOSE ((R4)),MF=(E,CLOSED) NI STATUS,255-X'80' CLOSED DROP R4 IHADCB NOCLOSE EQU * TM STATUS,X'40' FREE REQUIRED? BZ NOFREE LA R1,MYDAPL LA R15,MYDAPB USING DAPB18,R15 XC 0(40,R15),0(R15) MVI DA18CD+1,X'18' MVC DA18DDN,DDSAVE MVC DA18MNM(8),=CL8' ' MVC DA18SCLS(2),=CL8' ' BAL R14,CALLDAIR UNALLOCATE NI STATUS,255-X'40' UNALLOCATED DROP R15 DAPB18 NOFREE EQU * SPACE IKJRLSA MYANS SPACE CLI RC+1,0 IS RC ZERO? BZ STACKDX YES, BRANCH MVC MYSTPB(STACKDL),STACKD SPACE STACK DELETE=ALL,PARM=MYSTPB,MF=(E,MYIOPL) SPACE TCLEARQ STACKDX EQU * SPACE LH R15,RC B EXIT SPACE ************************************************************ * * * CALL IKJDAIR SERVICE ROUTINE * * * ************************************************************ SPACE CALLDAIR ST R14,DAIRREGS AIF (NOT &MVS).SKIP6 L R15,16 TM 732(R15),X'80' CVTDAIR BNO DAIRLINK L R15,732(,R15) BALR R14,R15 B DAIRFINI DAIRLINK EQU * .SKIP6 ANOP LINK EP=IKJDAIR,SF=(E,LINKAREA) DAIRFINI L R14,DAIRREGS BR R14 SPACE ************************************************************ * * * DYNAMIC ALLOCATION FAILURE ROUTINE * * * ************************************************************ SPACE DAIRFAIL ST R14,MYDFREGS AIF (NOT &MVS).SKIP7 LA R1,MYDFPARM USING DFDSECTD,R1 ST R15,MYDFRC LA R15,MYDFRC ST R15,DFRCP LA R15,MYDAPL ST R15,DFDAPLP SLR R15,R15 ST R15,MYJEFF02 LA R15,MYJEFF02 ST R15,DFJEFF02 LA R15,DFDAIR STH R15,MYDFID LA R15,MYDFID ST R15,DFIDP SLR R15,R15 ST R15,DFCPPLP LINK EP=IKJEFF18,SF=(E,LINKAREA) L R15,MYDFRC DROP R1 DFDSECTD .SKIP7 ANOP AIF (&MVS).SKIP8 LA R1,MSGDAIR LA R0,L'MSGDAIR BAL R14,PUTMSG .SKIP8 ANOP L R14,MYDFREGS BR R14 SPACE ************************************************************ * * * PUTMSG ROUTINE * * * ************************************************************ SPACE PUTMSG STM R14,R1,PUTLINS XC MYOLD(8),MYOLD XC MYSEG1(4),MYSEG1 MVC MYPTPB(12),MODLPTPM LA R14,1 NO. OF MESSAGE SEGMENTS ST R14,MYOLD LA R14,MYSEG1 POINT TO 1ST SEGMENT ST R14,MYOLD+4 LR R14,R0 LENGTH IN R0 LA R14,4(,R14) ADD 4 LA R15,MYSEG1+4 CLC 0(3,R1),=C'IKJ' IS DATA PRECEEDED BY MESSAGE ID? BE *+16 YES - BRANCH LA R14,1(,R14) ADD 1 TO LENGTH MVI 0(R15),C' ' INSERT LEADING BLANK LA R15,1(,R15) BUMP POINTER STH R14,MYSEG1 LR R14,R0 BCTR R14,0 B *+10 MVC 0(0,R15),0(R1) MOVE MESSAGE IN EX R14,*-6 L R15,MYPUTLEP SPACE PUTLINE PARM=MYPTPB,OUTPUT=(MYOLD),ENTRY=(15),MF=(E,MYIOPL) SPACE LM R14,R1,PUTLINS BR R14 SPACE ************************************************************ * * * PUTLINE ROUTINE * * * ************************************************************ SPACE PUTLINE STM R14,R1,PUTLINS XC MYSEG1(4),MYSEG1 MVC MYPTPB(12),MODLPTPB LR R14,R0 LENGTH IN R0 LA R14,4(,R14) ADD 4 STH R14,MYSEG1 LR R14,R0 BCTR R14,0 B *+10 MVC MYSEG1+4(0),0(R1) MOVE TEXT IN EX R14,*-6 LA R1,MYIOPL L R15,MYPUTLEP SPACE PUTLINE PARM=MYPTPB,OUTPUT=(MYSEG1,DATA),ENTRY=(15),MF=(E,(1)) SPACE LM R14,R1,PUTLINS BR R14 SPACE 1 ERRRECFM LA R1,MSGRECFM LA R0,L'MSGRECFM BAL R14,PUTMSG B NEXTD12 SPACE EXIT LR 1,13 L R0,@SIZE L 13,4(,13) ST 15,16(,13) FREEMAIN R,A=(1),LV=(0) LM 14,12,12(13) BR 14 SPACE ************************************************************ * * * SYNAD EXIT * * * ************************************************************ SPACE * THIS ROUTINE IS ENTERED DURING THE 'CHECK' MACRO * IF AN I/O ERROR OCCURS. SPACE DIRSYNAD EQU * SYNADAF ACSMETH=BSAM MVC SYNADMSG(78),50(R1) MVI SYNADSW,X'FF' SYNADRLS BR R14 SPACE ************************************************************ * * * CONSTANTS * * * ************************************************************ SPACE LTORG SPACE MODLPTPM PUTLINE OUTPUT=(1,TERM,SINGLE,INFOR), X TERMPUT=(EDIT,WAIT,NOHOLD,NOBREAK),MF=L SPACE MODLPTPB PUTLINE OUTPUT=(1,TERM,SINGLE,DATA), X TERMPUT=(EDIT,WAIT,NOHOLD,NOBREAK),MF=L SPACE PRINT NOGEN SPACE DIRDCB DCB DDNAME=DYNAM,DSORG=PS,MACRF=(R,W), + RECFM=FB,LRECL=256,BLKSIZE=256,KEYLEN=8, + EODAD=0,SYNAD=0 DIRDCBL EQU *-DIRDCB SPACE PDSDCB DCB DDNAME=DYNAM,DSORG=PO,MACRF=(W),KEYLEN=0 PDSDCBL EQU *-PDSDCB SPACE SEQDCB DCB DDNAME=DYNAM,DSORG=PS,MACRF=(W) SEQDCBL EQU *-SEQDCB SPACE PRINT GEN SPACE READ DIRDECBR,SF,0,0,MF=L DIRDECBL EQU *-DIRDECBR SPACE WRITE DIRDECBW,SF,0,0,MF=L SPACE OBTAIN CAMLST SEARCH,2,3,4 OBTAINL EQU *-OBTAIN SPACE LOCATE CAMLST NAME,2,,4 LOCATEL EQU *-LOCATE SPACE STACKD STACK DELETE=ALL,MF=L STACKDL EQU *-STACKD SPACE MSG01 DC C'ERROR IN PARSE SERVICE ROUTINE' MSG02 DC C'IKJ58503I DATA SET ' MSG02A DC C' NOT IN CATALOG' MSG03 DC C'ERROR IN DEFAULT SERVICE ROUTINE' MSG04 DC C'UNABLE TO OPEN DATASET' MSG05 DC C'IKJ58509I DATA SET NAME REQUIRED WHEN MEMBER IS SPECIF+ IED' MSG06 DC C'ORGANIZATION OF DATA SET MUST BE PARTITIONED OR SEQUEN+ TIAL' MSG07 DC C'ONLY AN ENTIRE PDS MAY BE EMPTIED, NOT INDIVIDUAL MEMB+ ERS' MSG08 DC C'STOW FAILED FOR NULL MEMBER' MSG09 DC C'UNABLE TO OBTAIN DSCB FOR DATA SET' MSG10 DC C'DIRECTORY SIZE NOT 1 TO 4096, WILL SET IT TO 1' MSG14 DC C'FILENAME ' MSG14A DC C' INVALID, MORE THAN 8 CHARACTERS ' MSG14B DC C' IS NOT CURRENTLY ALLOCATED ' MSG14C DC C' NOT ALLOCATED TO A DASD DATA SET ' MSGRECFM DC C'RECORD FORMAT U NOT SUPPORTED' MSGDAIR DC C'UNABLE TO ALLOCATE' MEMBER DC CL8'DUMMY',XL4'00' BLOCK1 DC 8X'FF',X'000E',8X'FF' PCLADDR DC 0D'0' END OF CSECT SPACE ************************************************************ * * * PARSE PARAMETERS * * * ************************************************************ SPACE PRINT NOGEN EMPTYPCL IKJPARM DSN IKJPOSIT DSNAME,PROMPT='DATA SET NAME' FILEKW IKJKEYWD IKJNAME 'FILE' QUICKW IKJKEYWD IKJNAME 'QUICK' DIRKW IKJKEYWD IKJNAME 'DIR',SUBFLD=DIRSF DIRSF IKJSUBF DIR IKJIDENT 'DIRECTORY BLOCKS', + FIRST=NUMERIC,OTHER=NUMERIC,MAXLNTH=5 IKJENDP PRINT GEN SPACE ************************************************************ * * * DSECTS * * * ************************************************************ SPACE @DATA DSECT DS 18F REGISTER SAVEAREA LINKAREA DS 2F MYPPL DS 7F MYANS DS F MYECB DS F USED BY PUTLINE ROUTINE MYIOPL DS 4F USED BY PUTLINE ROUTINE MYPTPB DS 3F USED BY PUTLINE ROUTINE MYOLD DS 2F USED BY PUTLINE ROUTINE MYSEG1 DS 2H,CL256 USED BY PUTLINE ROUTINE PUTLINS DS 4F USED BY PUTLINE ROUTINE MYPUTLEP DS F ADDRESS OF IKJPUTL MYSTPB DS 0F 5 WORDS USED BY STACK DELETE MYDAPL DS 5F MYDAPB DS 21F MYDFPB DS 5F MEMBERW DS CL12 DSNAME DS H,CL44 VOLSER DS CL6 LOCATEW DS 0F OBTAINW DS 4F LOCBUF DS 0D USES NEXT 265 BYTES MYDSCB DS CL140 96 BYTES OF DSCB, 5 BYTES CCHHR MSGWK DS CL128 DSORG DS X STATUS DS X RC DS H SAVRECFM DS X SAVLRECL DS H SAVBLKSI DS H MYDFPARM DS 5F USED BY DAIRFAIL MYDFREGS DS F USED BY DAIRFAIL MYDFRC DS F USED BY DAIRFAIL MYJEFF02 DS F USED BY DAIRFAIL MYDFID DS H USED BY DAIRFAIL DOUBLE DS D EIGHT DS CL8 DDSAVE DS CL8 DAIRREGS DS F OPEND DS 0F CLOSED DS F DIREXLST DS F PDSEXLST DS F KOUNT DS F DKOUNT DS F SEQDCBW DS 0D,XL(SEQDCBL) PDSDCBW DS 0D,XL(PDSDCBL) DIRDCBW DS 0D,XL(DIRDCBL) DIRDECB DS 0F,XL(DIRDECBL) SYNADSW DS F SYNADMSG DS CL78 DEVDATA DS 2F JFCB DS 0F,CL176 DS 0D BLOCK DS 264C @DATAL EQU *-@DATA SPACE IHADCB DSECT DS 32XL1 DCBBFTEK DS XL1 DCBEODAD DS AL3 DCBRECFM DS X DCBEXLSA DS AL3 DCBDDNAM DS CL8 DCBOFLGS DS X DS 7XL1 DS X DCBSYNAD DS AL3 DCBBLKSI EQU IHADCB+62,2 DCBLRECL EQU IHADCB+82,2 SPACE IKJCPPL SPACE 3 IKJPPL SPACE IKJDFPB SPACE 2 IKJUPT SPACE 2 IKJIOPL SPACE 2 IKJDAPL SPACE 2 IKJDAP08 SPACE 2 IKJDAP18 SPACE 2 IKJPSCB SPACE 2 AIF (NOT &MVS).SKIP12 IKJEFFDF DFDSECT=YES .SKIP12 ANOP SPACE 2 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