**************************************************************** * AUTHOR - BILL SWEENEY * * SSC, INC. (703) 777-2771 * * WHSWEENEY@SSCMAINFRAME.COM * * WWW.SSCMAINFRAME.COM * * DATE - (C) COPYRIGHT 1997 * * * * THIS PROGRAM IS A REXX FUNCTION THAT WILL PROCESS * * REQUESTS FOR MANIPULATING A PDS * * * * THE VARIABLES THAT WILL BE PASSED THROUGH REGISTER 1 ARE: * * FUNCTION = SCRATCH, RENAME OR ALIAS * * DDNAME = THE DDNAME TO SEARCH * * MEMBER = THE MEMBER NAME TO PROCESS * * MEMBER = THE NAME FOR RENAME OR ALIAS * * * * THE VARIABLE VALUE THAT WILL BE RETURNED IS: * * STATUS_AREA = WHERE THIS PROGRAM WILL RETURN THE STATUS * * * * REGISTERS: * * R1 - FIVE WORD PARAMETER LIST OF REXX VARIABLES * * WORD1 - RESERVED * * WORD2 - RESERVED * * WORD3 - RESERVED * * WORD4 - ADDRESS OF ARGUMENTS PASSED BY REXX * * WORD5 - ADDRESS OF THE EVALUATION BLOCK WHERE WE * * WILL RETURN THE REPLY * * * * I AM ONLY INTERESTED IN R1 BECAUSE IT WILL PASS THE ADDRESS * * PARAMETER LIST OF VARIABLES. EVERYTHING IS STANDARD * * USAGE AND NOTHING TO WRITE HOME ABOUT. * **************************************************************** ALXRPDSC CSECT ALXRPDSC AMODE 31 ALXRPDSC RMODE 24 PRINT ON,NOGEN,NODATA 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 NO_STORAGE EQU 20 FOUND_DDN EQU 1 STM R14,R12,12(R13) LR R7,R1 SAVE THE PARAMETER ADDRESS LR R12,R15 SET UP BASE REGISTER ADDRESS. USING ALXRPDSC,R12 GETMAIN RC,LV=STORAGE_SIZE LTR R15,R15 BZ GOOD_STORAGE LA R15,NO_STORAGE B RETURN2 GOOD_STORAGE EQU * ST R1,8(R13) ST R13,4(R1) LR R13,R1 USING STORAGE,R13 XC FLAG(1),FLAG ST R7,EVALBLK_ADDRESS ************************************************************** * THE FIRST PARAMETER IS THE FUNCTION TO PROCESS * ************************************************************** L R11,16(R7) LET'S GET OUR ARGUMENT CLC 0(8,R11),FFFLAG IS THERE ANY ARGUMENT BE BAD_PARM NO, THEN QUIT WITH ERROR ICM R3,15,4(R11) GET THE LENGTH OF ARGUMENT BZ BAD_PARM IF NULL/ZERO THEN DO DEFAULT L R10,0(R11) AND ADDRESS THE ARGUMENT CLC 0(7,R10),SCRATCH_KW IS THIS A SCRATCH FUNCTION BNE CHECK_RENAME NO, THEN TRY RENAME OI FLAG,X'01' SET A FLAG FOR NOW B SECOND_VARIABLE GO PROCESS THE NEXT VARIABLE CHECK_RENAME EQU * CLC 0(6,R10),RENAME_KW IS THIS A RENAME FUNCTION BNE CHECK_ALIAS NO, THEN TRY ALIAS OI FLAG,X'02' SET A FLAG FOR NOW B SECOND_VARIABLE GO PROCESS THE NEXT VARIABLE CHECK_ALIAS EQU * CLC 0(5,R10),ALIAS_KW IS THIS AN ALIAS FUNCTION BNE BAD_PARM NO, THEN BAD FUNCTION ************************************************************** * THE SECOND PARAMETER IS THE DDNAME OF THE MEMBER TO READ * ************************************************************** SECOND_VARIABLE EQU * CLC 8(8,R11),FFFLAG END OF PARM LIST BE BAD_PARM YES, THEN THERE IS AN ERROR ICM R9,15,12(R11) GET THE LENGTH OF DDNAME VALUE BZ THIRD_VARIABLE IF 0 THEN USE DEFAULT AND GO TO NEXT CH R9,HW8 LENGTH 8 IS THE MAX BH BAD_PARM GT JUST GET OUT MVC PDSREAD+40(8),BLANKS BLANK IT OUT FOR EX MOVE MVC DIRREAD+40(8),BLANKS BLANK IT OUT FOR EX MOVE L R10,8(R11) POINT TO THE ARGUMENT BCTR R9,0 DECREMENT IT BY ONE EX R9,MOVEDDN MVC PDSREAD+40(0),0(R10) MVC DIRREAD+40(8),PDSREAD+40 AND MOVE IT IN HERE ALSO ************************************************************** * THE THIRD PARAMETER IS THE MEMBER NAME * ************************************************************** THIRD_VARIABLE EQU * CLC 16(8,R11),FFFLAG END OF PARM LIST BE BAD_PARM YES, USE REMAINING DEFAULT VALUES ICM R9,15,20(R11) GET THE LENGTH OF VAR NAME BZ BAD_PARM IF 0 THEN USE DEFAULT AND GO TO NEXT CH R9,HW8 LENGTH 17 IS THE MAX BH BAD_PARM GT JUST GET OUT L R10,16(R11) POINT TO THE ARGUMENT MVC MEMBER_NAME(8),BLANKS BLANK OUT THE MEMBER BCTR R9,0 DECREMENT IT BY ONE FOR MOVE EX R9,MOVEMMBR MVC MEMBER_NAME(0),0(R10) ****************************************************************** * THE FOURTH PARAMETER IS RENAME OR ALIAS NAME * ****************************************************************** FOURTH_VARIABLE EQU * CLC 24(8,R11),FFFLAG END OF PARM LIST BE OPENLIB YES, USE REMAINING DEFAULT VALUES ICM R9,15,28(R11) GET THE LENGTH OF VAR NAME BZ OPENLIB YES, USE REMAINING DEFAULT VALUES TM FLAG,X'01' WAS THIS A SCRATCH BO BAD_PARM YES, THEN ERROR L R10,24(R11) POINT TO THE ARGUMENT TM FLAG,X'02' WAS THIS A RENAME BZ MOVE_AL NO, THEN MOVE THE ALIAS MVC RENAME_NAME(8),BLANKS BLANK OUT THE MEMBER BCTR R9,0 DECREMENT IT BY ONE FOR MOVE EX R9,MOVERENM MVC RENAME_NAME(0),0(R10) B OPENLIB * MOVE_AL MVC ALIAS_NAME(8),BLANKS BLANK OUT THE MEMBER BCTR R9,0 DECREMENT IT BY ONE FOR MOVE EX R9,MOVE_ALIAS MVC ALIAS_NAME(0),0(R10) ********************************************************************* * THIS SECTION WILL OPEN THE FILE AND READ IN ALL THE PROGRAM * * ENTRIES TO THE TABLE. * ********************************************************************* OPENLIB EQU * LA R14,OPENBSM ICM R14,8,=X'00' BSM R0,R14 OPENBSM EQU * OPEN DIRREAD TM DIRREAD+48,X'10' BZ BAD_OPEN ***************************************************************** LA R8,DIRECTORY_READ LOCSET READ DIRDECB,SF,DIRREAD,(8) CHECK DIRDECB LR R7,R8 R10 POINTS TO FIELD READ LH R9,0(R7) R9 CONTAINS LENGTH OF RECORD AR R9,R7 POINT TO END OF LIST LA R7,2(R7) ADDRESS MEMBER LOOPMMBR CLC 0(8,R7),FFFLAG IS THIS THE LAST DIRECTORY ENTRY BE NOTFOUND YES, THEN CLOSE IT AND GET TO WORK * INITIALIZE THE SHV BLOCKS AND INCREMENT THE COMPOUND VARIABLE HERE * *********** CLC 0(8,R7),MEMBER_NAME COMPARE FOR OUR MEMBER BE FOUND_IT YES, THEN WE ARE OKAY GETPAST IC R14,11(R7) GET # OF USER HALFWORDS N R14,FW31 ZERO OUT HI ORDER BITS SLA R14,1 MULTIPLY BY TWO LA R14,12(R14) ADD THE CONSTANT SECTION TO IT AR R7,R14 AND THEN INCREMENT R10 CR R7,R9 ARE WE AT THE END OF THIS READ BL LOOPMMBR NO, THEN PROCESS THE NEXT B LOCSET READ NEXT RECORD EJECT ****************************************************** FOUND_IT EQU * CLOSE DIRREAD OPEN (PDSREAD,(OUTPUT)) TM PDSREAD+48,X'10' BZ BAD_OPEN LA R3,MEMBER_NAME XC MEMBER_NAME+8(8),MEMBER_NAME+8 VERIFY IT IS ZERO TM FLAG,X'01' IS THIS A SCRATCH BZ TRY_RENAME STOW PDSREAD,(3),D LTR R15,R15 BNZ NOT_SCRATCHED B OKAYFUNC TRY_RENAME EQU * TM FLAG,X'02' IS THIS A SCRATCH BZ DO_ALIAS MVC MEMBER_NAME+8(8),RENAME_NAME MOVE IT IN FOR RENAME STOW PDSREAD,(3),C LTR R15,R15 BNZ NOT_RENAMED B OKAYFUNC DO_ALIAS EQU * IC R14,11(R7) GET # OF USER HALFWORDS N R14,FW31 ZERO OUT HI ORDER BITS SLA R14,1 MULTIPLY BY TWO LA R14,11(R14) ADD THE CONSTANT SECTION TO IT EX R14,MOVEDIRE MVC MEMBER_NAME(0),0(R7) MVC MEMBER_NAME(8),ALIAS_NAME MOVE IT IN WITH THE TTR OI MEMBER_NAME+11,X'80' TURN ON ALIAS BIT * AND ADD THE ALIAS STOW PDSREAD,(3),A LTR R15,R15 BNZ NOT_ALIASED OKAYFUNC LA R8,4 CLOSEUP EQU * CLOSE PDSREAD RESET31 LA R14,SETRPLY ICM R14,8,=X'80' BSM R0,R14 **************************************** SETRPLY L R7,EVALBLK_ADDRESS L R10,20(R7) L R10,0(R10) USING EVALBLOCK,R10 ST R8,EVALBLOCK_EVLEN LA R14,16(R8) SRDL R14,32 LA R3,8 DIVISOR BY DOUBLE WORDS DR R14,R3 DIVIDE IT LTR R14,R14 BZ NO_INCREMENT LA R15,1(R15) NO_INCREMENT EQU * ST R15,EVALBLOCK_EVSIZE MVC EVALBLOCK_EVDATA(33),STATUS_AREA FREESTOR EQU * LR R1,R13 L R13,4(R13) SO WE CAN GET OUT OF HERE FREEMAIN RC,A=(1),LV=STORAGE_SIZE RETURN1 SLR R15,R15 RETURN2 L R14,12(R13) LM R0,R12,20(R13) BR R14 BAD_PARM EQU * MVC STATUS_AREA(33),ERROR_FUNCTION LA R8,32 B SETRPLY BAD_OPEN EQU * MVC STATUS_AREA(33),OPEN_ERROR LA R8,25 B RESET31 ************************* NOTFOUND EQU * MVC STATUS_AREA(33),NOT_FOUND_MBR LA R8,26 CLOSE DIRREAD B CLOSEUP ************************* NOT_SCRATCHED EQU * MVC STATUS_AREA(33),NOT_SCRATCH_MBR LA R8,14 B CLOSEUP ************************* NOT_RENAMED EQU * MVC STATUS_AREA(33),NOT_RENAME_MBR LA R8,13 B CLOSEUP ************************* NOT_ALIASED EQU * MVC STATUS_AREA(33),NOT_ALIAS_MBR LA R8,24 B CLOSEUP ************************* ************************* DIRREAD DCB DDNAME=PDSUPDTE,DSORG=PS,MACRF=R,EODAD=NOTFOUND, + BLKSIZE=256,LRECL=256,RECFM=F PDSREAD DCB DDNAME=PDSUPDTE,DSORG=PO,MACRF=W EJECT MOVEMMBR MVC MEMBER_NAME(0),0(R10) MOVERENM MVC RENAME_NAME(0),0(R10) MOVE_ALIAS MVC ALIAS_NAME(0),0(R10) MOVEDDN MVC PDSREAD+40(0),0(R10) MOVEDIRE MVC MEMBER_NAME(0),0(R7) FW31 DC F'31' HW1 DC H'1' HW8 DC H'8' HW80 DC H'80' FFFLAG DC 8X'FF' SCRATCH_KW DC CL7'SCRATCH' RENAME_KW DC CL6'RENAME' ALIAS_KW DC CL5'ALIAS' ****** ****** BLANKS DC CL8' ' STATUS_AREA DC CL34'OK' ERROR_FUNCTION DC CL33'ERROR IN SPECIFYING THE FUNCTION' OPEN_ERROR DC CL33'ERROR OPENING PDS DATASET ' 24 STORAGE_ERROR DC CL33'STORAGE REQUEST FAILED ' NOT_FOUND_MBR DC CL33'MEMBER REQUESTED NOT FOUND ' NOT_SCRATCH_MBR DC CL33'SCRATCH FAILED ' NOT_RENAME_MBR DC CL33'RENAME FAILED ' NOT_ALIAS_MBR DC CL33'ALIAS ASSIGNMENT FAILED ' *********** STORAGE DSECT SAVEAREA DS 18F BLDL_COUNT DS H BLDL_LENGTH DS H MEMBER_NAME DS CL8,2F DS 60X RENAME_NAME DS CL8 ALIAS_NAME DS CL8 GETMAIN_ADDRESS DS F EVALBLK_ADDRESS DS F GETMAIN_LENGTH DS F FLAG DS X DIRECTORY_READ DS 256X ************************* STORAGE_SIZE EQU *-SAVEAREA ** IRXEVALB END