**************************************************************** * 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: * * MEMBER = WHICH WILL CONTAIN THE MEMBER NAME TO FIND * * DDNAME = THE DDNAME TO SEARCH * * VARIABLE_NAME = NAME OF THE COMPOUND VARIABLE * * COUNT = MAXIMUM NUMBER OF RECORDS TO READ * * * * 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. * **************************************************************** ALXRGETM CSECT ALXRGETM AMODE 31 ALXRGETM 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 ALXRGETM,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 MEMBER TO READ * ************************************************************** 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 CH R3,HW8 VERIFY IT'S NOT TOO LONG BH BAD_PARM NO, THEN CONTINUE BCTR R3,0 DECREMENT FOR EXECUTE MOVE L R10,0(R11) AND ADDRESS THE ARGUMENT EX R3,MOVEMMBR MVC MEMBER(0),0(R10) ************************************************************** * THE SECOND PARAMETER IS THE DDNAME OF THE MEMBER TO READ * ************************************************************** 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 DDNAME VALUE BZ PROCESS_VARNAME IF 0 THEN USE DEFAULT AND GO TO NEXT MVC PDSLIB+40(8),BLANKS BLANK OUT THE DDNAME L R10,8(R11) POINT TO THE ARGUMENT BCTR R9,0 DECREMENT IT BY ONE EX R9,MOVEDDN MVC PDSLIB+40(0),0(R10) ************************************************************** * THE THIRD PARAMETER IS THE COMPOUND VARIABLE NAME * ************************************************************** PROCESS_VARNAME 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_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,16(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 FOURTH PARAMETER IS THE MAXIMUM NUMBER OF RECORDS TO READ * ****************************************************************** PROCESS_COUNT 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_START IF 0 THEN USE DEFAULT AND GO TO NEXT L R10,24(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 STH R8,UCOUNT_VALUE SAVE COUNT FOR RECFM U ALSO ****************************************************************** * THE FIFTH PARAMETER IS THE STARTING NUMBER OF WHERE TO BEGIN * * READING RECORDS. THIS WOULD BE USED FOR SUBSEQUENT INVOCATION * * OF THIS FUNCTION TO PICK UP WHERE IT LEFT OFF. * ****************************************************************** PROCESS_START 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 IF 0 THEN WE ARE DONE L R10,32(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_START PACK DOUBLE_WORD(0),0(0,R10) CVB R8,DOUBLE_WORD GET THE START RECORD NUMBER IN R8 STH R8,START_VALUE SAVE THE COUNT FOR READING RECORDS USE_DEFAULTS EQU * ********************************************************************* * 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 PDSLIB TM PDSLIB+48,X'10' BZ BAD_OPEN TM PDSLIB+36,X'C0' BNO NOT_UCOUNT MVC COUNT_VALUE(2),UCOUNT_VALUE NOT_UCOUNT EQU * 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) ACCOUNT FOR HEADER INFORMATION TM PDSLIB+36,X'C0' VERIFY NOT RECFM U BNO NOTLMOD MH R3,PDSLIB+62 AND MULTIPLY BY BLKSIZE B COUNTSET AND GO AROUND NOTLMOD LA R3,1(R3) ADD ONE MORE FOR MEMBER.0 MH R3,PDSLIB+82 MULTIPLY BY LRECL FOR MAX RECORD COUNTSET LH R0,PDSLIB+62 GET THE BLKSIZE IN HERE AS WELL AR R5,R3 AR 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 LR R10,R1 SAVE FOR REXX SHV BLOCK DATA LA R8,0(R5,R10) POINT PAST THE SHV BLOCK INFO LA R10,20(R10) INCREMENT PASSED HEADER INFO ST R8,BLOCK_ADDRESS SAVE THE ADDRESS LA R2,MEMBER FIND PDSLIB,(2),D LTR R15,R15 BNZ NOT_FOUND ************************************************************ 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 LOOPREAD EQU * LH R14,PDSLIB+62 IF IT IS RECFM U THEN NEED BLKSIZE READ PDSDECB,SF,PDSLIB,(8),(14) CHECK PDSDECB L R14,BLOCK_COUNT LA R14,1(R14) INCREMENT BY ONE ST R14,BLOCK_COUNT LH R6,PDSLIB+62 BLKSIZE L R7,PDSDECB+16 IOB SH R6,14(R7) SRDL R6,32 LR R9,R7 SAVE THE BLOCK SIZE READ LH R4,PDSLIB+82 LRECL LR R5,R8 TM PDSLIB+36,X'80' IS IT VARIABLE LENGTH BLOCK BO LOOPMOVE NO, THEN PROCESS FIXED LA R5,4(R5) ADDRESS PAST BDW SH R7,HW4 SUBTRACT THE BDW LOOPMOVE EQU * * INITIALIZE THE SHV BLOCKS AND INCREMENT THE COMPOUND VARIABLE HERE * 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 * * PROCESS RECFM U BLOCKS AS INDIVIDUAL COMPOUND VARIABLES * TM PDSLIB+36,X'C0' IS IT A LOAD MODULE BNO CHECK_VARBLE NO, THEN PROCESS FIXED BLOCK LR R4,R9 GET THE SIZE OF THE BLOCK READ B MOVE_RECORD AND GO PROCESS THE RECORD ** CHECK_VARBLE EQU * TM PDSLIB+36,X'40' IS IT VARIABLE LENGTH BLOCK BZ MOVE_RECORD NO, THEN PROCESS FIXED BLOCK SLR R4,R4 CLEAR R4 ICM R4,3,0(R5) GET THE RDW SH R4,HW4 SUBTRACT THE RDW SH R7,HW4 AND FROM THE OVERALL SIZE LA R5,4(R5) INCREMENT PAST THE RDW MOVE_RECORD EQU * STCM R4,15,0(R10) MOVE IN THE VARIABLE DATA LENGTH SR R7,R4 REMOVE THE LENGTH CH R4,HW255 IS THIS TOO BIG FOR MVC * DC H'00' BL NOT_MVCL LA R14,4(R10) POINT TO LOCATION OF VAR DATA LR R0,R5 POINT TO THE INPUT DATA LR R1,R4 GET THE LENGTH LR R15,R4 HERE ALSO MVCL R14,R0 MOVE IT IN LA R10,4(R4,R10) GET PAST THE VARIABLE DATA B ITSMOVED AND GO AROUND NOT_MVCL LR R15,R4 GET THE LENGTH FOR DECR BCTR R15,0 DECR FOR EX MVC EX R15,MOVE_VARDATA MVC 4(0,R10),0(R5) LA R10,4(R4,R10) GET PAST THE VARIABLE DATA ITSMOVED LA R3,1(R3) INCREMENT THE COUNT CH R3,COUNT_VALUE CHECK TO SEE IF MAX HIT BNL CLOSEUP ELSE FINISH UP AND GET OUT CHCKLOOP LTR R7,R7 SEE IF ANY MORE RECORDS LEFT BZ LOOPREAD READ THE NEXT RECORD LA R5,0(R4,R5) INCREMENT TO NEXT RECORD B LOOPMOVE THEN MORE RECORDS CLOSEUP EQU * CLOSE PDSLIB 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 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 CLOSEUP ************************* NOT_FOUND EQU * MVC STATUS_AREA(33),NOT_FOUND_MBR OI FLAG,X'01' SET FOR ERROR LA R8,26 B CLOSEUP ************************* DC H'00' EJECT PDSLIB DCB DDNAME=PDSLIB,DSORG=PO,MACRF=R,EODAD=CLOSEUP ALXEXCOM DC V(ALXEXCOM) MEMBER DC CL8' ',2F'0' MOVEMMBR MVC MEMBER(0),0(R10) MOVEDDN MVC PDSLIB+40(0),0(R10) MOVEVARN MVC VARNAME(0),0(R10) MOVERPLY MVC EVALBLOCK_EVDATA(0),STATUS_AREA MOVE_STEM MVC 0(0,R14),0(R1) 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 HW4 DC H'4' HW8 DC H'8' HW17 DC H'17' HW33 DC H'33' HW255 DC H'255' HW1000 DC H'1000' HW9999 DC H'9999' FFFLAG DC 8X'FF' UCOUNT_VALUE DC H'20' 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' ****** ****** 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 STORAGE_ERROR DC CL33'STORAGE REQUEST FAILED ' 22 NOT_FOUND_MBR DC CL33'MEMBER REQUESTED NOT_FOUND ' 26 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 BLOCK_ADDRESS DS F RECORD_COUNT DS F BLOCK_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