COPY MVSMACS COPY PDPTOP CSECT , PRINT GEN * YREGS SPACE 1 *-----------------------ASSEMBLY OPTIONS------------------------------* SUBPOOL EQU 0 * *---------------------------------------------------------------------* SPACE 1 * * * * Start of functions * * *********************************************************************** * * * AOPEN - Open a data set * * * *********************************************************************** * * * Parameters are: * *1 DDNAME - space-padded, 8 character DDNAME to be opened * *2 MODE = 0 INPUT 1 OUTPUT 2 UPDAT 3 APPEND Record mode * * MODE = 4 INOUT 5 OUTIN * * MODE = 8/9 Use EXCP for tape, BSAM otherwise (or 32<=JFCPNCP<=65) * * MODE + 10 = Use BLOCK mode (valid 10-15) * * MODE = 80 = GETLINE, 81 = PUTLINE (other bits ignored) * * N.B.: see comments under Return value *3 RECFM - 0 = F, 1 = V, 2 = U. Default/preference set by caller; * * actual value returned from open. * *4 LRECL - Default/preference set by caller; OPEN value returned. * *5 BLKSIZE - Default/preference set by caller; OPEN value returned. * * * * August 2009 revision - caller will pass preferred RECFM (coded 0-2) * * LRECL, and BLKSIZE values. DCB OPEN exit OCDCBEX will use these * * defaults when not specified on JCL or DSCB merge. * * * *6 ZBUFF2 - pointer to an area that may be written to (size is LRECL) * *7 MEMBER - *pointer* to space-padded, 8 character member name. * * A member name beginning with blank or hex zero is ignored. * * If pointer is 0 (NULL), no member is requested * * * * Return value: * * An internal "handle" that allows the assembler routines to * * keep track of what's what, when READ etc are subsequently * * called. * * * * All passed parameters are subject to overrides based on device * * capabilities and capacities, e.g., blocking may be turned off. * * In particular, the MODE flag will have x'40' ORed in for a * * unit record device. * * * * * * Note - more documentation for this and other I/O functions can * * be found halfway through the stdio.c file in PDPCLIB. * * * * Here are some of the errors reported: * * * * OPEN input failed return code is: -37 * * OPEN output failed return code is: -39 * * * * FIND input member return codes are: * * Original, before the return and reason codes had * * negative translations added refer to copyrighted: * * DFSMS Macro Instructions for Data Sets * * RC = 0 Member was found. * * RC = -1024 Member not found. * * RC = -1028 RACF allows PDSE EXECUTE, not PDSE READ. * * RC = -1032 PDSE share not available. * * RC = -1036 PDSE is OPENed output to a different member. * * RC = -2048 Directory I/O error. * * RC = -2052 Out of virtual storage. * * RC = -2056 Invalid DEB or DEB not on TCB or TCBs DEB chain. * * RC = -2060 PDSE I/O error flushing system buffers. * * RC = -2064 Invalid FIND, no DCB address. * * * *********************************************************************** PUSH USING @@AOPEN FUNHEAD SAVE=(WORKAREA,OPENLEN,SUBPOOL) LR R11,R1 KEEP R11 FOR PARAMETERS USING PARMSECT,R11 MAKE IT EASIER TO READ L R3,PARM1 R3 POINTS TO DDNAME * Note that R5 is used as a scratch register L R8,PARM4 R8 POINTS TO LRECL * PARM5 has BLKSIZE * PARM6 has ZBUFF2 pointer L R9,PARM7 R9 POINTS TO MEMBER NAME (OF PDS) LA R9,00(,R9) Strip off high-order bit or byte TM 0(R9),255-X'40' Either blank or zero? BNZ *+6 No SR R9,R9 Set for no member SPACE 1 L R4,PARM2 R4 is the MODE. 0=input 1=output CH R4,=H'256' Call with value? BL *+8 Yes; else pointer L R4,0(,R4) Load C/370 MODE. 0=input 1=output SPACE 1 AIF ('&SYS' NE 'S390').NOLOW GETMAIN R,LV=ZDCBLEN,SP=SUBPOOL,LOC=BELOW AGO .FINLOW .NOLOW GETMAIN R,LV=ZDCBLEN,SP=SUBPOOL .FINLOW LR R10,R1 Addr.of storage obtained to its base USING IHADCB,R10 Give assembler DCB area base register LR R0,R10 Load output DCB area address LA R1,ZDCBLEN Load output length of DCB area LA R15,0 Pad of X'00' and no input length MVCL R0,R14 Clear DCB area to binary zeroes *---------------------------------------------------------------------* * GET USER'S DEFAULTS HERE, BECAUSE THEY MAY GET CHANGED *---------------------------------------------------------------------* L R5,PARM3 HAS RECFM code (0-FB 1-VB 2-U) L R14,0(,R5) LOAD RECFM VALUE STC R14,FILEMODE PASS TO OPEN L R14,0(,R8) GET LRECL VALUE ST R14,LRECL PASS TO OPEN L R14,PARM5 R14 POINTS TO BLKSIZE L R14,0(,R14) GET BLOCK SIZE ST R14,BLKSIZE PASS TO OPEN SPACE 1 *---------------------------------------------------------------------* * DO THE DEVICE TYPE NOW TO CHECK WHETHER EXCP IS POSSIBLE * ALSO BYPASS STUFF IF USER REQUESTED TERMINAL I/O *---------------------------------------------------------------------* OPCURSE STC R4,WWORK Save to storage STC R4,WWORK+1 Save to storage NI WWORK+1,7 Retain only open mode bits TM WWORK,IOFTERM Terminal I/O ? BNZ TERMOPEN Yes; do completely different ***> Consider forcing terminal mode if DD is a terminal? MVC DWDDNAM,0(R3) Move below the line DEVTYPE DWDDNAM,DWORK Check device type BXH R15,R15,FAILDCB DD missing ICM R0,15,DWORK+4 Any device size ? BNZ OPHVMAXS MVC DWORK+6(2),=H'32760' Set default max SPACE 1 OPHVMAXS CLI WWORK+1,3 Append requested ? BNE OPNOTAP No TM DWORK+2,UCB3TAPE+UCB3DACC TAPE or DISK ? BM OPNOTAP Yes; supported NI WWORK,255-2 Change to plain output *OR-FAIL BNM FAILDCB No, not supported SPACE 1 OPNOTAP CLI WWORK+1,2 UPDAT request? BNE OPNOTUP No CLI DWORK+2,UCB3DACC DASD ? BNE FAILDCB No, not supported SPACE 1 OPNOTUP CLI WWORK+1,4 INOUT or OUTIN ? BL OPNOTIO No TM DWORK+2,UCB3TAPE+UCB3DACC TAPE or DISK ? BNM FAILDCB No; not supported SPACE 1 OPNOTIO TM WWORK,IOFEXCP EXCP requested ? BZ OPFIXMD2 CLI DWORK+2,UCB3TAPE TAPE/CARTRIDGE device? BE OPFIXMD1 Yes; wonderful ? OPFIXMD0 NI WWORK,255-IOFEXCP Cancel EXCP request B OPFIXMD2 OPFIXMD1 L R0,BLKSIZE GET USER'S SIZE CH R0,=H'32760' NEED EXCP ? BNH OPFIXMD0 NO; USE BSAM ST R0,DWORK+4 Increase max size ST R0,LRECL ALSO RECORD LENGTH MVI FILEMODE,2 FORCE RECFM=U SPACE 1 OPFIXMD2 IC R4,WWORK Fix up OPFIXMOD STC R4,WWORK Save to storage MVC IOMFLAGS,WWORK Save for duration SPACE 1 *---------------------------------------------------------------------* * Do as much common code for input and output before splitting * Set mode flag in Open/Close list * Move BSAM, QSAM, or EXCP DCB to work area *---------------------------------------------------------------------* STC R4,OPENCLOS Initialize MODE=24 OPEN/CLOSE list NI OPENCLOS,X'07' For now * OPEN mode: IN OU UP AP IO OI TR OPENCLOS(1),=X'80,8F,84,8E,83,86,0,0' CLI OPENCLOS,0 NOT SUPPORTED ? BE FAILDCB FAIL REQUEST SPACE 1 TM WWORK,IOFEXCP EXCP mode ? BZ OPQRYBSM MVC ZDCBAREA(EXCPDCBL),EXCPDCB Move DCB/IOB/CCW LA R15,TAPEIOB FOR EASIER SETTINGS USING IOBSTDRD,R15 MVI IOBFLAG1,IOBDATCH+IOBCMDCH COMMAND CHAINING IN USE MVI IOBFLAG2,IOBRRT2 LA R1,TAPEECB ST R1,IOBECBPT LA R1,TAPECCW ST R1,IOBSTART CCW ADDRESS ST R1,IOBRESTR CCW ADDRESS LA R1,TAPEDCB ST R1,IOBDCBPT DCB LA R1,TAPEIOB STCM R1,7,DCBIOBAA LINK IOB TO DCB FOR DUMP FORM.ING LA R0,1 SET BLOCK COUNT INCREMENT STH R0,IOBINCAM DROP R15 B OPREPCOM SPACE 1 OPQRYBSM TM WWORK,IOFBLOCK Block mode ? BNZ OPREPBSM TM WWORK,X'01' In or Out *DEFUNCT BNZ OPREPQSM OPREPBSM MVC ZDCBAREA(BSAMDCBL),BSAMDCB Move DCB template to work TM DWORK+2,UCB3DACC+UCB3TAPE Tape or Disk ? BM OPREPCOM Either; keep RP,WP NC DCBMACR(2),=AL1(DCBMRRD,DCBMRWRT) Strip Point B OPREPCOM SPACE 1 OPREPQSM MVC ZDCBAREA(QSAMDCBL),QSAMDCB OPREPCOM MVC DCBDDNAM,0(R3) MVC DEVINFO(8),DWORK Check device type ICM R0,15,DEVINFO+4 Any ? BZ FAILDCB No DD card or ? N R4,=X'000000EF' Reset block mode TM WWORK,IOFTERM Terminal I/O? BNZ OPFIXMOD TM WWORK,IOFBLOCK Blocked I/O? BZ OPREPJFC CLI DEVINFO+2,UCB3UREC Unit record? BE OPFIXMOD Yes, may not block SPACE 1 OPREPJFC LA R14,JFCB * EXIT TYPE 07 + 80 (END OF LIST INDICATOR) ICM R14,B'1000',=X'87' ST R14,DCBXLST+4 LA R14,OCDCBEX POINT TO DCB EXIT * Both S380 and S390 operate in 31-bit mode so need a stub AIF ('&SYS' EQ 'S370').NODP24 ST R14,DOPE31 Address of 31-bit exit OI DOPE31,X'80' Set high bit = AMODE 31 MVC DOPE24,DOPEX24 Move in stub code LA R14,DOPE24 Switch to 24-bit stub .NODP24 ANOP , ICM R14,8,=X'05' REQUEST IT ST R14,DCBXLST AND SET IT BACK LA R14,DCBXLST STCM R14,B'0111',DCBEXLSA MVC EOFR24(EOFRLEN),ENDFILE Put EOF code below the line LA R1,EOFR24 STCM R1,B'0111',DCBEODA RDJFCB ((R10)),MF=(E,OPENCLOS) Read JOB File Control Blk *---------------------------------------------------------------------* * If the caller did not request EXCP mode, but the user has BLKSIZE * greater than 32760 on TAPE, then we set the EXCP bit in R4 and * restart the OPEN. Otherwise MVS should fail? * The system fails explicit BLKSIZE in excess of 32760, so we cheat. * The NCP field is not otherwise honored, so if the value is 32 to * 64 inclusive, we use that times 1024 as a value (max 65535) *---------------------------------------------------------------------* CLI DEVINFO+2,UCB3TAPE TAPE DEVICE? BNE OPNOTBIG NO TM WWORK,IOFEXCP USER REQUESTED EXCP ? BNZ OPVOLCNT NOTHING TO DO CLI JFCNCP,32 LESS THAN MIN ? BL OPNOTBIG YES; IGNORE CLI JFCNCP,65 NOT TOO HIGH ? BH OPNOTBIG TOO BAD *---------------------------------------------------------------------* * Clear DCB wrk area and force RECFM=U,BLKSIZE>32K * and restart the OPEN processing *---------------------------------------------------------------------* LR R0,R10 Load output DCB area address LA R1,ZDCBLEN Load output length LA R15,0 Pad of X'00' MVCL R0,R14 Clear DCB area to zeroes SR R0,R0 ICM R0,1,JFCNCP NUMBER OF CHANNEL PROGRAMS SLL R0,10 *1024 C R0,=F'65535' LARGER THAN CCW SUPPORTS? BL *+8 NO L R0,=F'65535' LOAD MAX SUPPORTED ST R0,BLKSIZE MAKE NEW VALUES THE DEFAULT ST R0,LRECL MAKE NEW VALUES THE DEFAULT MVI FILEMODE,2 USE RECFM=U LA R0,IOFEXCP GET EXCP OPTION OR R4,R0 ADD TO USER'S REQUEST B OPCURSE AND RESTART THE OPEN SPACE 1 OPVOLCNT SR R1,R1 ICM R1,1,JFCBVLCT GET VOLUME COUNT FROM DD BNZ *+8 OK LA R1,1 SET FOR ONE ST R1,ZXCPVOLS SAVE FOR EOV SPACE 1 OPNOTBIG CLI DEVINFO+2,UCB3DACC Is it a DASD device? BNE OPNODSCB No; no member name supported *---------------------------------------------------------------------* * For a DASD resident file, get the format 1 DSCB *---------------------------------------------------------------------* * CAMLST CAMLST SEARCH,DSNAME,VOLSER,DSCB+44 * L R14,CAMDUM Get CAMLST flags LA R15,JFCBDSNM Load address of output data set name LA R0,JFCBVOLS Load addr. of output data set volser LA R1,DS1FMTID Load address of where to put DSCB STM R14,R1,CAMLST Complete CAMLST addresses OBTAIN CAMLST Read the VTOC record SPACE 1 * The member name may not be below the line, which may stuff up * the "FIND" macro, so make sure it is in 24-bit memory. OPNODSCB LTR R9,R9 See if an address for the member name BZ NOMEM No member name, skip copying MVC MEMBER24,0(R9) LA R9,MEMBER24 SPACE 1 *---------------------------------------------------------------------* * Split READ and WRITE paths * Note that all references to DCBRECFM, DCBLRECL, and DCBBLKSI * have been replaced by ZRECFM, LRECL, and BLKSIZE for EXCP use. *---------------------------------------------------------------------* NOMEM TM WWORK,1 See if OPEN input or output BNZ WRITING *---------------------------------------------------------------------* * * READING * N.B. moved RDJFCB prior to member test to allow uniform OPEN and * other code. Makes debugging and maintenance easier * *---------------------------------------------------------------------* OI JFCBTSDM,JFCNWRIT Don't mess with DSCB CLI DEVINFO+2,UCB3DACC Is it a DASD device? BNE OPENVSEQ No; no member name supported *---------------------------------------------------------------------* * See if DSORG=PO but no member; use member from JFCB if one *---------------------------------------------------------------------* TM DS1DSORG,DS1DSGPO See if DSORG=PO BZ OPENVSEQ Not PDS, don't read PDS directory TM WWORK,X'07' ANY NON-READ OPTION ? BNZ FAILDCB NOT ALLOWED FOR PDS LTR R9,R9 See if an address for the member name BNZ OPENMEM Is member name - BPAM access TM JFCBIND1,JFCPDS See if a member name in JCL BZ OPENDIR No; read directory MVC MEMBER24,JFCBELNM Save the member name NI JFCBIND1,255-JFCPDS Reset it XC JFCBELNM,JFCBELNM Delete it in JFCB LA R9,MEMBER24 Force FIND to prevent 013 abend B OPENMEM Change DCB to BPAM PO *---------------------------------------------------------------------* * At this point, we have a PDS but no member name requested. * Request must be to read the PDS directory *---------------------------------------------------------------------* OPENDIR TM OPENCLOS,X'0F' Other than plain OPEN ? BNZ BADOPIN No, fail (allow UPDAT later?) LA R0,256 Set size for Directory BLock STH R0,DCBBLKSI Set DCB BLKSIZE to 256 STH R0,DCBLRECL Set DCB LRECL to 256 ST R0,LRECL ST R0,BLKSIZE MVI DCBRECFM,DCBRECF Set DCB RECFM to RECFM=F (notU?) B OPENIN OPENMEM MVI DCBDSRG1,DCBDSGPO Replace DCB DSORG=PS with PO OI JFCBTSDM,JFCVSL Force OPEN analysis of JFCB B OPENIN OPENVSEQ LTR R9,R9 Member name for sequential? BNZ BADOPIN Yes, fail TM IOMFLAGS,IOFEXCP EXCP mode ? BNZ OPENIN YES OI DCBOFLGS,DCBOFPPC Allow unlike concatenation OPENIN OPEN MF=(E,OPENCLOS),TYPE=J Open the data set TM DCBOFLGS,DCBOFOPN Did OPEN work? BZ BADOPIN OPEN failed, go return error code -37 LTR R9,R9 See if an address for the member name BZ GETBUFF No member name, skip finding it * FIND (R10),(R9),D Point to the requested member * LTR R15,R15 See if member found BZ GETBUFF Member found, go get an input buffer * If FIND return code not zero, process return and reason codes and * return to caller with a negative return code. SLL R15,8 Shift return code for reason code OR R15,R0 Combine return code and reason code LR R7,R15 Number to generate return and reason CLOSE MF=(E,OPENCLOS) Close, FREEPOOL not needed B FREEDCB BADOPIN DS 0H BADOPOUT DS 0H FAILDCB N R4,=F'1' Mask other option bits LA R7,37(R4,R4) Preset OPEN error code FREEDCB FREEMAIN R,LV=ZDCBLEN,A=(R10),SP=SUBPOOL Free DCB area LCR R7,R7 Set return and reason code B RETURNOP Go return to caller with negative RC SPACE 1 *---------------------------------------------------------------------* * Process for OUTPUT mode *---------------------------------------------------------------------* WRITING LTR R9,R9 BZ WNOMEM CLI DEVINFO+2,UCB3DACC DASD ? BNE BADOPOUT Member name invalid TM DS1DSORG,DS1DSGPO See if DSORG=PO BZ BADOPOUT Is not PDS, fail request TM WWORK,X'06' ANY NON-RITE OPTION ? BNZ FAILDCB NOT ALLOWED FOR PDS MVC JFCBELNM,0(R9) OI JFCBIND1,JFCPDS OI JFCBTSDM,JFCVSL Just in case B WNOMEM2 Go to move DCB info WNOMEM DS 0H TM JFCBIND1,JFCPDS See if a member name in JCL BO WNOMEM2 Is member name, go to continue OPEN * See if DSORG=PO but no member so OPEN output would destroy directory TM DS1DSORG,DS1DSGPO See if DSORG=PO BZ WNOMEM2 Is not PDS, go OPEN WTO 'MVSSUPA - No member name for output PDS',ROUTCDE=11 WTO 'MVSSUPA - Refuses to write over PDS directory', C ROUTCDE=11 ABEND 123 Abend without a dump SPACE 1 WNOMEM2 OPEN MF=(E,OPENCLOS),TYPE=J TM DCBOFLGS,DCBOFOPN Did OPEN work? BZ BADOPOUT OPEN failed, go return error code -39 SPACE 1 *---------------------------------------------------------------------* * Acquire one BLKSIZE buffer for our I/O; and one LRECL buffer * for use by caller for @@AWRITE, and us for @@AREAD. *---------------------------------------------------------------------* GETBUFF L R5,BLKSIZE Load the input blocksize LA R6,4(,R5) Add 4 in case RECFM=U buffer GETMAIN R,LV=(R6),SP=SUBPOOL Get input buffer storage ST R1,ZBUFF1 Save for cleanup ST R6,ZBUFF1+4 ditto ST R1,BUFFADDR Save the buffer address for READ XC 0(4,R1),0(R1) Clear the RECFM=U Record Desc. Word LA R14,0(R5,R1) Get end address ST R14,BUFFEND for real SPACE 1 L R6,LRECL Get record length LA R6,4(,R6) Insurance GETMAIN R,LV=(R6),SP=SUBPOOL Get VBS build record area ST R1,ZBUFF2 Save for cleanup ST R6,ZBUFF2+4 ditto LA R14,4(,R1) ST R14,VBSADDR Save the VBS read/user write L R5,PARM6 Get caller's BUFFER address ST R14,0(,R5) and return work address AR R1,R6 Add size GETMAINed to find end ST R1,VBSEND Save address after VBS rec.build area B DONEOPEN Go return to caller with DCB info SPACE 1 PUSH USING *---------------------------------------------------------------------* * Establish ZDCBAREA for either @@AWRITE or @@AREAD processing to * a terminal, or SYSTSIN/SYSTERM in batch. *---------------------------------------------------------------------* TERMOPEN MVC IOMFLAGS,WWORK Save for duration NI IOMFLAGS,IOFTERM+IOFOUT IGNORE ALL OTHERS MVC ZDCBAREA(TERMDCBL),TERMDCB Move DCB/IOB/CCW MVC ZIODDNM,0(R3) DDNAME FOR DEBUGGING, ETC. LTR R9,R9 See if an address for the member name BNZ FAILDCB Yes; fail L R14,PSATOLD-PSA GET MY TCB USING TCB,R14 ICM R15,15,TCBJSCB LOOK FOR THE JSCB BZ FAILDCB HUH ? USING IEZJSCB,R15 ICM R15,15,JSCBPSCB PSCB PRESENT ? BZ FAILDCB NO; NOT TSO L R1,TCBFSA GET FIRST SAVE AREA N R1,=X'00FFFFFF' IN CASE AM31 L R1,24(,R1) LOAD INVOCATION R1 USING CPPL,R1 DECLARE IT MVC ZIOECT,CPPLECT MVC ZIOUPT,CPPLUPT SPACE 1 ICM R6,15,BLKSIZE Load the input blocksize BP *+12 Use it LA R6,1024 Arbitrary non-zero size ST R6,BLKSIZE Return it ST R6,LRECL Return it LA R6,4(,R6) Add 4 in case RECFM=U buffer GETMAIN R,LV=(R6),SP=SUBPOOL Get input buffer storage ST R1,ZBUFF2 Save for cleanup ST R6,ZBUFF2+4 ditto LA R1,4(,R1) Allow for RDW if not V ST R1,BUFFADDR Save the buffer address for READ L R5,PARM6 R5 points to ZBUFF2 ST R1,0(,R5) save the pointer XC 0(4,R1),0(R1) Clear the RECFM=U Record Desc. Word MVC ZRECFM,FILEMODE Requested format 0-2 NI ZRECFM,3 Just in case TR ZRECFM,=X'8040C0C0' Change to F / V / U POP USING SPACE 1 * Lots of code tests DCBRECFM twice, to distinguish among F, V, and * U formats. We set the index byte to 0,4,8 to allow a single test * with a three-way branch. DONEOPEN LR R7,R10 Return DCB/file handle address LA R0,8 TM ZRECFM,DCBRECU Undefined ? BO SETINDEX Yes BM GETINDFV No TM ZRECFM,DCBRECTO RECFM=D BZ SETINDEX No; treat as U B SETINDVD GETINDFV SR R0,R0 Set for F TM ZRECFM,DCBRECF Fixed ? BNZ SETINDEX Yes SETINDVD LA R0,4 Preset for V SETINDEX STC R0,RECFMIX Save for the duration SRL R0,2 Convert to caller's code L R5,PARM3 POINT TO RECFM ST R0,0(,R5) Pass either RECFM F or V to caller L R1,LRECL Load RECFM F or V max. record length ST R1,0(,R8) Return record length back to caller L R5,PARM5 POINT TO BLKSIZE L R0,BLKSIZE Load RECFM U maximum record length ST R0,0(,R5) Pass new BLKSIZE L R5,PARM2 POINT TO MODE MVC 3(1,R5),IOMFLAGS Pass (updated) file mode back CLI DEVINFO+2,UCB3UREC BNE NOTUNREC Not unit-record OI 3(R5),IOFUREC flag unit-record NOTUNREC DS 0H * * Finished with R5 now * RETURNOP FUNEXIT RC=(R7) Return to caller * * This is not executed directly, but copied into 24-bit storage ENDFILE LA R6,1 Indicate @@AREAD reached end-of-file LNR R6,R6 Make negative BR R14 Return to instruction after the GET EOFRLEN EQU *-ENDFILE * LTORG , SPACE 1 BSAMDCB DCB MACRF=(RP,WP),DSORG=PS,DDNAME=BSAMDCB, input and output * EXLST=1-1 JFCB and DCB exits added later BSAMDCBN EQU *-BSAMDCB READDUM READ NONE, Read record Data Event Control Block * SF, Read record Sequential Forward * , (R10), Read record DCB address * , (R4), Read record input buffer * , (R5), Read BLKSIZE or 256 for PDS.Directory* MF=L List type MACRO READLEN EQU *-READDUM BSAMDCBL EQU *-BSAMDCB SPACE 1 EXCPDCB DCB DDNAME=EXCPDCB,MACRF=E,DSORG=PS,REPOS=Y,BLKSIZE=0, * DEVD=TA,EXLST=1-1,RECFM=U DC 8XL4'0' CLEAR UNUSED SPACE ORG EXCPDCB+84 LEAVE ROOM FOR DCBLRECL DC F'0' VOLUME COUNT PATCCW CCW 1,2-2,X'40',3-3 ORG , EXCPDCBL EQU *-EXCPDCB PATTERN TO MOVE SPACE 1 TERMDCB PUTLINE MF=L PATTERN FOR TERMINAL I/O TERMDCBL EQU *-TERMDCB SIZE OF IOPL SPACE 1 F65536 DC F'65536' Maximum VBS record GETMAIN length * * QSAMDCB changes depending on whether we are in LOCATE mode or * MOVE mode QSAMDCB DCB MACRF=P&OUTM.M,DSORG=PS,DDNAME=QSAMDCB QSAMDCBL EQU *-QSAMDCB * * * CAMDUM CAMLST SEARCH,DSNAME,VOLSER,DSCB+44 CAMDUM CAMLST SEARCH,*-*,*-*,*-* CAMLEN EQU *-CAMDUM Length of CAMLST Template POP USING SPACE 1 *---------------------------------------------------------------------* * Expand OPEN options for reference *---------------------------------------------------------------------* ADHOC DSECT , OPENREF OPEN (BSAMDCB,INPUT),MF=L QSAM, BSAM, any DEVTYPE OPEN (BSAMDCB,OUTPUT),MF=L QSAM, BSAM, any DEVTYPE OPEN (BSAMDCB,UPDAT),MF=L QSAM, BSAM, DASD OPEN (BSAMDCB,EXTEND),MF=L QSAM, BSAM, DASD, TAPE OPEN (BSAMDCB,INOUT),MF=L BSAM, DASD, TAPE OPEN (BSAMDCB,OUTINX),MF=L BSAM, DASD, TAPE OPEN (BSAMDCB,OUTIN),MF=L BSAM, DASD, TAPE SPACE 1 PARMSECT DSECT , MAP CALL PARM PARM1 DS A FIRST PARM PARM2 DS A NEXT PARM PARM3 DS A NEXT PARM PARM4 DS A NEXT PARM PARM5 DS A NEXT PARM PARM6 DS A NEXT PARM PARM7 DS A NEXT PARM PARM8 DS A NEXT PARM CSECT , SPACE 1 ORG CAMDUM+4 Don't need rest SPACE 2 *********************************************************************** * * * OPEN DCB EXIT - if RECFM, LRECL, BLKSIZE preset, no change * * unless forced by device (e.g., unit record * * not blocked) * * for PDS directory read, F, 256, 256 are preset. * * a) device is unit record - default U, device size, device size * * b) all others - default to values passed to AOPEN * * * * For FB, if LRECL > BLKSIZE, make LRECL=BLKSIZE * * For VB, if LRECL+3 > BLKSIZE, set spanned * * * * * * So, what this means is that if the DCBLRECL etc fields are set * * already by MVS (due to existing file, JCL statement etc), * * then these aren't changed. However, if they're not present, * * then start using the "LRECL" etc previously set up by C caller. * * * *********************************************************************** PUSH USING DROP , USING OCDCBEX,R15 USING IHADCB,R1 DECLARE OUR DCB WORK SPACE OCDCBEX LR R11,R1 SAVE DCB ADDRESS AND OPEN FLAGS N R1,=X'00FFFFFF' NO 0C4 ON DCB ACCESS IF AM31 TM IOPFLAGS,IOFDCBEX Been here before ? BZ OCDCBX1 OI IOPFLAGS,IOFCONCT Set unlike concatenation OI DCBOFLGS,DCBOFPPC Keep them coming OCDCBX1 OI IOPFLAGS,IOFDCBEX Show exit entered SR R2,R2 FOR POSSIBLE DIVIDE (FB) SR R3,R3 ICM R3,3,DCBBLKSI GET CURRENT BLOCK SIZE SR R4,R4 FOR POSSIBLE LRECL=X ICM R4,3,DCBLRECL GET CURRENT RECORD LENGTH NI FILEMODE,3 MASK FILE MODE MVC ZRECFM,FILEMODE GET OPTION BITS TR ZRECFM,=X'90,50,C0,C0' 0-FB 1-VB 2-U TM DCBRECFM,DCBRECLA ANY RECORD FORMAT SPECIFIED? BNZ OCDCBFH YES CLI DEVINFO+2,UCB3UREC UNIT RECORD? BNE OCDCBFM NO; USE OVERRIDE OCDCBFU CLI FILEMODE,0 DID USER REQUEST FB? BE OCDCBFM YES; USE IT OI DCBRECFM,DCBRECU SET U FOR READER/PUNCH/PRINTER B OCDCBFH OCDCBFM MVC DCBRECFM,ZRECFM OCDCBFH LTR R4,R4 BNZ OCDCBLH HAVE A RECORD LENGTH L R4,DEVINFO+4 SET DEVICE SIZE FOR UNIT RECORD CLI DEVINFO+2,UCB3UREC UNIT RECORD? BE OCDCBLH YES; USE IT * REQUIRES CALLER TO SET LRECL=BLKSIZE FOR RECFM=U DEFAULT ICM R4,15,LRECL SET LRECL=PREFERRED BLOCK SIZE BNZ *+8 L R4,DEVINFO+4 ELSE USE DEVICE MAX IC R5,DCBRECFM GET RECFM N R5,=X'000000C0' RETAIN ONLY D,F,U,V SRL R5,6 CHANGE TO 0-D 1-V 2-F 3-U MH R5,=H'3' PREPARE INDEX SR R6,R6 IC R6,FILEMODE GET USER'S VALUE AR R5,R6 DCB VS. DFLT ARRAY * DCB RECFM: --D--- --V--- --F--- --U--- * FILE MODE: F V U F V U F V U F V U LA R6,=AL1(4,0,-4,4,0,-4,0,-4,0,0,-4,0) LRECL ADJUST AR R6,R5 POINT TO ENTRY ICM R5,8,0(R6) LOAD IT SRA R5,24 SHIFT WITH SIGN EXTENSION AR R4,R5 NEW LRECL SPACE 1 * NOW CHECK BLOCK SIZE OCDCBLH LTR R3,R3 ANY ? BNZ *+8 YES ICM R3,15,BLKSIZE SET OUR PREFERRED SIZE BNZ *+8 OK L R3,DEVINFO+4 SET NON-ZERO C R3,DEVINFO+4 LEGAL ? BNH *+8 L R3,DEVINFO+4 NO; SHORTEN TM DCBRECFM,DCBRECU U? BO OCDCBBU YES TM DCBRECFM,DCBRECF FIXED ? BZ OCDCBBV NO; CHECK VAR DR R2,R4 CH R3,=H'1' DID IT FIT ? BE OCDCBBF BARELY BH OCDCBBB ELSE LEAVE BLOCKED LA R3,1 SET ONE RECORD MINIMUM OCDCBBF NI DCBRECFM,255-DCBRECBR BLOCKING NOT NEEDED OCDCBBB MR R2,R4 BLOCK SIZE NOW MULTIPLE OF LRECL B OCDCBXX AND GET OUT * VARIABLE OCDCBBV LA R5,4(,R4) LRECL+4 CR R5,R3 WILL IT FIT ? BNH *+8 YES OI DCBRECFM,DCBRECSB SET SPANNED B OCDCBXX AND EXIT * UNDEFINED OCDCBBU LR R4,R3 FOR NEATNESS, SET LRECL = BLOCK SIZE * EXEUNT (Save DCB options for EXCP compatibility in main code) OCDCBXX STH R3,DCBBLKSI UPDATE POSSIBLY CHANGED BLOCK SIZE STH R4,DCBLRECL AND RECORD LENGTH ST R3,BLKSIZE UPDATE POSSIBLY CHANGED BLOCK SIZE ST R4,LRECL AND RECORD LENGTH MVC ZRECFM,DCBRECFM DITTO AIF ('&SYS' EQ 'S370').NOOPSW BSM R0,R14 AGO .OPNRET .NOOPSW ANOP , BR R14 RETURN TO OPEN .OPNRET ANOP , POP USING SPACE 2 * AIF ('&SYS' EQ 'S370').NODOP24 *********************************************************************** * * * OPEN DCB EXIT - 24 bit stub * * This code is not directly executed. It is copied below the line * * It is only needed for AMODE 31 programs (both S380 and S390 * * execute in this mode). * * * *********************************************************************** PUSH USING DROP , USING DOPEX24,R15 * * This next line works because when we are actually executing, * we are executing inside that DSECT, so the address we want * follows the code. Also, it has already had the high bit set, * so it will switch to 31-bit mode. * DOPEX24 L R15,DOPE31-DOPE24(,R15) Load 31-bit routine address * * The following works because while the AMODE is saved in R14, the * rest of R14 isn't disturbed, so it is all set for a BSM to R14 * BSM R14,R15 Switch to 31-bit mode DOPELEN EQU *-DOPEX24 POP USING .NODOP24 ANOP , * COPY CLIBSUPA * SPACE 2 PRINT NOGEN IHAPSA , MAP LOW STORAGE CVT DSECT=YES IKJTCB , MAP TASK CONTROL BLOCK IKJECT , MAP ENV. CONTROL BLOCK IKJPTPB , PUTLINE PARAMETER BLOCK IKJCPPL , IKJPSCB , IEZJSCB , IEZIOB , IEFZB4D0 , MAP SVC 99 PARAMETER LIST IEFZB4D2 , MAP SVC 99 PARAMETERS IEFUCBOB , MYTIOT DSECT , IEFTIOT1 , IHAPDS PDSBLDL=YES SPACE 1 IFGACB , GP14233 SPACE 1 IFGRPL , GP14233 IEFJESCT , IKJUPT , END