**************************************************************** * 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 FETCH THE RECORD * * VARIABLES FROM REXX AND WRITE A MEMBER TO A PDS * * * * 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 = NUMBER OF RECORDS TO WRITE * * STOW VALUE = ADD OR REP (REPLACE) * * DIRECTORY = IF REQUESTED, THE DIRECTORY INFO TO STORE * * * * 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. * **************************************************************** ALXRWRTM CSECT ALXRWRTM AMODE 31 ALXRWRTM 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 REPLACE_FLAG EQU 8 ALLDONE_FLAG EQU 4 STM R14,R12,12(R13) LR R7,R1 SAVE THE PARAMETER ADDRESS LR R12,R15 SET UP BASE REGISTER ADDRESS. USING ALXRWRTM,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 MVC MEMBER(8),BLANKS MOVE IN BLANKS EX R3,MOVEMMBR MVC MEMBER(0),0(R10) XC TTR(66),TTR CLEAR OUT ALL DIRECTORY INFO ************************************************************** * THE SECOND PARAMETER IS THE DDNAME OF THE MEMBER TO READ * ************************************************************** CLC 8(8,R11),FFFLAG END OF PARM LIST BE BAD_PARM YES, THEN NOT ENOUGH TO CONTINUE 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 BAD_PARM YES, THEN NOT ENOUGH TO CONTINUE 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 NUMBER OF RECORDS TO WRITE * ****************************************************************** PROCESS_COUNT EQU * CLC 24(8,R11),FFFLAG END OF PARM LIST BE BAD_PARM YES, THEN NOT ENOUGH TO CONTINUE ICM R9,15,28(R11) GET THE LENGTH OF VAR NAME BZ BAD_PARM IF ZERO THEN GET OUT 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 LTR R8,R8 CAN'T BE 0 OR LESS BNP BAD_PARM YES, THEN JUST QUIT STH R8,COUNT_VALUE SAVE THE COUNT FOR GETMAIN ****************************************************************** * THE FIFTH PARAMETER IS THE STOW VALUE FOR ADDING OR REPLACING * * THE MEMBER. * ****************************************************************** PROCESS_ADDREP 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 PROCESS_DIRECTORY IF 0 THEN WE ARE DONE L R10,32(R11) POINT TO THE ARGUMENT CH R9,HW3 LENGTH 3 IS ALL IT CAN BE BNE BAD_PARM GT JUST GET OUT CLC 0(3,R10),ADD SEE IF ADD BE PROCESS_DIRECTORY YES, THEN LEAVE ALONE CLC 0(3,R10),REPLACE SEE IF REPLACE BNE BAD_PARM NO, THEN IT IS BAD OI FLAG,REPLACE_FLAG SET FLAG FOR STOW ****************************************************************** * THE SIXTH PARAMETER WILL BE THE DIRECTORY INFORMATION TO STORE* * WITH THE MEMBER. * ****************************************************************** PROCESS_DIRECTORY EQU * CLC 40(8,R11),FFFLAG END OF PARM LIST BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES ICM R8,15,44(R11) GET THE LENGTH OF VAR NAME BE USE_DEFAULTS YES, USE REMAINING DEFAULT VALUES CH R8,HW62 CANNOT BE MORE THAN 58 BYTES BH BAD_PARM YES, THEN GET OUT L R10,40(R11) POINT TO THE ARGUMENT LR R15,R8 SAVE LENGTH FOR EX MOVE SLR R9,R9 CLEAR FOR SPLITTING/CHECKING R8 SRDL R8,1 SPLIT IT IN HALF FOR HW COUNT LTR R9,R9 SEE IF ODD BZ NOTODD NO, THEN GO AROUNT LA R8,1(R8) INCREMENT FOR ODD NOTODD EQU * MVI DIRECTORY_DATA,C' ' SET UP FIRST BLANK MVC DIRECTORY_DATA+1(57),DIRECTORY_DATA AND BLANK IT OUT BCTR R15,0 DECREMENT FOR EX MOVE EX R15,DIRECT_MOVE MVC DIRECTORY_DATA(0),0(R10) STC R8,HALFWORD_COUNT AND SAVE THE HW COUNT USE_DEFAULTS EQU * ********************************************************************* * THIS SECTION WILL OPEN THE FILE, GET THE DCB ATTRIBUTES, ACQUIRE * * THE REXX STORAGE, AND BUILD THE SHV BLOCKS FOR FETCH OF RECORDS * ********************************************************************* OPENLIB EQU * LA R14,OPENBSM SET THE ADDRESS FOR MODE CHANGE ICM R14,8,=X'00' SET HI FOR 24 BIT BSM R0,R14 AND SET IT OPENBSM EQU * OPEN (PDSLIB,(OUTPUT)) TM PDSLIB+48,X'10' CHECK FOR GOOD OPEN BZ BAD_OPEN NO, THEN SEE YA TM PDSLIB+36,X'C0' CHECK FOR RECFM U BO BAD_RECFM YES, THEN SEE YA ********************************************************************* 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 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 LH R4,PDSLIB+82 LRECL LH R3,COUNT_VALUE RELOAD COUNT FOR LOOP 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 SET_RECORD EQU * STCM R4,15,0(R10) MOVE IN THE VARIABLE DATA LENGTH LA R10,4(R4,R10) GET PAST THE VARIABLE DATA BCT R3,LOOPMOVE AND LOOP BACK THRU SETTO31 LA R14,FETCHIT ICM R14,8,=X'80' BSM R0,R14 **************************************** FETCHIT L R14,GETMAIN_ADDRESS USING ALXPARM,R14 MVC ALXEXCOM_FUNCTION(8),=C'FETCH ' LH R3,COUNT_VALUE ST R3,ALXEXCOM_VARCOUNT 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 LA R10,ALXEXCOM_STORAGE LOAD NOW FOR WRITN STORAGE DROP R14 L R15,ALXEXCOM BALR R14,R15 LTR R15,R15 BZ SETTO24 CH R15,HW4 TRUNCATION ON FETCH IS OKAY BNE BAD_FETCH SETTO24 LA R14,LOAD_COUNT ICM R14,8,=X'00' BSM R0,R14 **************************************** LOAD_COUNT EQU * LH R11,COUNT_VALUE GET THE LOOP COUNT SLR R7,R7 CLEAR FOR INSERT CHARACTER LOOPBLOK SLR R9,R9 CLEAR FOR BLOCKSIZE COUNT LR R4,R8 GET POINTER TO OUTPUT BLOCK LH R1,PDSLIB+62 GET THE BLOCK SIZE TM PDSLIB+36,X'40' IS IT VARIABLE LENGTH BLOCK BZ CLEAR_BLOCK NO, THEN DO NOT DECREMENT SH R1,HW4 DECR FOR THE BDW LA R4,4(R4) INCREMNET PAST BDW B DONTDECR NO, THEN DO NOT DECREMENT CLEAR_BLOCK EQU * BLANK OUT TO PAD FOR RECFM F LR R14,R4 GET THE LOCATION OF BLOCK LR R15,R1 GET THE BLKSIZE IN R15 SLR R3,R3 CLEAR FOR LENGTH ICM R3,8,BLANKS SET FOR BLANKING LR R2,R14 WASTE OF TIME MVCL R14,R2 BLANK OUT THE BLOCK DONTDECR STH R1,BLOCK_SIZE SAVE THE COMPARE LENGTH * LOOPWRIT ICM R15,15,0(R10) GET THE LENGTH OF VARIABLE NAME ST R10,SAVE_LOCR10 SAVE FOR POSS. RELOAD AT WRITE LA R10,4(R15,R10) AND INCREMENT TO THE VARIABLE ICM R7,3,0(R10) GET THE ACTUAL LENGTH OF RECORD BZ BAD_FETCH ZERO, THEN GET OUT * LR R2,R7 SAVE THIS LENGTH FOR NOW LA R2,4(R7) SAVE THIS LENGTH + RDW TM PDSLIB+36,X'40' IS IT VARIABLE LENGTH BLOCK BO ADD_BLK YES, THEN GO AROUND LH R2,PDSLIB+82 GET THE FB LRECL INSTEAD ADD_BLK LA R15,0(R2,R9) ADD THE TWO TOGETHER CH R15,BLOCK_SIZE AND COMPARE TO THE BLKSIZE BNL WRITE_BLOCK IF EQ TO OR GT THEN WRITE IT AR R9,R2 INCREMENT THE BLOCK COUNT LA R2,4(R10) ADDRESS THE VARIABLE DATA LR R3,R7 AND GET THE LENGTH HERE LR R14,R4 GET THE LOCATION POINTER TM PDSLIB+36,X'40' IS IT VARIABLE LENGTH BLOCK BZ NO_RDW NO, THEN DO NOT INCREMENT LA R1,4(R7) INCREMENT FOR LENGTH OF RDW STCM R1,3,0(R4) SAVE THE LENGTH IN THE RDW LA R4,0(R1,R4) AND INCREMENT TO NEXT RECD LA R14,4(R14) INCREMENT PAST THE RDW B CHECK_MOVE NO_RDW AH R4,PDSLIB+82 INCREMENT BY LENGTH OF LRECL CHECK_MOVE EQU * CH R7,HW256 SEE IF TOO BIG FOR MVC BNH NOT_MVCL NO, THEN MOVE AS FASTER INSTR LR R15,R7 GET THE LENGTH MVCL R14,R2 AND MOVE THE DATA B DONEMOVE NOT_MVCL BCTR R3,0 DECR FOR EX MOVE EX R3,MOVE_RECORD MVC 0(0,R14),0(R2) DONEMOVE EQU * SLR R14,R14 CLEAR FOR INSERT ICM R14,3,2(R10) GET THE INITIAL LENGTH LA R10,4(R14,R10) ** AND INCREMENT TO NEXT ** BCT R11,LOOPWRIT OI FLAG,ALLDONE_FLAG FLAG TO SAY ALL DONE **** WRITE_BLOCK EQU * SR R4,R8 GET THE LENGTH OF THE BLOCK TM PDSLIB+36,X'40' IS IT VARIABLE LENGTH BLOCK BZ NO_BDW NO, THEN DO NOT INCREMENT STCM R4,3,0(R8) STORE THE LENGTH IN THE BDW NO_BDW EQU * LH R5,PDSLIB+62 SAVE PERMANENT BLKSIZE STH R4,PDSLIB+62 SAVE THE BLKSIZE WRITE PDSDECB,SF,PDSLIB,(8) CHECK PDSDECB STH R5,PDSLIB+62 AND PUT IT BACK L R10,SAVE_LOCR10 RELOAD FOR VARIABLE NAME TM FLAG,ALLDONE_FLAG WAS THAT THE LAST BLOCK BZ LOOPBLOK YES, THEN GET OUT STOWIT TM FLAG,REPLACE_FLAG BZ ADDIT STOW PDSLIB,MEMBER,R LTR R15,R15 CHECK THE STOW BNZ BAD_STOWREP B SETREPLY ADDIT EQU * STOW PDSLIB,MEMBER,A LTR R15,R15 CHECK THE STOW BNZ BAD_STOWADD SETREPLY LA R8,2 SET THE DEFAULT REPLY MESSAGE **** CLOSEUP EQU * CLOSE PDSLIB **** 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 * 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 LA R8,25 B RESET31 ************************* BAD_STORAGE EQU * MVC STATUS_AREA(33),STORAGE_ERROR LA R8,22 B CLOSEUP ************************* BAD_RECFM EQU * MVC STATUS_AREA(33),RECFM_ERROR LA R8,29 B CLOSEUP ************************* BAD_FETCH EQU * MVC STATUS_AREA(33),FETCH_ERROR LA R8,30 B CLOSEUP ************************* BAD_STOWREP EQU * CH R15,HW8 SEE IF REPLACE FOR NON-EXISTENT MEM BNE BAD_STOWADD NO, THEN JUST ISSUE BAD STOW MSG MVC STATUS_AREA(33),STOW_REPLACE LA R8,31 B CLOSEUP ************************* BAD_STOWADD EQU * MVC STATUS_AREA(33),FAILED_STOW LA R8,25 B CLOSEUP ************************* EJECT PDSLIB DCB DDNAME=PDSLIB,DSORG=PO,MACRF=W ALXEXCOM DC V(ALXEXCOM) 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) DIRECT_MOVE MVC DIRECTORY_DATA(0),0(R10) INITVARN MVC 4(0,R10),VARNAME MOVE_VARDATA MVC 4(0,R10),0(R5) MOVE_RECORD MVC 0(0,R14),0(R2) PACK_COUNT PACK DOUBLE_WORD(0),0(0,R10) PACK_START EQU PACK_COUNT HW3 DC H'3' HW4 DC H'4' HW8 DC H'8' HW17 DC H'17' HW33 DC H'33' HW62 DC H'62' HW256 DC H'256' HW1000 DC H'1000' HW9999 DC H'9999' FFFLAG DC 8X'FF' COUNT_VALUE DC H'00' 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' ADD DC CL3'ADD' REPLACE DC CL3'REP' ****** ****** BLANKS DC CL8' ' STATUS_AREA DC CL33'OK' ERROR_FUNCTION DC CL33'ERROR IN SPECIFYING THE FUNCTION' 33 OPEN_ERROR DC CL33'ERROR OPENING PDS DATASET ' 25 STORAGE_ERROR DC CL33'STORAGE REQUEST FAILED ' 22 RECFM_ERROR DC CL33'RECORD FORMAT U NOT SUPPORTED ' 29 FETCH_ERROR DC CL33'ERROR WITH REXX FETCH SERVICES ' 30 STOW_REPLACE DC CL33'REPLACE SPECIFIED, MEMBER ADDED ' 31 FAILED_STOW DC CL33'FAILURE IN STORING MEMBER ' 25 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 SAVE_LOCR10 DS F MEMBER DS CL8 TTR DS 3X HALFWORD_COUNT DS X DIRECTORY_DATA DS CL62 BLOCK_SIZE DS H ** 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