*********************************************************************** 00000100 * * 00000200 * VSAM I/O PROCESSING MODULE 00000300 * WRITTEN BY : STEVE SCOTT * 00000400 * DATE: 02/89 * 00000500 * * 00000600 *********************************************************************** 00000700 VSIOMOD AMODE 31 00000801 VSIOMOD RMODE 24 00000901 *********************************************************************** 00001000 * REGISTER USAGE * 00001100 *********************************************************************** 00001200 * * 00001300 * R0 - WORK * 00001400 * R1 - WORK/ADDRESS OF PARAMETER LIST * 00001500 * R2 - WORK * 00001600 * R3 - BASE * 00001700 * R4 - FILE CONTROL TABLE DSECT REGISTER * 00001800 * R5 - PARAMETER LIST DSECT REGISTER * 00001900 * R6 - WORK AREA DSECT REGISTER * 00002000 * R7 - WORK * 00002100 * R8 - WORK * 00002200 * R9 - RETURN ADDRESS *** DO * NOT * SCREW * !! **** * 00002300 * R10 - ** UNUSED ** * 00002400 * R11 - ** UNUSED ** * 00002500 * R12 - ** UNUSED ** * 00002600 * R13 - PROGRAM SAVE AREA * 00002700 * R14 - BAL/WORK * 00002800 * R15 - WORK/SYSTEM * 00002900 * * 00003000 *********************************************************************** 00003100 EJECT 00003200 GBLB &TEST 00003300 &TEST SETB 0 ****** SET TO 1 IF TRACING DESIRED ******** 00003412 * 00003500 VSIOMOD START 0 00003600 R0 EQU 0 00003701 R1 EQU 1 00003801 R2 EQU 2 00003901 R3 EQU 3 00004001 R4 EQU 4 00004101 R5 EQU 5 00004201 R6 EQU 6 00004301 R7 EQU 7 00004401 R8 EQU 8 00004501 R9 EQU 9 00004601 R10 EQU 10 00004701 R11 EQU 11 00004801 R12 EQU 12 00004901 R13 EQU 13 00005001 R14 EQU 14 00005101 R15 EQU 15 00005201 EJECT 00005301 STM R14,R12,12(R13) 00005401 LR R3,R15 3'S THE BASE 00005501 USING VSIOMOD,R3 RESET USING STATUS 00005601 * 00005701 GETMAIN R,LV=72,SP=0 00005801 ST R13,4(R1) SET CHAIN 00005901 ST R1,8(R13) 00006001 LR R13,R1 GET SAVE AREA ADDR IN R13 00006101 * 00006201 L R1,4(R13) GET CALLER SAVE AREA ADDR 00006301 L R1,24(R1) RESTORE R1 CONTENTS FROM THEIR SAVE 00006401 L R5,0(R1) AND ADDRESS OF PARM LIST ADDR 00006501 L R5,0(R5) AND ADDRESS OF PARM LIST 00006601 * 00006701 USING VS$#@IOD,R5 SET UP USING 00006801 * 00006901 ESTAE SHELSHOK,PARAM=(R5),ASYNCH=NO 00007001 * 00007101 LA R0,WORKALEN LENGTH OF TEMP WORK AREAS 00007201 GETMAIN R,LV=(0) 00007301 LR R6,R1 PUT IN R6 00007401 LR R14,R6 CLEAR THE WORKAREA 00007501 LA R15,WORKALEN LENGTH OF AREA 00007601 XR R0,R0 00007701 XR R1,R1 00007801 MVCL R14,R0 00007901 USING WORKADS,R6 SET UP USING 00008001 * 00008101 MVI VS$#@IND,VS$#@ACT SET ACTIVE INDICATOR 00008201 EJECT 00008301 *********************************************************************** 00008401 * ENTRY POINT AFTER WAIT ECB POSTED * 00008501 *********************************************************************** 00008601 SPACE 00008701 FROMDTOP DS 0H HERES WHERE START AFTER WAIT POSTED 00008801 LA R9,RETURN INITIALIZE RETURN ADDRESS 00008901 * 00009001 USING FCDSECT,R4 R4 IS THE BASE FOR FILE CONTROL 00009101 * 00009201 MVN TESTBYTE,VS$#@FNC 00009301 AIF (NOT &TEST).NOTEST1 00009401 BAL R14,FCTRACE GO DO TRACE ROUTINE 00009501 * 00009601 .NOTEST1 ANOP , 00009701 CLI TESTBYTE,VS$#OPEN OPEN REQUEST? 00009801 BE CKOPER YES--> FILE WONT BE FOUND ON OPEN 00009901 ICM R4,15,VS$#@CTL GET CONTROL TAB ADDR 00010001 BZ INVFILE NOT THERE--> ERROR 00010101 * 00010201 CLI VS$#@FNC,VS$#CLOS+VS$#CLSA CLOSE ALL? 00010301 BE CKOPER YES--> DONT TRY TO FIND THE FILE 00010401 * 00010501 FCLOOP DS 0H 00010601 CLC VS$#@FIL,FCDDNAME THIS ENTRY? 00010701 BE CKOPER YES--> GO CHECK AND PROCESS REQ 00010801 L R4,FCNEXT GET FOWARD POINTER 00010901 C R4,=F'-1' X'FF'S ? 00011001 BE INVFILE YES--> FILE NOT FOUND - INVALID 00011101 B FCLOOP GO BACK, JACK 00011201 * 00011301 CKOPER DS 0H 00011401 XR R1,R1 00011501 IC R1,TESTBYTE GET OPERATION 00011601 SLL R1,2 MULTIPLY BY 4 00011701 *=================>>>>>>> WARNING...WARNING... <<<<<<<=============== 00011801 *=================>>>>>>> WARNING...WARNING... <<<<<<<=============== 00011901 * IF ANY OTHER OPERATIONS ARE TO BE ADDED THIS TEST BETTER BE CHANGED 00012001 ********************************* 00012101 CLI TESTBYTE,VS$#ENRQ HIGHER THAN LAST OP? 00012201 ********************************* 00012301 BH INVOPER YES--> INVALID 00012401 B BRTAB(R1) GO DO OPERATION 00012501 BRTAB DS 0H 00012601 B INVOPER 0 IS INVALID 00012701 B FCOPEN 00012801 B FCCLOSE 00012901 B FCREAD 00013001 B FCWRITE 00013101 B FCDELET 00013201 B FCPOINT 00013301 B FCENDREQ 00013401 DC D'0' JUST IN CASE WE GO A LITTLE TOO FAR 00013501 EJECT 00013601 *********************************************************************** 00013701 * EVERYBODY COMES BACK HERE! * 00013801 *********************************************************************** 00013901 SPACE 00014001 RETURN DS 0H 00014101 * 00014201 LA R1,VS$#@E02 GET ECB MOMMA IS WAITING ON 00014301 POST (1) GIVE 'ER THAT BAD BOY 00014401 * 00014501 TM VS$#@E01,X'40' HAS IT BEEN POSTED? 00014601 BO RETNOWT YES--> DONT WAIT 00014701 LA R1,VS$#@E01 LETS WAIT TILL WERE NOTIFIED 00014801 WAIT ECB=(1) 00014901 RETNOWT DS 0H 00015001 XC VS$#@E01,VS$#@E01 CLEAR ECB 00015101 * 00015201 B FROMDTOP 00015301 DETACH DS 0H 00015401 * 00015501 MVI VS$#@IND,0 CLEAR ACTIVE INDICATOR 00015601 LA R1,VS$#@E02 GET ECB MOMMA IS WAITING ON 00015701 POST (1) GIVE 'ER THAT BAD BOY 00015801 SPACE 00015901 ESTAE 0 REMOVE OUR EXIT 00016001 * 00016101 LA R1,VS$#@E01 LETS WAIT TILL WERE DETACHED 00016201 WAIT ECB=(1) 00016301 * SHOULDN'T GET HERE, BUT IF.... 00016401 DC D'0' 00016501 * 00016801 EJECT 00016901 *********************************************************************** 00017001 * FILE OPEN ROUTINE * 00017101 *********************************************************************** 00017201 SPACE 00017301 FCOPEN DS 0H 00017401 SPACE 00017501 ICM R4,15,VS$#@CTL GET FIRST CTL BLOCK ADDR 00017601 BZ ADDITON NOT THERE--> ADD THE FIRST FILE 00017701 * 00017801 FCFINDIT DS 0H 00017901 CLC VS$#@FIL,FCDDNAME FOUND FILE? 00018001 BE DUPOPEN NOT ALLOWED, SIR 00018101 L R1,FCNEXT GET NEXT ENTRY 00018201 C R1,=F'-1' AT END? 00018301 BE ADDITON YES--> GO ADD FILE 00018401 LR R4,R1 NEXT ADDRESS IN R4 00018501 B FCFINDIT GO TRY TO FIND THE FILE 00018601 * 00018701 ADDITON BAL R14,ADDFILE GO ADD THE FILE ENTRY 00018801 * 00018901 CLC VS$#@FTY,=CL4'ESDS' ENTRY SEQUENCED? 00019306 BNE OPN4WRD NO--> GO FORWARD WITH THE OPEN! 00019406 SPACE 00019506 L R2,FCACBAD GET ACB ADDRESS 00019611 MODCB ACB=(2),MACRF=(ADR,SEQ,IN) 00019706 LTR R15,R15 CHECK FOR ERROR 00019808 BNZ VSERRMC IF SO --> GO 00019908 L R2,FCSRPLAD GET SEQ RPL ADDR 00020006 MODCB RPL=(2),OPTCD=(ADR,SEQ,NUP,MVE) 00020106 LTR R15,R15 CHECK FOR ERROR 00020208 BNZ VSERRMC IF SO --> GO 00020308 L R2,FCRRPLAD GET SEQ RPL ADDR 00020406 MODCB RPL=(2),OPTCD=(ADR,SEQ,NUP,MVE) 00020506 LTR R15,R15 CHECK FOR ERROR 00020608 BNZ VSERRMC IF SO --> GO 00020708 OPN4WRD DS 0H 00020806 SPACE 00020909 L R15,FCACBAD GET ADDR OF ACB 00021009 USING IFGACB,R15 00021109 SPACE 00021206 CLC VS$#@DBF,=H'0' ANY DATA BUFFERS REQ? 00021306 BE CKIBUF NO--> CHECK INDEX BUFFERS 00021406 MVC ACBBUFND,VS$#@DBF MOVE NUMBER OF BUFFERS IN 00021501 CKIBUF DS 0H 00021601 CLC VS$#@IBF,=H'0' ANY INDEX REQUESTED? 00021701 BE NOPERS NOPE 00021801 MVC ACBBUFNI,VS$#@IBF MOVE INDEX BUFFERS IN 00021901 NOPERS DS 0H 00022001 TM VS$#@FNC,VS$#ORDO OPEN FOR READ ONLY? 00022101 BO OPENIT YES-> OPENIT! 00022201 NI ACBMACR1,255-ACBIN TURN OFF READ FLAG 00022301 OI ACBMACR1,ACBOUT NO--> SET ACB FOR OUTPUT 00022401 TM VS$#@FNC,VS$#OLOD+VS$#ORSU OPEN FOR LOAD OR RESET/UPD 00022501 BZ OPENIT NO--> OPEN AS UPDATE 00022601 OI ACBMACR2,ACBRST SET TO RESET FILE TO EMPTY 00022701 MVI ACBSTRNO,X'01' STRINGS = 1 00022801 * 00022901 OPENIT DS 0H 00023001 LR R2,R15 PUT ACB ADDRESS IN R2 00023101 OPEN ((2)) OPEN IT 00023201 LTR R15,R15 CHECK FOR ERROR 00023301 BNZ VSERROC IF SO --> GO 00023401 * 00023501 FCOPENR DS 0H 00023601 * 00023701 L R7,FCACBAD GET ACB ADDRESS 00023801 LA R1,DBLWRD 00023901 * 00024001 SHOWCB AREA=(1), X00024101 FIELDS=(KEYLEN,LRECL,RKP), X00024201 LENGTH=12, X00024301 ACB=(7) 00024401 * 00024501 LTR R15,R15 DID WE GET THE KEYLENGTH? 00024601 BNZ VSERROC NO--> ERROR 00024701 MVC FCFKEYL,DBLWRD+3 SAVE FULL KEY LENGTH 00024801 MVC FCFKEYD,FULLWORD+2 SAVE KEY DISPLACEMENT 00024901 L R0,DBLWRD+4 GET RECORD LENGTH FROM SHOWCB 00025001 GETMAIN R,LV=(0) 00025101 ST R1,FCSAREA STORE AREA ADDRESS IN FC TABLE 00025201 L R0,DBLWRD+4 GET RECORD LENGTH FROM SHOWCB 00025301 GETMAIN R,LV=(0) 00025401 ST R1,FCRAREA STORE AREA ADDRESS IN FC TABLE 00025501 * 00025601 USING IFGRPL,R1 00025701 L R1,FCSRPLAD 00025801 L R0,DBLWRD+4 GET RECORD LENGTH FROM SHOWCB 00025901 ST R0,RPLRLEN GET RECORD LENGTH IN RPL 00026001 ST R0,RPLBUFL STORE LENGTH OF AREA 00026101 MVC RPLAREA,FCSAREA SET AREA ADDR IN RPL 00026201 L R1,FCRRPLAD GET RANDOM RPL ADDR 00026301 ST R0,RPLRLEN AND STORE LENGTH THERE, TOO 00026401 ST R0,RPLBUFL STORE LENGTH OF AREA 00026501 MVC RPLAREA,FCRAREA SET AREA ADDR IN RPL 00026601 * 00026701 TM VS$#@FNC,VS$#ORSU OPEN FOR RESET / UPDATE? 00026801 BO ORESUP YES--> DO DUMMY ROUTINE 00026901 STH R0,VS$#@RLN STORE LENGTH IN PARAMETER LIST 00027001 * 00027101 TM VS$#@FNC,VS$#OLOD OPENED FOR LOAD? 00027201 BO NOPOINT YES--> SKIP THE POINT 00027301 * 00027401 L R1,FCSRPLAD 00027501 XC FCKEY,FCKEY CLEAR KEY FIELD 00027601 POINT RPL=(1) 00027701 * POINT TO 1ST RECORD ON SEQ 00027801 * RPL. THIS IS DONE TO COMPENSATE 00027901 * FOR THE INCONSISTANCY WITH IBM 00028001 * DOCUMENTATION ON CONCURRENT 00028101 * PROCESSING USING STRINGS 00028201 DROP R15 00028301 DROP R1 00028401 NOPOINT DS 0H 00028501 BR R9 00028601 SPACE 00028701 ORESUP DS 0H 00028801 SPACE 00028901 CLC VS$#@RLN,=H'0' LENGTH SUPPLIED? 00029001 BNE SUPPLEN YES--> SKIP STORE 00029101 STH R0,VS$#@RLN SAVE LENGTH FROM OPEN 00029201 SUPPLEN DS 0H 00029301 L R1,FCSRPLAD SEQUENTIAL RPL ADDR IN 1 00029401 USING IFGRPL,R1 00029501 L R14,RPLAREA GET AREA ADDRESS 00029601 LH R15,VS$#@RLN YES--> PUT LENGTH IN R15 00029701 DROP R1 00029801 XR R1,R1 CLEAR THE AREA 00029901 LR R0,R1 00030001 MVCL R14,R0 00030101 * 00030201 BAL R9,FCWRITE GO EXECUTE WRITE ROUTINE FOR DUMMY 00030301 MVI VS$#@FNC,X'00' SET FUNCTION BYTE 0 INTERNAL SW 00030401 BAL R9,FCCLOSE DO CLOSE ROUTINE 00030501 OI VS$#@FNC,VS$#OPEN+VS$#OUPD 00030601 LA R9,RETURN 00030701 B FCOPEN 00030801 EJECT 00030901 *********************************************************************** 00031001 * FILE CLOSE ROUTINE * 00031101 *********************************************************************** 00031201 SPACE 00031301 FCCLOSE DS 0H 00031401 SPACE 00031501 TM VS$#@FNC,VS$#CLSA CLOSE ALL? 00031601 BZ FCLOSIT NO--> CONTINUE 00031701 * 00031801 L R4,VS$#@CTL GET BEGINNING CONTROL TABLE ADDR 00031901 * 00032001 FCLOSIT DS 0H 00032101 MVC VS$#@FIL,FCDDNAME MOVE DDNAME TO PARM LIST 00032201 L R1,FCRRPLAD GET RANDOM RPL ADDR 00032301 USING IFGRPL,R1 00032401 L R7,RPLBUFL GET RECORD LENGTH BEFORE WE CLOSE 00032501 DROP R1 00032601 L R2,FCACBAD ACB ADDR IN R2 00032701 CLOSE ((2)) CLOSE THE FILE 00032801 * 00032901 LTR R15,R15 CHECK FOR ERROR 00033001 BNZ VSERROC 00033101 * 00033201 FCCLOSR DS 0H RETURN ADDRESS ON CLOSE ERROR 00033301 * BECAUSE WE STILL WANT TO FREE 00033401 * ASSOCIATED AREAS 00033501 LR R0,R7 00033601 L R1,FCSAREA FREE SEQ I/O AREA ADRESS 00033701 FREEMAIN R,LV=(0),A=(1) 00033801 LR R0,R7 RESET LENGTH 00033901 L R1,FCRAREA FREE RANDOM I/O AREA ADRESS 00034001 FREEMAIN R,LV=(0),A=(1) 00034101 * 00034201 BAL R14,DELFILE GO DELETE FILE ENTRY FROM TABLE 00034301 * 00034401 ICM R1,15,VS$#@CTL IS CTL TABLE ADDR ZEROS? 00034501 BNZ CKCLOSA NO--> CHECK IF CLOSE ALL 00034601 CLI VS$#@FNC,X'00' INTERNAL FUNCTION? 00034701 BER R9 YES--> RETURN DO NOT DETACH 00034801 B DETACH ALL GONE--> DETACH 00034901 * AND FREE ASSOCIATED BLOCKS 00035001 CKCLOSA DS 0H 00035101 TM VS$#@FNC,VS$#CLSA CLOSE ALL? 00035201 BO FCLOSIT YES--> CONTINUE 00035301 BR R9 NO--> RETURN 00035401 * 00035501 EJECT 00035601 *********************************************************************** 00035701 * FILE READ ROUTINE * 00035801 *********************************************************************** 00035901 SPACE 00036001 FCREAD DS 0H 00036101 SPACE 00036201 USING IFGRPL,R1 00036301 * 00036401 L R1,FCSRPLAD GET SEQUENTIAL RPL ADDR 00036501 CLI VS$#@KYL,0 ANY KEY? 00036601 BE FCRPLOK NO--> USE SEQ RPL 00036701 L R1,FCRRPLAD YES--> USE RANDOM RPL 00036801 FCRPLOK DS 0H 00036901 TM VS$#@FNC,VS$#RUPD READ FOR UPDATE? 00037001 BZ FCREADO NO--> SET READ ONLY 00037101 OI RPLOPT2,RPLUPD TURN UPDATE FLAG ON 00037201 B CKKEYF 00037301 FCREADO DS 0H 00037401 NI RPLOPT2,255-RPLUPD ASSURE UPDATE FLAG OFF 00037501 DROP R1 00037601 CKKEYF DS 0H 00037701 ICM R1,15,VS$#@KEY ANY KEY? 00037801 BZ SEQREAD NOT PRESENT--> ASSUME SEQ ACCESS 00037901 XC FCKEY,FCKEY CLEAR KEY AREA 00038001 XR R7,R7 CLEAR R7 00038101 IC R7,VS$#@KYL INSERT KEY LENGTH 00038201 BCTR R7,0 DECREMENT FOR MOVE 00038301 EX R7,MOVEKEY MOVE THE KEY IN 00038401 * 00038501 L R1,FCRRPLAD RANDOM RPL ADDRESS IN R1 00038601 FCSVNGET DS 0H 00038701 ST R1,WHATRPL SAVE ADDRESS FOR LATER 00038801 * 00038901 GET RPL=(1) 00039001 * 00039101 LTR R15,R15 IF ERROR, INVESTIGATE 00039201 BNZ VSERREQ 00039301 * 00039401 CLC FCFKEYL,VS$#@KYL GENERIC READ? 00039501 BH MOVEREC YES--> GIVE EM WHAT WE GOT 00039601 XR R8,R8 00039701 ICM R8,B'0011',FCFKEYD GET KEY DISPLACEMENT 00039801 XR R7,R7 00039901 IC R7,FCFKEYL FULL KEY LENGTH IN R7 00040001 BCTR R7,0 DOWN BY 1 FOR EX COMPARE 00040101 L R1,FCRAREA GET RANDOM RECORD ADDRESS 00040201 AR R1,R8 BUMP TO KEY OFFSET 00040301 EX R7,KEYCLC COMPARE THE KEY 00040401 BE MOVEREC EQUAL--> OK 00040501 BAL R9,FCENDREQ RELEASE THE RECORD WE JUST READ 00040601 LA R9,RETURN RESET RETURN ADDRESS 00040701 B EOFNRF NOT EQUAL--> NOT FOUND 00040801 * 00040901 SEQREAD DS 0H 00041001 L R1,FCSRPLAD GET SEQ RPL ADDRESS 00041101 ST R1,WHATRPL SAVE ADDRESS FOR LATER 00041201 * 00041301 GET RPL=(1) 00041401 * 00041501 LTR R15,R15 ERROR? 00041601 BNZ VSERREQ YES--> CHECK IT OUT 00041701 * 00041801 MOVEREC DS 0H 00041901 L R1,WHATRPL GET RPL ADDRES WE JUST ACCESSED 00042001 USING IFGRPL,R1 00042101 * 00042201 L R14,RPLAREA GET FROM ADDRESS(EITHER FCRAREA/FCSAREA) 00042301 L R15,RPLRLEN AND LENGTH OF RECORD READ 00042401 STH R15,VS$#@RLN STORE LENGTH IN PARAMETER LIST 00042501 ICM R0,15,VS$#@ARE DID THEY SUPPLY A RECORD ADDRESS? 00042601 BZ NOMOVE NO--> SUPPLY ONLY OUR ADDRESS 00042701 DROP R1 00042801 LR R1,R15 PUT LENGTH IN R1 ALSO 00042901 MVCL R0,R14 MOVE RECORD TO USER AREA 00043001 * 00043101 BR R9 00043201 * 00043301 NOMOVE DS 0H 00043401 ST R14,VS$#@ARE STORE IN PARAMETER LIST 00043501 BR R9 AND EXIT 00043601 * 00043701 MOVEKEY MVC FCKEY(0),0(R1) EXECUTED MOVE 00043801 KEYCLC CLC FCKEY(0),0(R1) EXECUTED COMPARE 00043901 EJECT 00044001 *********************************************************************** 00044101 * FILE WRITE ROUTINE * 00044201 *********************************************************************** 00044301 SPACE 00044401 FCWRITE DS 0H 00044501 SPACE 00044601 ICM R1,15,VS$#@KEY GET ADDRESS OF KEY 00044701 BZ SEQWRITE NOT PRESENT--> ASSUME SEQ WRITE 00044801 * 00044901 L R1,FCRRPLAD RANDOM RPL ADDRESS IN R1 00045001 LR R7,R1 PUT ADDRESS IN R7 00045101 B CKMOVEIT 00045201 * 00045301 SEQWRITE DS 0H 00045401 L R1,FCSRPLAD GET SEQ RPL ADDRESS 00045501 LR R7,R1 PUT ADDR IN R7 00045601 * 00045701 CKMOVEIT DS 0H 00045801 USING IFGRPL,R1 00045901 L R14,RPLAREA GET TO ADDRESS(EITHER FCRAREA/FCSAREA) 00046001 L R15,RPLBUFL SET MAX LENGTH AS DEFAULT 00046101 CLI RPLREQ,RPLGET WAS LAST REQUEST A GET? 00046201 BE FCCKUPD YES--> GO CHECK IF UPDATE 00046301 NI RPLOPT2,255-RPLUPD NO--> TURN OFF UPDATE FLAG IF ON 00046401 B FCCKRLEN AND USE MAX FOR DEFAULT 00046501 FCCKUPD DS 0H CHECK IF UPDATE 00046601 TM RPLOPT2,RPLUPD FOR UPDATE? 00046701 BZ FCCKRLEN NO---> USE MAX LENGTH AS DEFAULT 00046801 L R15,RPLRLEN PREVIOUS REQUEST WAS READ/UPDATE 00046901 * SO DEFAULT IS LENGTH OF RECORD READ 00047001 FCCKRLEN DS 0H 00047101 CLC VS$#@RLN,=H'0' DID THEY SUPPLY A LENGTH? 00047201 BE NOPE NO--> USE RPL LENGTH 00047301 LH R15,VS$#@RLN YES--> PUT LENGTH IN R15 00047401 NOPE DS 0H 00047501 ST R15,RPLRLEN STORE NEW/OLD LENGTH IN RPL 00047601 * 00047701 TM VS$#@FNC,VS$#OPEN 00047801 BO PUTIT DON'T CHECK AREA ON OPEN RESET/UPD 00047901 * 00048001 ICM R0,15,VS$#@ARE DID THEY SUPPLY A RECORD ADDRESS? 00048101 BZ PUTIT NO--> THEY UPDATED IN OUR AREA 00048201 DROP R1 00048301 LR R1,R15 PUT LENGTH IN R1 ALSO 00048401 MVCL R14,R0 MOVE USER AREA TO OURS 00048501 * 00048601 PUTIT DS 0H 00048701 PUT RPL=(7) 00048801 * 00048901 LTR R15,R15 IF ERROR, INVESTIGATE 00049001 BNZ VSERREQ 00049101 * 00049201 BR R9 00049301 * 00049401 EJECT 00049501 *********************************************************************** 00049601 * FILE DELETE ROUTINE * 00049701 *********************************************************************** 00049801 SPACE 00049901 FCDELET DS 0H 00050001 SPACE 00050101 ICM R1,15,VS$#@KEY GET ADDRESS OF KEY 00050201 BNZ RANDELET PRESENT--> DO RANDOM DELETE 00050301 * 00050401 L R1,FCSRPLAD GET SEQ RPL ADDRESS 00050501 B BYEBYE NO AUTOREAD ON SEQ DELETE 00050601 * 00050701 RANDELET DS 0H 00050801 CLC FCFKEYL,VS$#@KYL IS IT A FULL KEY DELETE? 00050901 BNE DELERR NO--> ERROR 00051001 * 00051101 XC FCKEY,FCKEY CLEAR KEY AREA 00051201 XR R7,R7 CLEAR R7 00051301 IC R7,VS$#@KYL INSERT KEY LENGTH 00051401 BCTR R7,0 DECREMENT FOR MOVE 00051501 EX R7,MOVEKEY MOVE THE KEY IN 00051601 * 00051701 L R1,FCRRPLAD RANDOM RPL ADDRESS IN R1 00051801 USING IFGRPL,R1 00051901 * 00052001 CLI RPLREQ,RPLGET WAS LAST REQUEST A GET? 00052101 BNE GETU NO--> GET RECORD 00052201 TM RPLOPT2,RPLUPD YES--> FOR UPDATE? 00052301 BO BYEBYE YES--> GO DO DELETE 00052401 * 00052501 GETU DS 0H 00052601 OI RPLOPT2,RPLUPD TURN UPDATE FLAG ON 00052701 * NI RPLOPT2,255-RPLNSP TURN OFF NOTE STRING POS 00052801 DROP R1 00052901 * 00053001 GET RPL=(1) GET THE RECORD FOR UPDATE 00053101 * 00053201 LTR R15,R15 IF ERROR, INVESTIGATE 00053301 BNZ VSERREQ 00053401 * 00053501 L R1,FCRRPLAD RESTORE RPL ADDRESS 00053601 * 00053701 BYEBYE DS 0H 00053801 ERASE RPL=(1) 00053901 * 00054001 LTR R15,R15 IF ERROR, INVESTIGATE 00054101 BNZ VSERREQ 00054201 * 00054301 BR R9 00054401 * 00054501 EJECT 00054601 *********************************************************************** 00054701 * FILE POINT ROUTINE * 00054801 * SEQUENTIAL RPL ASSUMED * 00054901 *********************************************************************** 00055001 SPACE 00055101 FCPOINT DS 0H 00055201 SPACE 00055301 ICM R1,15,VS$#@KEY GET ADDRESS OF KEY 00055401 BZ INVKEY NOT PRESENT--> ERROR...ERROR...ERROR 00055501 * 00055601 XC FCKEY,FCKEY CLEAR KEY AREA 00055701 XR R7,R7 CLEAR R7 00055801 IC R7,VS$#@KYL INSERT KEY LENGTH 00055901 BCTR R7,0 DECREMENT FOR MOVE 00056001 EX R7,MOVEKEY MOVE THE KEY IN 00056101 * 00056201 L R1,FCSRPLAD SEQ RPL ADDRESS IN R1 00056301 * 00056401 POINTIT DS 0H 00056501 POINT RPL=(1) 00056601 * 00056701 LTR R15,R15 IF ERROR, INVESTIGATE 00056801 BNZ VSERREQ 00056901 * 00057001 CLC FCFKEYL,VS$#@KYL GENERIC POINT? 00057101 BHR R9 YES--> GIVE EM WHAT WE GOT 00057201 XR R7,R7 00057301 IC R7,FCFKEYL FULL KEY LENGTH IN R7 00057401 BCTR R7,0 DOWN BY 1 FOR EX COMPARE 00057501 XR R8,R8 00057601 ICM R8,B'0011',FCFKEYD GET KEY DISPLACEMENT 00057701 L R1,FCSAREA GET SEQ RECORD ADDRESS 00057801 AR R1,R8 BUMP TO KEY 00057901 EX R7,KEYCLC COMPARE THE KEY 00058001 BER R9 EQUAL--> OK 00058101 BAL R9,FCENDREQ RELEASE THE VSAM STRING/POINTER 00058201 LA R9,RETURN RESET RETURN ADDRESS 00058301 B EOFNRF NOT EQUAL--> NOT FOUND 00058401 * 00058501 EJECT 00058601 *********************************************************************** 00058701 * FILE ENDREQ ROUTINE * 00058801 *********************************************************************** 00058901 SPACE 00059001 FCENDREQ DS 0H 00059101 SPACE 00059201 L R1,FCSRPLAD GET SEQ RPL ADDRESS 00059301 ICM R0,15,VS$#@KEY GET ADDRESS OF KEY 00059401 BZ ERQIT NOT PRESENT--> USE SEQ RPL 00059501 * 00059601 L R1,FCRRPLAD GET RANDOM RPL ADDR 00059701 * 00059801 ERQIT DS 0H 00059901 ENDREQ RPL=(1) 00060001 * 00060101 LTR R15,R15 IF ERROR, INVESTIGATE 00060201 BNZ VSERREQ 00060301 * 00060401 BR R9 00060501 * 00060601 EJECT 00060701 *********************************************************************** 00060801 * ADD FILE TO CONTROL TABLE * 00060901 *********************************************************************** 00061001 * THIS ROUTINE ASSUMES THAT R4 CONTAINS EITHER: * 00061101 * THE LAST FILE ENTRY IN THE FILE CONTROL TABLE * 00061201 * *** OR *** * 00061301 * ZEROS * 00061401 * THIS ROUTINE WILL ACQUIRE THE STORAGE REQUIRED FOR A NEW * 00061501 * FILE CONTROL TABLE ENTRY, ADJUST FC CHAIN, GETMAIN STORAGE * 00061601 * FOR THE ACB/RPL'S BLOCK, AND SETS THE FOLLOWING ADDRESSES * 00061701 * IN THE RPL'S: * 00061801 * RPLDACB - ACB ADDRESS * 00061901 * RPLARG - ADDRESS OF SEARCH KEY (FCKEY) * 00062001 * * 00062101 * UPON RETURN, R4 WILL CONTAIN THE ADDRESS OF THE NEW ENTRY * 00062201 * CREATED. * 00062301 * * 00062401 *********************************************************************** 00062501 SPACE 00062601 ADDFILE DS 0H 00062701 SPACE 00062801 ST R14,SAVER14 00062901 * 00063001 LA R0,FCELEN GET THE AREA 00063101 * 00063201 GETMAIN R,LV=(0) 00063301 * 00063401 LTR R4,R4 DO WE HAVE A TABLE YET? 00063501 BNZ TACKITON YES--> TACK THIS GUY ON THE END 00063601 * 00063701 ST R1,VS$#@CTL NO--> SAVE BEGINNING ADDRESS 00063801 LR R4,R1 SET FC DSECT REG 00063901 MVC FCPREV,=F'-1' SET BACKWARD CHAIN = X"FF"S 00064001 B BLDFILE GO BUILD ENTRY/RPL'S/ACB 00064101 * 00064201 TACKITON DS 0H 00064301 * 00064401 ST R1,FCNEXT SET FOWARD CHAIN TO NEW AREA 00064501 LR R2,R4 SAVE PREV ADDR 00064601 LR R4,R1 SET FC DSECT REG TO NEW ENTRY 00064701 ST R2,FCPREV SET BACKWARD CHAIN 00064801 BLDFILE DS 0H 00064901 MVC FCNEXT,=F'-1' SET FOWARD PTR = EOC 00065001 MVC FCDDNAME,VS$#@FIL SET DDNAME 00065101 SPACE 00065201 LA R0,VSCBLEN GET LENGTH OF ACB/RPL BLOCK 00065301 GETMAIN R,LV=(0) 00065401 SPACE 00065501 MVC 0(VSCBLEN,R1),VSACB MOVE DUMMY CONTROL BLOCKS IN 00065601 ST R1,FCACBAD STORE ACB ADDRESS 00065701 LA R15,VSSRPLOF(,R1) SET R15 AT SEQ RPL ADDR 00065801 ST R15,FCSRPLAD STORE IT IN SEQ RPL ADDR 00065901 LA R15,VSRRPLOF(,R1) SET R15 AT RANDOM RPL ADDR 00066001 ST R15,FCRRPLAD STORE IT IN RANDOM RPL ADDR 00066101 SPACE 00066201 L R15,FCSRPLAD NOW SET RPL PTRS TO APPROPRIATE 00066301 USING IFGRPL,R15 ADDRESS 00066401 SPACE 00066501 MVC RPLDACB,FCACBAD SET ACB ADDRESS IN RPL 00066601 LA R1,FCKEY ADDR OF KEY IN R1 00066701 ST R1,RPLARG STORE KEY ADDR IN RPL 00066801 SPACE 00066901 L R15,FCRRPLAD DO RANDOM RPL ALSO 00067001 SPACE 00067101 MVC RPLDACB,FCACBAD SET ACB ADDRESS IN RPL 00067201 LA R1,FCKEY ADDR OF KEY IN R1 00067301 ST R1,RPLARG STORE KEY ADDR IN RPL 00067401 DROP R15 00067501 L R1,FCACBAD GET ACBADDR 00067601 USING IFGACB,R1 00067701 MVC ACBDDNM,VS$#@FIL SET FILENAME IN ACB 00067801 DROP R1 00067901 L R14,SAVER14 00068001 BR R14 00068101 * 00068201 EJECT 00068301 *********************************************************************** 00068401 * DELETE FILE FROM CONTROL TABLE * 00068501 *********************************************************************** 00068601 * THIS ROUTINE ASSUMES THAT R4 CONTAINS THE CURRENT FILE * 00068701 * ENTRY TO BE DELETED. * 00068801 * THIS ROUTINE WILL RELEASE ALL STORAGE ACQUIRED FOR A CLOSED * 00068901 * FILE CONTROL TABLE ENTRY, AND ADJUST THE FC CHAIN APPROPRIATELY. * 00069001 * * 00069101 *********************************************************************** 00069201 SPACE 00069301 DELFILE DS 0H 00069401 SPACE 00069501 ST R14,SAVER14 00069601 * 00069701 L R1,FCACBAD GET ADDRESS OF ACB 00069801 LA R0,VSCBLEN GET LENGTH OF ACB/RPL BLOCK 00069901 FREEMAIN R,LV=(0),A=(1) 00070001 SPACE 00070101 * 00070201 L R0,FCPREV R0= PREV ENTRY ADDR 00070301 L R1,FCNEXT R1= NEXT ENTRY ADDR 00070401 LR R7,R4 AND REMEMBER WHO GETS DELETED 00070501 * 00070601 C R0,=F'-1' 1ST ENTRY? 00070701 BE CKNEXTE YES--> SEE IF NEXT ENTRY 00070801 LR R4,R0 NO--> SET R4 TO PREV ENTRY 00070901 ST R1,FCNEXT PUT FOWARD POINTER IN PREV ENTRY 00071001 * 00071101 C R1,=F'-1' WAS THIS THE LAST GUY? 00071201 BE FREEIT YES--> WERE DONE! FREEMAIN IT 00071301 LR R4,R1 NO--> SET R4 TO NEXT ENTRY 00071401 ST R0,FCPREV PUT BACKWARD PTR IN NEXT ENTRY 00071501 B FREEIT AND GO FREE THE AREA 00071601 * 00071701 CKNEXTE DS 0H ONLY IF WERE FREEING THE FIRST ENTRY 00071801 XC VS$#@CTL,VS$#@CTL CLEAR THE CONTROL TAB ADDR 00071901 * WERE GOING TO BE CHANGING IT ANYWAY 00072001 C R1,=F'-1' FIRST AND ONLY? 00072101 BE FREEIT YES--> DONE! 00072201 LR R4,R1 NO--> SET R4 TO NEXT ENTRY 00072301 MVC FCPREV,=F'-1' INDICATE FIRST IN CHAIN 00072401 ST R4,VS$#@CTL SAVE NEW CTL TAB START 00072501 * AND FREE THE ENTRY 00072601 FREEIT DS 0H 00072701 LA R0,FCELEN GET THE ENTRY LENGTH 00072801 LR R1,R7 GET ADDRESS OF ENTRY AREA 00072901 * 00073001 FREEMAIN R,LV=(0),A=(1) 00073101 * 00073201 L R14,SAVER14 00073301 BR R14 00073401 * 00073501 EJECT 00073601 *********************************************************************** 00073701 * VSAM OPEN/CLOSE ERROR ROUTINES * 00073801 *********************************************************************** 00073901 INVKEY DS 0H 00074001 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00074101 MVC VSMBLD1+46(7),=CL7'POINT' 00074201 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00074301 WTO MF=(E,VSMBLD1) 00074401 WTO MF=(E,VSMINVK) 00074501 MVC VS$#@RCD,=X'FF0004' 00074601 BR R9 00074701 SPACE 00074801 DELERR DS 0H 00074901 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00075001 MVC VSMBLD1+46(7),=CL7'DELETE' 00075101 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00075201 WTO MF=(E,VSMBLD1) 00075301 WTO MF=(E,VSMDELK) 00075401 MVC VS$#@RCD,=X'FF0004' 00075501 BR R9 00075601 SPACE 00075701 INVOPER DS 0H 00075801 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00075901 MVC VSMBLD1+46(7),=CL7'UNKNOWN' 00076001 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00076101 WTO MF=(E,VSMBLD1) 00076201 WTO MF=(E,VSMINVO) 00076301 MVC VS$#@RCD,=X'FF0004' 00076401 BR R9 00076501 SPACE 00076601 INVFILE DS 0H 00076701 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00076801 MVC VSMBLD1+46(7),=CL7'--N/A--' 00076901 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00077001 WTO MF=(E,VSMBLD1) 00077101 WTO MF=(E,VSMNOTO) 00077201 MVC VS$#@RCD,=X'080004' 00077301 BR R9 00077401 SPACE 00077501 DUPOPEN DS 0H 00077601 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00077701 MVC VSMBLD1+46(7),=CL7'OPEN' 00077801 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00077901 WTO MF=(E,VSMBLD1) 00078001 WTO MF=(E,VSMDUPO) 00078101 MVC VS$#@RCD,=X'080004' 00078201 BR R9 00078301 SPACE 00078401 VSERROC DS 0H 00078508 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00078601 MVC VSMBLD2(VSMSG2L),VSMSG2 00078701 * 00078801 L R1,FCACBAD GET ACB ADDRESS 00078901 USING IFGACB,R1 00079001 * 00079101 MVC VSMBLD1+46(7),=CL7'OPEN' 00079201 CLI TESTBYTE,VS$#OPEN OPEN REQUEST? 00079301 BE CHKERR YES--> GO CHECK ERROR TYPE 00079401 MVC VSMBLD1+46(7),=CL7'CLOSE' OTHERWISE SET AS CLOSE 00079501 * 00079601 CHKERR DS 0H 00079701 STC R15,VS$#@RCD STORE R15 VALUE IN PLIST 00079801 MVC VS$#@RCD+L'VS$#@RCD-1(1),ACBERFLG 00079901 B DOMSGS GO WRITE MESSAGES TO LOG 00080001 DROP R1 00080101 SPACE 00080208 VSERRMC DS 0H 00080308 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00080408 MVC VSMBLD2(VSMSG2L),VSMSG2 00080508 * 00080608 L R1,FCACBAD GET ACB ADDRESS 00080708 USING IFGACB,R1 00080808 * 00080908 MVC VSMBLD1+46(7),=CL7'MODCB' 00081008 STC R15,VS$#@RCD STORE R15 VALUE IN PLIST 00081308 MVC VS$#@RCD+L'VS$#@RCD-1(1),ACBERFLG 00081408 B DOMSGS GO WRITE MESSAGES TO LOG 00081508 DROP R1 00081608 EJECT 00081701 *********************************************************************** 00081801 * VSAM I/O REQUEST ERROR ROUTINE * 00081901 *********************************************************************** 00082001 SPACE 00082101 VSERREQ DS 0H 00082201 MVC VSMBLD1(VSMSG1L),VSMSG1 MESSAGE BUILD AREAS 00082301 MVC VSMBLD2(VSMSG2L),VSMSG2 00082401 * 00082501 USING IFGRPL,R1 00082601 STC R15,VS$#@RCD STORE R15 VALUE 00082701 MVC VS$#@RCD+L'VS$#@RCD-1(1),RPLERRCD ERROR CODE 00082801 * 00082901 MVC VSMBLD1+46(7),=CL7'GET' SET OPERATION TYPE 00083001 CLI RPLREQ,RPLGET GET REQUEST? 00083101 BE DOMSGS YES--> GOTIT 00083201 MVC VSMBLD1+46(7),=CL7'PUT' SET OPERATION TYPE 00083301 CLI RPLREQ,RPLPUT PUT REQUEST? 00083401 BE DOMSGS YES--> GOTIT 00083501 MVC VSMBLD1+46(7),=CL7'POINT' SET OPERATION TYPE 00083601 CLI RPLREQ,RPLPOINT POINT REQUEST? 00083701 BE DOMSGS YES--> GOTIT 00083801 MVC VSMBLD1+46(7),=CL7'ERASE' SET OPERATION TYPE 00083901 CLI RPLREQ,RPLERASE ERASE REQUEST? 00084001 BE DOMSGS YES--> GOTIT 00084101 MVC VSMBLD1+46(7),=CL7'ENDREQ' SET OPERATION TYPE 00084201 CLI RPLREQ,RPLENDRE ERASE REQUEST? 00084301 BE DOMSGS YES--> GOTIT 00084401 MVC VSMBLD1+46(7),=CL7'UNKNOWN' SET OPERATION TYPE 00084501 * 00084601 DOMSGS DS 0H 00084701 MVC VSMBLD1+13(8),VS$#@FIL GET FILENAME 00084801 MVI VSMBLD2+19,0 MAKE R15 VALUE DISPLAYABLE HEX 00084901 MVZ VSMBLD2+19(1),VS$#@RCD 00085001 MVI VSMBLD2+20,0 00085101 MVN VSMBLD2+20(1),VS$#@RCD 00085201 TR VSMBLD2+19(2),=C'0123456789ABCDEF' 00085301 * 00085401 SR R7,R7 00085501 ICM R7,3,VS$#@RCD+1 GET VSAM ERROR CODE 00085601 CVD R7,DBLWRD 00085701 OI DBLWRD+L'DBLWRD-1,X'0F' 00085801 UNPK VSMBLD2+37(4),DBLWRD+L'DBLWRD-3(3) 00085901 SPACE 00086001 CLI VS$#@RCD+L'VS$#@RCD-1,X'04' EOF? 00086101 BE EOFNRF 00086201 CLI VS$#@RCD+L'VS$#@RCD-1,X'10' NRF? 00086301 BE EOFNRF 00086401 CLI VS$#@RCD+L'VS$#@RCD-1,X'08' DUP RECORD? 00086501 BER R9 YES--> NO MESSAGE PLEASE 00086601 WRITMSG DS 0H 00086701 WTO MF=(E,VSMBLD1) 00086801 WTO MF=(E,VSMBLD2) 00086901 * 00087001 CLI TESTBYTE,VS$#CLOS CLOSE REQUEST? 00087101 BE FCCLOSR YES--> FREE AREAS 00087201 CLI TESTBYTE,VS$#OPEN OPEN REQUEST? 00087301 BNER R9 NO--> EXIT 00087401 CLI VS$#@RCD,X'04' WARNING? 00087501 BE FCOPENR YES--> CONTINUE WITH OPEN PROCESSING 00087601 BR R9 NO--> EXIT 00087701 EOFNRF DS 0H 00087801 MVC VS$#@RCD,=X'040004' INDICATE EOFNRF 00087901 NI RPLOPT2,255-RPLUPD RESET RPL UPDATE FLAG 00088001 AIF (NOT &TEST).NOTEST2 00088101 WTO MF=(E,TREOFMSG) 00088201 .NOTEST2 ANOP , 00088301 BR R9 00088401 DROP R1 00088501 EJECT 00088601 AIF (NOT &TEST).NOTEST3 00088701 FCTRACE DS 0H 00088801 ST R14,TRSAV14 00088901 * 00089001 MVC TRMBLD1(TRMSG1L),TRMSG1 MESSAGE BUILD AREAS 00089101 MVC TRMBLD2(TRMSG2L),TRMSG2 MESSAGE BUILD AREAS 00089201 * 00089301 CLI TESTBYTE,TROPENT 00089401 BH FCUNKN BAD CODE 00089501 XR R7,R7 00089601 IC R7,TESTBYTE GET LOW HALF OF OPER 00089701 MH R7,=AL2(L'TROPTAB) 00089801 A R7,=A(TROPTAB) 00089901 * 00090001 MVC TRMBLD1+46(7),0(R7) SET OPERATION TYPE 00090101 * 00090201 CLI TESTBYTE,VS$#READ READ REQ? 00090301 BH TRMSGS HIGH--> NO SUBFLAGS 00090401 BE TRREAD EQ--> CHECK SUBFLAG 00090501 * 00090601 CLI TESTBYTE,VS$#OPEN OPEN REQ? 00090701 BNE MUSBCLOS NO--> MUST BE CLOSED 00090801 * 00090901 MVI TRMBLD1+50,C'U' OPEN UPDATE 00091001 TM VS$#@FNC,VS$#OUPD IS IT? 00091101 BO TRMSGS 00091201 * 00091301 MVI TRMBLD1+50,C'L' OPEN LOAD 00091401 TM VS$#@FNC,VS$#OLOD IS IT? 00091501 BO TRMSGS 00091601 * 00091701 MVI TRMBLD1+50,C' ' OPEN READ ONLY 00091801 TM VS$#@FNC,VS$#ORDO IS IT? 00091901 BO TRMSGS 00092001 * 00092101 MVC TRMBLD1+50(2),=C'RU' RESET/UPD 00092201 B TRMSGS 00092301 TRREAD DS 0H 00092401 MVI TRMBLD1+50,C'U' READ UPDATE 00092501 TM VS$#@FNC,VS$#RUPD IS IT? 00092601 BO TRMSGS 00092701 MVI TRMBLD1+50,C'O' READ ONLY 00092801 B TRMSGS 00092901 MUSBCLOS DS 0H 00093001 TM VS$#@FNC,VS$#CLSA 00093101 BZ TRMSGS 00093201 MVC TRMBLD1+51(2),=C'AL' 00093301 B TRMSGS 00093401 FCUNKN MVC TRMBLD1+46(7),=CL7'UNKNOWN' SET OPERATION TYPE 00093501 TRMSGS DS 0H 00093601 MVC TRMBLD1+13(8),VS$#@FIL GET FILENAME 00093701 * 00093801 CLI VS$#@KYL,0 ANY KEY? 00093901 BNE TRKEY 00094001 MVC TRMBLD2+17(131),=CL131'NONE' 00094101 B TRWTOIT 00094201 TRKEY DS 0H 00094301 XC DECKEY,DECKEY CLEAR KEY AREA 00094401 L R7,VS$#@KEY GET ADDRESS OF KEY 00094501 XR R14,R14 CLEAR R14 00094601 IC R14,VS$#@KYL GET KEY LENGTH 00094701 LA R8,DECKEY GET TRANSLATED AREA 00094801 LA R2,DECKEY+L'DECKEY END OF AREA 00094901 LOOPIT DS 0H 00095001 XR R15,R15 00095101 IC R15,0(R7) 00095201 MVN 1(1,R8),0(R7) 00095301 SRL R15,4 00095401 STC R15,0(R8) 00095501 LA R8,2(,R8) 00095601 LA R7,1(R7) 00095701 CR R8,R2 00095801 BNL TRDONE 00095901 BCT R14,LOOPIT 00096001 TRDONE DS 0H 00096101 TR DECKEY,=C'0123456789ABCDEF' 00096201 LA R7,DECKEY+L'DECKEY R7 TO END OF KEY 00096301 CR R7,R8 00096401 BNH TRMVKEY 00096501 SR R7,R8 SUBTRACT R8 FROM R7 = LENGTH REMAINING 00096601 BCTR R7,0 DECREMENT BY 1 00096701 EX R7,FILLKEY 00096801 TRMVKEY DS 0H 00096901 MVC TRMBLD2+19(128),DECKEY 00097001 TRWTOIT DS 0H 00097101 WTO MF=(E,TRMBLD1) 00097201 WTO MF=(E,TRMBLD2) 00097301 L R14,TRSAV14 00097401 BR R14 00097501 * 00097601 FILLKEY MVC 0(1,R8),=CL128'"' 00097701 EJECT 00097801 TRMSG1 WTO 'VSAMIO - DDDDDDDD ACCESS TRACE, REQUEST = ZZZZZZZ', X00097901 ROUTCDE=(8,11),MF=L 00098001 TRMSG1L EQU *-TRMSG1 00098101 TRMSG2 WTO 'VSAMIO - KEY=X"NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNX00098201 NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNX00098301 NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNN"',ROUTCDE=(8,11),MF=L 00098401 TRMSG2L EQU *-TRMSG2 00098501 TREOFMSG WTO 'VSAMIO - EOF/NRF ENCOUNTERED', X00098601 ROUTCDE=(8,11),MF=L 00098701 * 00098801 TROPTAB DC CL7'UNKNOWN' TRACE OPERATION TABLE 00098901 DC CL7'OPEN' 00099001 DC CL7'CLOSE' 00099101 DC CL7'READ' 00099201 DC CL7'WRITE' 00099301 DC CL7'DELETE' 00099401 DC CL7'POINT' 00099501 DC CL7'ENDREQ' 00099601 TROPENT EQU (*-TROPTAB)/L'TROPTAB LET ASSEMBLER CALC #ENTRIES 00099701 .NOTEST3 ANOP , 00099801 EJECT 00099901 ********************************************************************** 00100001 * * 00100101 ********************************************************************** 00100201 * 00100301 SHELSHOK DS 0H 00100401 * 00100501 USING SHELSHOK,R15 00100601 * 00100701 C R0,=F'12' ANY SDWA? 00100801 BNE SDWAOK YES-> GET PARAM FROM SDWA 00100901 * 00101001 LR R5,R2 PARMS ARE IN R2 IF NO SDWA 00101101 * 00101201 * 00101301 MVI VS$#@IND,0 CLEAR ACTIVE INDICATOR 00101401 MVC VS$#@RCD,=3X'FF' MAJOR BAD ERROR CODE 00101501 LA R1,VS$#@E02 GET ECB 00101601 POST (1) POST IT 00101701 SPACE 00101801 * 00101901 XR R15,R15 CLEAR 15 = CONTINUE TERMINATION 00102001 BR R14 RETURN TO CP 00102101 * 00102201 DROP R15 00102301 SDWAOK DS 0H 00102401 STM R14,R12,12(R13) 00102501 LR R3,R15 3'S THE BASE 00102601 USING SHELSHOK,R3 RESET USING STATUS 00102701 * 00102801 GETMAIN R,LV=72,SP=0 00102901 ST R13,4(R1) SET CHAIN 00103001 ST R1,8(R13) " " 00103101 LR R13,R1 GET SAVE AREA ADDR IN R13 00103201 * 00103301 L R1,4(R13) GET CALLER SAVE AREA ADDR 00103401 L R1,24(R1) RESTORE R1 CONTENTS FROM THEIR SAVE 00103501 USING SDWA,R1 00103601 L R5,0(R1) AND ADDRESS OF PARM LIST ADDR 00103701 * 00103801 SETRP WKAREA=(1),DUMP=YES,RC=0 00103901 * 00104001 MVI VS$#@IND,0 CLEAR ACTIVE INDICATOR 00104101 MVC VS$#@RCD,=3X'FF' MAJOR BAD ERROR CODE 00104201 LA R1,VS$#@E02 GET ECB 00104301 POST (1) POST IT 00104401 SPACE 00104501 L R13,4(R13) RESTORE CALLER SAVE AREA 00104601 LM R14,R12,12(R13) THEN THE REGISTERS 00104701 XR R15,R15 CLEAR R15 00104801 BR R14 EXIT 00104901 * 00105001 DROP R1 00105101 DROP R3 00105201 EJECT 00105301 LTORG 00105401 EJECT 00105501 ********************************************************************** 00105601 * DUMMY ACB AND RPL'S * 00105701 ********************************************************************** 00105801 SPACE 00105901 VSACB ACB AM=VSAM, X00106001 BUFND=4, X00106101 BUFNI=6, X00106201 MACRF=(KEY,SEQ,IN), X00106301 STRNO=2 00106401 SPACE 00106501 VSSRPL RPL ACB=VSACB, X00106601 OPTCD=(KEY,SEQ,NUP,KGE,MVE) 00106705 SPACE 00106801 VSRRPL RPL ACB=VSACB, X00106901 OPTCD=(KEY,DIR,NUP,KGE,MVE) 00107001 SPACE 00107101 VSCBLEN EQU *-VSACB LENGTH OF VSAM CONTROL BLOCK AREAS 00107201 VSSRPLOF EQU VSSRPL-VSACB OFFSET OF SEQ RPL FROM TOP 00107301 VSRRPLOF EQU VSRRPL-VSACB OFFSET OF RANDOM RPL FROM TOP 00107401 SPACE 00107505 EJECT 00107601 VSMINVK WTO 'VSAMIO - NO KEY SUPPLIED', X00107701 ROUTCDE=(8,11),MF=L 00107801 VSMDELK WTO 'VSAMIO - GENERIC KEY NOT ALLOWED FOR DELETE REQUEST', X00107901 ROUTCDE=(8,11),MF=L 00108001 VSMINVO WTO 'VSAMIO - INVALID OPERATION SUPPLIED/PARM LIST INVALID'X00108101 ,ROUTCDE=(8,11),MF=L 00108201 VSMNOTO WTO 'VSAMIO - FILE HAS NOT BEEN OPENED', X00108301 ROUTCDE=(8,11),MF=L 00108401 VSMDUPO WTO 'VSAMIO - FILE PREVIOUSLY OPENED', X00108501 ROUTCDE=(8,11),MF=L 00108601 VSMSG1 WTO 'VSAMIO - DDDDDDDD ACCESS ERROR, REQUEST = ZZZZZZZ', X00108701 ROUTCDE=(8,11),MF=L 00108801 VSMSG1L EQU *-VSMSG1 00108901 VSMSG2 WTO 'VSAMIO - R15 = XX, RETURN CODE = NNNN DECIMAL', X00109001 ROUTCDE=(8,11),MF=L 00109101 VSMSG2L EQU *-VSMSG2 00109201 EJECT 00109301 WORKADS DSECT , 00109401 DBLWRD DS D 00109501 FULLWORD DS D 00109601 VS$#@CTL DS F CONTROL TABLE BEGIN ADDRESS 00109701 SAVER14 DS F 00109801 FWORD DS F 00109901 WHATRPL DS F SAVE ADDRESS OF RPL ACCESSED 00110001 TESTBYTE DS XL1 00110101 VSMBLD1 DS CL(VSMSG1L) 00110201 VSMBLD2 DS CL(VSMSG2L) 00110301 AIF (NOT &TEST).NOTEST4 00110401 TRMBLD1 DS CL(TRMSG1L) 00110501 TRMBLD2 DS CL(TRMSG2L) 00110601 DECKEY DS CL128 00110701 TRSAV14 DS F 00110801 .NOTEST4 ANOP , 00110901 WORKALEN EQU *-WORKADS 00111001 VSIOMOD CSECT , 00111101 EJECT 00111201 VSAMIO ,FUNC=PLIST 00111301 EJECT 00111401 FCDSECT DSECT , 00111501 FCBLOCK DS 0F ALIGN THE STARS 00111601 FCDDNAME DS CL8 DDNAME 00111701 FCACBAD DS AL4 ADDRESS OF ACB 00111801 FCSRPLAD DS AL4 SEQ RPL ADDRESS 00111901 FCSAREA DS AL4 SEQ RECORD AREA ADDRESS 00112001 FCRRPLAD DS AL4 RANDOM RPL ADDRESS 00112101 FCRAREA DS AL4 RANDOM RECORD AREA ADDRESS 00112201 FCPREV DS AL4 BACKWARD CHAIN 00112301 FCNEXT DS AL4 FOWARD CHAIN 00112401 FCKEY DS XL255 RECORD KEY 00112501 FCFKEYL DS XL1 FULL KEY LENGTH 00112601 FCFKEYD DS XL2 KEY DISPLACEMENT INTO RECORD 00112701 * 00112801 FCELEN EQU *-FCBLOCK 00112901 *********************************************************************** 00113001 * SYSTEM DSECTS * 00113101 *********************************************************************** 00113201 IFGRPL DSECT=YES,AM=VSAM 00113301 EJECT 00113401 IFGACB DSECT=YES,AM=VSAM 00113501 EJECT 00113601 IHASDWA 00113701 * 00113801 VSIOMOD CSECT , 00114001 END VSIOMOD 00120001