**************************************************************** * 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 READ A MEMBER * * IN A PDS AND RETURN THE RECORDS/BLOCKS AS COMPOUND VARIABLES * * * * THE VARIABLES THAT WILL BE PASSED THROUGH REGISTER 1 ARE: * * DDNAME = THE DDNAME TO SEARCH * * VARIABLE_NAME = NAME OF THE COMPOUND VARIABLE * * COUNT = MAXIMUM NUMBER OF MEMBERS TO LIST * * YES/NO = WHETHER OR NOT TO SUPPLY USER HALFWORDS * * DEFAULT WILL BE NO * * MEMBER = MEMBER MATCH FOR RETURN * * * * 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. * **************************************************************** ALXRDDIR CSECT ALXRDDIR AMODE 31 ALXRDDIR 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 YESHWS EQU 8 YESMEM EQU 4 STM R14,R12,12(R13) LR R7,R1 SAVE THE PARAMETER ADDRESS LR R12,R15 SET UP BASE REGISTER ADDRESS. USING ALXRDDIR,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 ST R7,EVALBLK_ADDRESS ************************************************************** * THE FIRST PARAMETER IS THE NAME OF THE DDNAME TO USE * ************************************************************** L R11,16(R7) LET'S GET OUR ARGUMENT CLC 0(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R9,15,4(R11) GET THE LENGTH OF DDNAME VALUE BZ PROCESS_VARNAME IF 0 THEN USE DEFAULT AND GO TO NEXT MVC DIRREAD+40(8),BLANKS BLANK OUT THE DDNAME L R10,0(R11) POINT TO THE ARGUMENT BCTR R9,0 DECREMENT IT BY ONE EX R9,MOVEDDN MVC DIRREAD+40(0),0(R10) ************************************************************** * THE SECOND PARAMETER IS THE COMPOUND VARIABLE NAME * ************************************************************** PROCESS_VARNAME EQU * CLC 8(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R9,15,12(R11) GET THE LENGTH OF VAR NAME BZ PROCESS_COUNT IF 0 THEN USE DEFAULT AND GO TO NEXT CH R9,HW17 LENGTH 17 IS THE MAX BH BAD_PARM GT JUST GET OUT L R10,8(R11) POINT TO THE ARGUMENT STH R9,VARNAME_LENGTH SAVE THE LENGTH BCTR R9,0 DECREMENT IT BY ONE FOR MOVE EX R9,MOVEVARN MVC VARNAME(0),0(R10) ****************************************************************** * THE THIRD PARAMETER IS THE MAXIMUM NUMBER OF MEMBERS TO READ * ****************************************************************** PROCESS_COUNT EQU * CLC 16(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R9,15,20(R11) GET THE LENGTH OF VAR NAME BZ PROCESS_USERHWS YES, THEN PROCESS FOURTH PARM L R10,16(R11) POINT TO THE ARGUMENT BCTR R9,0 DECREMENT IT BY ONE LA R8,7 DOUBLE_WORD LENGTH - 1 FOR EX SLL R9,28 GET IT IN THE HI-ORDER BYTE SLDL R8,4 AND SHIFT IT TOGETHER W/ OTHER LENG EX R8,PACK_COUNT PACK DOUBLE_WORD(0),0(0,R10) CVB R8,DOUBLE_WORD GET THE LENGTH OF REPLY IN R8 CH R8,HW9999 CAN'T BE GT MAX BH BAD_PARM YES, THEN JUST QUIT STH R8,COUNT_VALUE SAVE THE COUNT FOR GETMAIN ****************************************************************** * THE FOURTH PARAMETER IS A YES/NO VALUE FOR USER HALFWORDS * ****************************************************************** PROCESS_USERHWS EQU * CLC 24(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R9,15,28(R11) GET THE LENGTH OF VAR NAME BZ PROCESS_MEMBER YES, USE REMAINING DEFAULT VALUES CH R9,HW3 SEE IF LENGTH OF YES BNE PROCESS_MEMBER NO, THEN DON'T CHECK FURTHER L R10,24(R11) POINT TO THE ARGUMENT CLC 0(3,R10),YES IS IT A YES BNE PROCESS_MEMBER NO, THEN LEAVE DEFAULT OI FLAG,YESHWS SET THE FLAG ****************************************************************** * THE FIFTH PARAMETER IS A MEMBER SELECTION SEARCH ARGUMENT * ****************************************************************** PROCESS_MEMBER EQU * CLC 32(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R9,15,36(R11) GET THE LENGTH OF VAR NAME BZ USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES L R10,32(R11) POINT TO THE ARGUMENT BCTR R9,0 DECREMENT IT BY ONE FOR MOVE STH R9,MEMBER_LENGTH SAVE THE DECREMENTED LENGTH EX R9,MOVEMEMM MVC VARNAME(0),0(R10) OI FLAG,YESMEM SET THE FLAG USE_DEFAULTS EQU * ********************************************************************* * THIS SECTION WILL OPEN THE FILE AND READ IN ALL THE PROGRAM * * ENTRIES TO THE TABLE. * ********************************************************************* LH R3,COUNT_VALUE LH R5,VARNAME_LENGTH LA R5,17(R5) INCREMENT FOR SHV BLOCK INFO * VARNAME LGNTH+VARDATA LNGTH+VARDATA ADDR+ 5 (.9999) CH R3,HW1000 SEE IF LT 1000 BNL LEAVEIT BCTR R5,0 TAKE ONE AWAY FOR SMALLER GETMAIN LEAVEIT MH R5,COUNT_VALUE GET THE TOTAL GETMAIN LA R5,20(R5) INCR PASSED BEGINNING LA R3,1(R3) ADD ONE MORE FOR MEMBER.0 TM FLAG,YESHWS DO WE WANT THE DIRECTORY INFO BZ MULTIPLY_BY8 NO, THEN JUST MEMBER NAME LENGTH MH R3,HW69 MULT BY 8, BLANK, AND 60 BYTE USER B NOTBY8 MULTIPLY_BY8 EQU * SLL R3,3 MULTIPLY BY EIGHT NOTBY8 AR R5,R3 TOTAL THE GETMAIN LR R0,R5 ST R0,GETMAIN_LENGTH SAVE THE LENGTH GETMAIN RC,LV=(0) LTR R15,R15 BNZ BAD_STORAGE ISSUE MESSAGE AND GET OUT ST R1,GETMAIN_ADDRESS * ST R1,ALXEXCOM_STORAGE SAVE IT HERE AS WELL FOR SHV BLKS LA R10,20(R1) SAVE FOR REXX SHV BLOCK DATA 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 ************************************************************ LH R15,VARNAME_LENGTH BCTR R15,0 DECR FOR EXECUTE EX R15,INITVARN MVC 4(0,R10),VARNAME LA R14,5(R15,R10) POINT TO LOCATION PAST NAME MVC 0(2,R14),STEM0 MOVE IN PERIOD AND ZERO LA R15,3(R15) 1 FOR EX DECR, 1 FOR . , 1 FOR 0 STCM R15,15,0(R10) SAVE THE VARIABLE NAME LENGTH LA R10,2(R14) INCREMENT PAST STEM LH R15,HW4 LENGTH OF 4 FOR VAR DATA STCM R15,15,0(R10) SAVE THE LENGTH LA R10,4(R10) INCREMENT TO VAR DATA ST R10,STEM0_ADDRESS SAVE THIS LOCATION XC 0(4,R10),0(R10) AND ZERO THE VARDATA LA R10,4(R10) AND INCREMENT PAST IT LA R3,1 SET FOR MEMBER.0 VARIABLE * SLR R3,R3 MAINTAIN THE COUNT OF VARIABLES LA R8,DIRECTORY_READ LOCSET READ DIRDECB,SF,DIRREAD,(8) CHECK DIRDECB RDNXTDIR EQU * LIST0 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 LIST1 CLC 0(8,R7),FFFLAG IS THIS THE LAST DIRECTORY ENTRY BE DIRENDL YES, THEN CLOSE IT AND GET TO WORK * INITIALIZE THE SHV BLOCKS AND INCREMENT THE COMPOUND VARIABLE HERE * TM FLAG,YESMEM BZ INITVARS LH R15,MEMBER_LENGTH EX R15,COMPMEM CLC MEMBER_MASK(0),0(R7) BE INITVARS IF EQUAL THEN MOVE IN 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 LIST1 NO, THEN PROCESS THE NEXT B LOCSET READ NEXT RECORD INITVARS LH R15,VARNAME_LENGTH BCTR R15,0 DECR FOR EXECUTE EX R15,INITVARN MVC 4(0,R10),VARNAME LA R14,5(R15,R10) POINT TO LOCATION PAST NAME MVI 0(R14),C'.' MOVE IN PERIOD LA R14,1(R14) INCREMENT PAST AP COMPOUND_STEM(3),INCR_STEM(1) MVC STEM_VALUE(6),STEM_MASK SET THE MASK ED STEM_VALUE(6),COMPOUND_STEM TRT STEM_VALUE(6),NBLNKTBL LOOK FOR FIRST NON BLANK LA R2,STEM_VALUE+5 INCR FOR SUBTRACT SLR R2,R1 GET THE LENGTH EX R2,MOVE_STEM MVC 0(0,R14),0(R1) LA R15,3(R2,R15) 2 FOR EX DECR, AND 1 FOR PERIOD STCM R15,15,0(R10) SAVE THE VARIABLE NAME LENGTH LA R10,1(R2,R14) INCREMENT PAST STEM *********** LIST2 MVC 4(8,R10),0(R7) MOVE IN THE MEMBER NAME TM FLAG,YESHWS CHECK IT HERE TO SEE IF MORE THAN 8 BO GETPAST YES, THEN DO NOT SET THE NEXT VALUES MVC 0(4,R10),FW8 MOVE IN LENGTH OF 8 LA R10,12(R10) INCREMENT PAST THE MEMBER AND LNGTH LA R3,1(R3) INCR. COUNTER FOR MEMBERS CH R3,COUNT_VALUE CHECK TO SEE IF MAX HIT BNL DIRENDL ELSE FINISH UP AND GET OUT GETPAST IC R14,11(R7) GET # OF USER HALFWORDS N R14,FW31 ZERO OUT HI ORDER BITS SLA R14,1 MULTIPLY BY TWO TM FLAG,YESHWS CHECK IT AGAIN HERE TO SEE IF SET BZ NOTHWS NO, THEN GO AROUND THIS CODE LR R1,R14 GET THE LENGTH IN R1 BCTR R1,0 DECR FOR MOVE MVI 12(R10),C' ' SET IT AS A BLANK EX R1,MOVE_DIRECTRY MVC 13(0,R10),12(R7) LA R1,10(R1) INCR FOR MMBR, BLANK, AND HWS STCM R1,15,0(R10) SAVE THE LENGTH LA R10,4(R1,R10) AND INCR THE LOCATION LA R3,1(R3) INCR. COUNTER FOR MEMBERS CH R3,COUNT_VALUE CHECK TO SEE IF MAX HIT BNL DIRENDL ELSE FINISH UP AND GET OUT NOTHWS 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 LIST1 NO, THEN PROCESS THE NEXT B LOCSET READ NEXT RECORD EJECT ****************************************************** DIRENDL EQU * CLOSE DIRREAD CLOSE DIRECTORY ****************************************************** RESET31 LA R14,CHECK_ERROR ICM R14,8,=X'80' BSM R0,R14 CHECK_ERROR EQU * TM FLAG,X'01' DID AN ERROR OCCUR ?? BO SETRPLY **************************************** STOREIT L R14,GETMAIN_ADDRESS USING ALXPARM,R14 MVC ALXEXCOM_FUNCTION(8),=C'STORE ' ST R3,ALXEXCOM_VARCOUNT L R15,STEM0_ADDRESS BCTR R3,0 CVD R3,DOUBLE_WORD GET IT ED STEM_MASK(6),DOUBLE_WORD+5 MVC 0(4,R15),STEM_MASK+2 LA R1,ALXEXCOM_FUNCTION SET THE PARM FIELD UP LIKE ST R1,PARMLIST THIS SO THAT SUBROUTINE IS LA R1,PARMLIST ABLE TO HANDLE PARM LIKE COBOL * MVI ALXEXCOM_RETCODE,C'Y' TELL ALXEXCOM THAT VAR DATA * ADDRESS IS IN THE FIELD DROP R14 L R15,ALXEXCOM BALR R14,R15 **** * LA R8,2 SET THE DEFAULT REPLY MESSAGE **************************************** 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 * ICM R1,15,GETMAIN_ADDRESS BZ NOT_GOTTEN L R0,GETMAIN_LENGTH FREEMAIN RC,A=(1),LV=(0) NOT_GOTTEN 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,33 B SETRPLY BAD_OPEN EQU * MVC STATUS_AREA(33),OPEN_ERROR OI FLAG,X'01' SET FOR ERROR LA R8,25 B RESET31 ************************* BAD_STORAGE EQU * MVC STATUS_AREA(33),STORAGE_ERROR OI FLAG,X'01' SET FOR ERROR LA R8,22 B DIRENDL ****************************************************** * THIS NEXT SECTION IS ENTERED IF EODAD IS HIT OR AN * * I/O ERROR OCCURS * ****************************************************** NOTDIR EQU * MVC STATUS_AREA(33),READ_ERROR OI FLAG,X'01' SET FOR ERROR LA R8,25 B DIRENDL ************************* EJECT DIRREAD DCB DDNAME=DIRREAD,DSORG=PS,MACRF=R,EODAD=NOTDIR, X BLKSIZE=256,LRECL=256,RECFM=F ALXEXCOM DC V(ALXEXCOM) MOVEDDN MVC DIRREAD+40(0),0(R10) MOVEVARN MVC VARNAME(0),0(R10) MOVEMEMM MVC MEMBER_MASK(0),0(R10) COMPMEM CLC MEMBER_MASK(0),0(R7) MOVERPLY MVC EVALBLOCK_EVDATA(0),STATUS_AREA MOVE_STEM MVC 0(0,R14),0(R1) MOVE_DIRECTRY MVC 13(0,R10),12(R7) INITVARN MVC 4(0,R10),VARNAME MOVE_VARDATA MVC 4(0,R10),0(R5) PACK_COUNT PACK DOUBLE_WORD(0),0(0,R10) PACK_START EQU PACK_COUNT FW8 DC F'8' FW31 DC F'31' HW3 DC H'3' HW4 DC H'4' HW17 DC H'17' HW69 DC H'69' HW1000 DC H'1000' HW9999 DC H'9999' FFFLAG DC 8X'FF' COUNT_VALUE DC H'1000' START_VALUE DC H'1' VARNAME_LENGTH DC H'6' VARNAME DC CL22'RECORD ' STEM0 DC CL2'.0' STEM_VALUE DC CL6' ' STEM_MASK DC X'402020202120' COMPOUND_STEM DC PL3'0' INCR_STEM DC PL1'1' YES DC CL3'YES' MEMBER_LENGTH DC H'0' MEMBER_MASK DC CL8' ' ****** ****** BLANKS DC CL8' ' STATUS_AREA DC CL33'OK' ERROR_FUNCTION DC CL33'ERROR IN SPECIFYING READ FUNCTION' 33 OPEN_ERROR DC CL33'ERROR OPENING PDS DATASET ' 25 READ_ERROR DC CL33'ERROR READING PDS DATASET ' 25 STORAGE_ERROR DC CL33'STORAGE REQUEST FAILED ' 22 FLAG DC X'00' *********** LTORG DS 0F NBLNKTBL DC 256X'FF' ORG NBLNKTBL+C' ' DC X'00' ORG STORAGE DSECT SAVEAREA DS 18F DOUBLE_WORD DS D EVALBLK_ADDRESS DS F GETMAIN_ADDRESS DS F GETMAIN_LENGTH DS F STEM0_ADDRESS DS F DIRECTORY_READ DS 256X RECORD_COUNT DS F *************************** STORAGE_SIZE EQU *-SAVEAREA ** ALXPARM DSECT PARMLIST DS F ALXEXCOM_FUNCTION DS CL8 ALXEXCOM_VARCOUNT DS F ALXEXCOM_RETCODE DS F ALXEXCOM_STORAGE EQU * IRXEVALB END