TITLE 'ICATS WRITE-DATA-TO-A-CMS-FILE ROUTINE' WRI00010
*********************************************************************** WRI00020
* * WRI00030
* MODULE NAME = WRITE * WRI00040
* * WRI00050
* FUNCTION = IF THIS REQUEST CAME FROM A UTS MACHINE, THEN * WRI00060
* RETRIEVE DATA FROM THE REQUESTING UTS MACHINE AND * WRI00070
* WRITE IT TO A CMS FILE. * WRI00080
* IF THIS IS A SMSG REQUEST, THEN LINK TO SOMEBODY'S * WRI00090
* DISK, ACCESS IT, AND COPY A FILE FROM THAT DISK TO * WRI00100
* ONE OF MY OWN DISKS. * WRI00110
* IF THIS IS A CONSOLE COMMAND, REJECT IT. * WRI00120
* * WRI00130
* ENTRY POINTS = WRITE * WRI00140
* * WRI00150
* LINKAGE = BALR R14,R15 FROM ICATS MAINLINE. * WRI00160
* * WRI00170
* * WRI00180
* REGISTER CONTENTS UPON ENTRY = * WRI00190
* R2 = POINTS TO THE ICATS COMMON DATA AREA, AS ALWAYS. * WRI00200
* R14 = RETURN ADDRESS BACK TO ICATS MAINLINE * WRI00210
* R15 = ENTRY POINT TO THIS MODULE * WRI00220
* * WRI00230
* * WRI00240
* REGISTER USAGE OUTSIDE RITELOOP (TO CON400 & AFTER CON600) = * WRI00250
* R0-R1 = USED TO PASS PARAMETERS TO SUBROUTINES. * WRI00260
* R2 = USED TO ADDRESS THE ICATS COMMON DATA AREA. * WRI00270
* R3 = FREE * WRI00280
* R4 = USED TO ADDRESS CURRENT UTS CONTROL BLOCK. * WRI00290
* R5 = USED TO ADDRESS CURRENT USER CONTROL BLOCK. * WRI00300
* R6 = USED TO ADDRESS CURRENT DISK CONTROL BLOCK. * WRI00310
* R7 = FREE * WRI00320
* R8 = POINT TO THE FILE NAME, TYPE, AND MODE * WRI00330
* R9-R11 = FREE * WRI00340
* R12 = MY FIRST BASE REGISTER * WRI00350
* R13 = MY SECOND BASE REGISTER * WRI00360
* R14 = MY RETURN ADDRESS WHEN I CALL SOMEBODY * WRI00370
* R15 = SUBROUTINE ADDRESS * WRI00380
* * WRI00390
* REGISTER USAGE DURING RITELOOP (CON400-CON600) = * WRI00400
* R0-R1 = USED TO PASS PARAMETERS TO SUBROUTINES. * WRI00410
* R2 = USED TO ADDRESS THE ICATS COMMON DATA AREA. * WRI00420
* R3 = FREE * WRI00430
* R4 = USED TO ADDRESS CURRENT UTS CONTROL BLOCK. * WRI00440
* R5 = USED TO ADDRESS CURRENT USER CONTROL BLOCK. * WRI00450
* R6 = USED TO ADDRESS CURRENT DISK CONTROL BLOCK. * WRI00460
* R7 = LENGTH OF THIS OUTPUT RECORD * WRI00470
* R8 = NUMBER OF BYTES LEFT TO WRITE IN THE INPUT BUFFER, * WRI00480
* OR IN THIS BLOCK, IF SOURCE CODE FORMAT. * WRI00490
* R9 = INPUT BUFFER POINTER TO CURRENT RECORD * WRI00500
* R10= LENGTH OF THIS INPUT RECORD * WRI00510
* R11= USED TO ADDRESS THE CURRENT RECORD IN THE INPUT BUFFER. * WRI00520
* R12 = MY FIRST BASE REGISTER * WRI00530
* R13 = MY SECOND BASE REGISTER * WRI00540
* R14 = MY RETURN ADDRESS WHEN I CALL SOMEBODY * WRI00550
* R15 = SUBROUTINE ADDRESS * WRI00560
* * WRI00570
* * WRI00580
* MODULE LOGIC: * WRI00590
* I) IF THIS IS A CONSOLE COMMAND, REJECT IT. * WRI00600
* II) IF THIS IS AN SMSG COMMAND, * WRI00610
* A) CALL THE ACCESS ROUTINE TO * WRI00620
* 1) LOCATE THE CORRECT UTSCB, * WRI00630
* 2) LOCATE THE CORRECT USERCB, * WRI00640
* 3) LOCATE THE CORRECT DISKCB, * WRI00650
* 4) AND TO ACCESS THE CORRECT MINIDISK. * WRI00660
* B) CHECK THE WRITE PASSWORD HE GAVE ME, * WRI00670
* C) LINK TO THIS GUYS MINIDISK, * WRI00680
* D) ACCESS IT, * WRI00690
* E) COPY THE FILE OVER TO MY DISK. * WRI00700
* F) RELEASE AND DETACH THIS GUYS MINIDISK. * WRI00710
* * WRI00720
* III) ELSE THIS MUST BE A UTS REQUEST. * WRI00730
* A) CALL THE ACCESS ROUTINE TO * WRI00740
* 1) LOCATE THE CORRECT UTSCB, * WRI00750
* 2) LOCATE THE CORRECT USERCB, * WRI00760
* 3) LOCATE THE CORRECT DISKCB, * WRI00770
* 4) AND TO ACCESS THE CORRECT MINIDISK. * WRI00780
* B) CHECK THE WRITE PASSWORD THE UTS USER SUPPLIED WITH * WRI00790
* THE ONE HE'S SUPPOSE TO SUPPLY FOR THIS MINIDISK. * WRI00800
* 1) CL8'ALL' = HE DOESN'T NEED A PASSWORD TO WRITE. * WRI00810
* 2) CL8'NONE' = HE CAN'T WRITE NO MATTER WHAT * WRI00820
* PASSWORD HE GAVE US. * WRI00830
* 3) ELSE VERIFY THE PASSWORD HE GAVE US. * WRI00840
* C) INSURE A VALID SUBFUNCTION WAS SPECIFIED AND SET FLAGS * WRI00850
* ACCORDINGLY. DETERMINE THE FILE NAME TO BE USED * WRI00860
* (THIS DETERMINATION DEPENDS ON THE SUBFUNCTION * WRI00870
* SPECIFIED). THE VALID SUBFUNCTIONS INCLUDE; * WRI00880
* 1) CREATE (THIS IS THE DEFAULT IF LEFT BLANK). THIS * WRI00890
* WILL ABORT THIS WRITE REQUEST IF A FILE ALREADY * WRI00900
* EXISTS WITH THIS FILENAME. * WRI00910
* 2) REPLACE. WE'LL DO AN ERASE OF THIS FILE FIRST. * WRI00920
* 3) INCRVL. THIS WILL SEARCH THE SPECIFIED MINIDISK TO * WRI00930
* DETERMINE THE FILENAME TO BE USED FOR THIS NEW FILE. * WRI00940
* IF THE FILENAME HE REQUESTED IS BEING USED BY SOME * WRI00950
* OTHER FILE, WE'LL CHANGE THE FILENAME TO THE FIRST * WRI00960
* FREE FILENAME WE FIND USING THIS SEARCH ORDER; * WRI00970
* XXXXX000 - XXXXX999 WHERE XXXXX = THE FIRST FIVE * WRI00980
* CHARACTERS OF THE GIVEN FILENAME. * WRI00990
* 4) APPEND. IF A FILE WITH THIS FILENAME ALREADY EXISTS * WRI01000
* THEN THIS DATA WILL BE APPENDED TO THAT FILE. ELSE * WRI01010
* A BRAND NEW FILE WILL BE CREATED WITH THIS FILENAME * WRI01020
* AND THIS DATA. * WRI01030
* 5) DA (DIRECT ACCESS WRITE). ALLOWS THE USER TO * WRI01040
* SPECIFY THE STARTING RECORD NUMBER OF CMS FILE TO * WRI01050
* START WRITING TO. THE CMS FILE MUST HAVE A FIXED * WRI01060
* LENGTH RECORD FORMAT. * WRI01070
* D) GO GET THE DATA FROM THE UTS MACHINE. THIS IS A * WRI01080
* SEPARATE SIO THAN THE ONE USED TO GET THE REQUEST * WRI01090
* CONTROL BLOCK. * WRI01100
* E) OPEN THE FILE AND, IF THIS IS A DA WRITE, THEN DO A * WRI01110
* FSPOINT TO START WRITING AT THE SPECIFIED RECORD. * WRI01120
* F) START WRITING UNTIL YOU'VE WRITTEN ALL THE DATA HE'S * WRI01130
* PASSED US. * WRI01140
* 1) DETERMINE THE LENGTH OF THE NEXT INPUT RECORD. * WRI01150
* 2) DETERMINE THE LENGTH OF THE NEXT OUTPUT RECORD. * WRI01160
* 3) PAD OR TRUNCATE THE INPUT RECORD AS NEEDED. * WRI01170
* 4) WRITE THIS RECORD INTO THE CMS FILE. * WRI01180
* G) CLOSE THE CMS FILE. * WRI01190
* H) GIVE A REPLY TO THE UTS MACHINE TELLING WHAT HAPPENED. * WRI01200
* INCLUDE STARTING RECORD # FOR NEXT WRITE, * WRI01210
* CMS FILE CHARACTERISTICS (RECORD FORMAT, LOGICAL * WRI01220
* RECORD LENGTH, AND NUMBER OF RECORDS IN THE FILE), * WRI01230
* AND THE BIGGEST RECORD I FOUND IN THE INPUT DATA. * WRI01240
* * WRI01250
* NORMAL EXIT = * WRI01260
* R15 = 0 * WRI01270
* * WRI01280
* EXTERNAL REFERENCES = DMSCPY (IF THIS WRITE IS FROM AN SMSG, * WRI01290
* I WANT TO USE THE CMS COPYFILE COMMAND, * WRI01300
* BUT THE COPY COMMAND RUNS IN THE USER AREA, * WRI01310
* OVERLAYING THE ICATS PROGRAM. SO I GOT THE * WRI01320
* COPYFILE TEXT FILE (DMSCPY TEXT) FROM THE * WRI01330
* CMS SYSTEM DISK (DO A GET CMSSP) AND NOW * WRI01340
* IT'S PART OF THE ICATS MODULE. * WRI01350
* * WRI01360
* MACROS = ICDATA = ICATS COMMON DATA AREA * WRI01370
* ETTE = ENTER TRACE TABLE ENTRY SUBROUTINE * WRI01380
* * WRI01390
* CHANGE ACTIVITY * WRI01400
* DATE NAME REASON FOR CHANGE * WRI01410
* 02/25/83 RICK JASPER INITIAL PROGRAM CREATION * WRI01420
* 05/03/83 RICK JASPER ADDED UTS SOURCE RECORD FORMAT SUPPORT * WRI01430
* 09/16/83 RICK JASPER WRITE FROM SMSG IS NOW DEFINED. * WRI01440
* * WRI01450
*********************************************************************** WRI01460
PRINT GEN,NODATA WRI01470
WRITE CSECT WRI01480
USING ICDATA,R2 ADDRESS ICATS COMMON DATA AREA WRI01490
USING CBUTS,R4 USE R4 TO ADDRESS UTS CONTROL BLOCK WRI01500
USING CBUSER,R5 USE R5 TO ADDRESS USER CONTROL BLOCK WRI01510
USING CBDISK,R6 USE R6 TO ADDRESS DISK CONTROL BLOCK WRI01520
USING *,R15 USE R15 FOR BASE REG NEXT INSTRUCTION ONLY WRI01530
STM R0,R14,REGSAVE SAVE CALLER'S REGISTERS WRI01540
DROP R15 WRI01550
USING WRITE,R12,R13 R12 & R13 WILL BE OUR BASE REGS WRI01560
LR R12,R15 ESTABLISH FIRST BASE REGISTER WRI01570
LA R13,4095(R12) AND THE SECOND WRI01580
LA R13,1(R13) WRI01590
* WRI01600
TM FLAGB,CONSCMD REJECT THIS REQUEST IF IT WRI01610
BNO CON10 CAME FROM THE CONSOLE. WRI01620
L R15,AREJECT GO TO REJECT-THIS-COMMAND ROUTINE WRI01630
BALR R14,R15 WRI01640
B WRITEBYE WRI01650
* WRI01660
CON10 DS 0H WRI01670
TM FLAGB,UTSCMD IF IT'S A UTS REQUEST, WRI01680
BO CON50 GO HANDLE THAT. WRI01690
* WRI01700
* THIS IS AN SMSG REQUEST. PARMS ARE SET UP LIKE SO, WRI01710
* SMSGVMID = VM USER ID WHO SENT THIS SMSG WRI01720
* PARM2 = FILE NAME WRI01730
* PARM3 = FILE TYPE WRI01740
* PARM4 = HIS DISK ADDRESS (I.E. 191) WRI01750
* PARM5 = HIS READ PASSWORD FOR THIS DISK WRI01760
* PARM6 = UTS ID WRI01770
* PARM7 = USER UNDER THAT UTS WRI01780
* PARM8 = WHICH DISK FOR THAT USER WRI01790
* PARM9 = WRITE PASSWORD FOR THAT DISK WRI01800
* WRI01810
* LOOP THROUGH THE UTSCB CHAIN TO SEE WHICH UTS THIS GUY IS WRI01820
* REFERENCING. KEY ON THE UTS UNIQUE ID (CBUTSUID). WRI01830
L R4,CBFIRST GET ADDRESS OF FIRST UTSCB WRI01840
UTSLOOPA LTR R4,R4 ARE WE PAST THE END-OF-CHAIN ?? WRI01850
BZ CMSERR1 YEP, WE DIDN'T FIND A MATCH. WRI01860
CLC CBUTSUID,PARM6 ELSE, SEE IF THIS IS THE ONE WRI01870
BE CMSGOTIT YEP, IT IS. CONTINUE ON. WRI01880
L R4,CBUTSFP HAVEN'T FOUND IT YET. WRI01890
B UTSLOOPA GO CHECK THE NEXT ONE. WRI01900
CMSGOTIT DS 0H WRI01910
* PREPARE FOR ACCESS ROUTINE. WRI01920
ST R4,THISUTS SAVE UTSCB ADDRESS WRI01930
MVC THISUSER,PARM7 MOVE IN UTS USER ID WRI01940
MVC THISDISK,PARM8 MOVE IN THE DISK HE WANTED WRI01950
L R15,AACCESS GET ADDRESS OF ACCESS ROUTINE WRI01960
BALR R14,R15 GO FIND ALL THE CONTROL BLOCKS WRI01970
* UPON RETURN, IF THERE WAS AN ERROR, THEN R15 > 0, WRI01980
* ELSE R15 = 0 AND R4, R5, AND R6 ALL POINT TO THE WRI01990
* CORRECT UTSCB, USERCB, AND DISKCB RESPECTIVELY. WRI02000
LTR R15,R15 DID ALL GO OK ?? WRI02010
BZ CON15 IF SO, CONTINUE ON WRI02020
CH R15,=H'8' WRI02030
BE CMSERR2 USER NOT FOUND UNDER THIS UTS WRI02040
CH R15,=H'12' WRI02050
BE CMSERR3 DISK NOT FOUND FOR THIS USER WRI02060
B CMSERR4 SOME OTHER BAD ERROR WRI02070
CON15 DS 0H WRI02080
* NOW CHECK THE WRITE PASSWORD THIS GUY GAVE ME FOR THIS DISK WRI02090
CLC CBDSKWPW,=CL8'ALL' DOES HE REQUIRE A PASSWORD ?? WRI02100
BE CON20 NOPE, CONTINUE ON WRI02110
CLC CBDSKWPW,=CL8'NONE' IS HE ALLOWED TO WRITE ON THIS WRI02120
BE CMSERR5 DISK ?? NOPE, TELL HIM SO WRI02130
CLC CBDSKWPW,PARM9 NOT SPECIAL CASE - COMPARE PASSWORD WRI02140
BNE CMSERR5 PASSWORD IS INCORRECT WRI02150
CON20 DS 0H WRI02160
* LINK TO THIS GUY'S MINIDISK WRI02170
MVC LINK1,SMSGVMID PUT VM USER ID IN LINK COMMAND WRI02180
MVC LINK2,PARM4 INCLUDE HIS DISK ADDRESS WRI02190
MVC LINK3,PARM5 AND HIS READ PASSWORD WRI02200
LA R1,LINKCMD WRI02210
SVC 202 DO THE CP LINK COMMAND WRI02220
DC AL4(*+4) WRI02230
LTR R15,R15 WRI02240
BNZ CMSERR6 BRANCH IF LINK ERROR WRI02250
* NOW ACCESS THIS DISK AS MY Z-DISK WRI02260
LA R1,ACCCMD WRI02270
SVC 202 DO THE ACCESS COMMAND WRI02280
DC AL4(*+4) WRI02290
LTR R15,R15 WRI02300
BNZ CMSERR7 BRANCH IF ACCESS ERROR WRI02310
* WE'RE READY NOW TO DO THE COPY. THE COMMAND IS WRI02320
* COPY FN FT Z = = ? (REPLACE WRI02330
MVC COPY1,PARM2 MOVE FILE NAME INTO COPY COMMAND WRI02340
MVC COPY2,PARM3 DITTO WITH THE FILE TYPE WRI02350
MVC COPY3,PARM8 AND MY ACCESS MODE WRI02360
LA R1,COPYCMD WRI02370
* SVC 202 DO THE COPY COMMAND (SEE THE NOTE WRI02380
* DC AL4(*+4) IN THE PROLOG AS TO WHY WE CALL WRI02390
L R15,=V(DMSCPY) COPYFILE IN THIS WAY) WRI02400
BALR R14,R15 WRI02410
LTR R15,R15 WRI02420
BNZ CMSERR8 BRANCH IF COPY ERROR WRI02430
* NO ERRORS. MESSAGE WILL BE THAT ALL WENT OK. WRI02440
LA R1,CMSMSG0 TELL HIM EVERYTHING WENT OK WRI02450
B CMSBYE WRI02460
CMSERR1 LA R1,CMSMSG1 TELL HIM UTS NOT FOUND WRI02470
B CMSBYE WRI02480
CMSERR2 LA R1,CMSMSG2 TELL HIM USER NOT FOUND FOR THIS UTS WRI02490
B CMSBYE WRI02500
CMSERR3 LA R1,CMSMSG3 TELL HIM DISK NOT FOUND FOR THIS USER WRI02510
B CMSBYE WRI02520
CMSERR4 LA R1,CMSMSG4 TELL HIM ABOUT UNUSUAL ACCESS ERROR WRI02530
B CMSBYE WRI02540
CMSERR5 LA R1,CMSMSG5 TELL HIM HE GAVE THE WRONG PASSWORD WRI02550
B CMSBYE WRI02560
CMSERR6 DS 0H TELL HIM ABOUT THE LINK ERROR WRI02570
L R9,ABUFFER WRI02580
LR R10,R15 MOVE LINK RETURN CODE TO A FREE REG WRI02590
LINEDIT TEXT='ERROR LINKING TO YOUR ........ MINIDISK. LINK R-WRI02600
ETURN CODE IS .....',SUB=(CHARA,PARM4,DEC,(R10)),DISP=NO-WRI02610
NE,BUFFA=(R9),RENT=NO WRI02620
LR R1,R9 WRI02630
B CMSBYE WRI02640
CMSERR7 DS 0H TELL HIM ABOUT THE ACCESS ERROR WRI02650
L R9,ABUFFER WRI02660
LR R10,R15 MOVE ACCESS RETURN CODE TO A FREE REG WRI02670
LINEDIT TEXT='ERROR ACCESSING YOUR ........ MINIDISK. ACCESS -WRI02680
RETURN CODE IS .....',SUB=(CHARA,PARM4,DEC,(R10)),DISP=N-WRI02690
ONE,BUFFA=(R9),RENT=NO WRI02700
LR R1,R9 WRI02710
B CMSBYE WRI02720
CMSERR8 DS 0H TELL HIM ABOUT THE COPY ERROR WRI02730
L R9,ABUFFER WRI02740
LR R10,R15 MOVE COPY RETURN CODE TO A FREE REG WRI02750
LINEDIT TEXT='ERROR COPYING THE FILE OVER. COPY RETURN CODE I-WRI02760
S .....',SUB=(DEC,(R10)),DISP=NONE,BUFFA=(R9),RENT=NO WRI02770
LR R1,R9 WRI02780
* WRI02790
CMSBYE DS 0H WRI02800
* GIVE HIM MESSAGE IN R1, THEN RELEASE AND DETACH HIS DISK. WRI02810
L R15,AMESSAGE GIVE HIM THE MESSAGE POINTED TO BY R1 WRI02820
BALR R14,R15 WRI02830
LA R1,RELCMD WRI02840
SVC 202 DO THE RELEASE Z (DET COMMAND WRI02850
DC AL4(*+4) MAY NOT BE NECESSARY, BUT WHO CARES ?? WRI02860
B WRITEBYE WRI02870
EJECT WRI02880
*********************************************************************** WRI02890
* THIS IS A WRITE REQUEST FROM A UTS. FIRST OF ALL, INITIALIZE * WRI02900
* EVERYTHING. * WRI02910
*********************************************************************** WRI02920
CON50 DS 0H WRI02930
XC UTSPARMS,UTSPARMS CLEAR ALL THE PARMS AT ONCE WRI02940
MVI RITFLAGA,X'00' CLEAR WRITE STATUS FLAG WRI02950
MVI RITFLAGB,X'00' CLEAR THE OTHER ONE WRI02960
CLI PARM4,C'›' WRI02970
BNE NOCENT WRI02980
MVI PARM4,C'#' WRI02990
NOCENT DS 0H WRI03000
* PREPARE FOR ACCESS ROUTINE. WRI03010
MVC THISUSER,PARM0 MOVE IN UTS USER ID WRI03020
MVC THISDISK,PARM6 MOVE IN THE DISK HE WANTED WRI03030
L R15,AACCESS GET ADDRESS OF ACCESS ROUTINE WRI03040
BALR R14,R15 GO FIND ALL THE CONTROL BLOCKS WRI03050
* UPON RETURN, IF THERE WAS AN ERROR, THEN R15 > 0, WRI03060
* ELSE R15 = 0 AND R4, R5, AND R6 ALL POINT TO THE WRI03070
* CORRECT UTSCB, USERCB, AND DISKCB RESPECTIVELY. WRI03080
LTR R15,R15 WRI03090
BNZ ERROR1 GO FIGURE OUT WHAT THE ERROR WAS WRI03100
* NOW CHECK THE WRITE PASSWORD THIS GUY GAVE ME FOR THIS DISK WRI03110
CLC CBDSKWPW,=CL8'ALL' DOES HE REQUIRE A PASSWORD ?? WRI03120
BE CON100 NOPE, CONTINUE ON WRI03130
CLC CBDSKWPW,=CL8'NONE' IS HE ALLOWED TO WRITE ON THIS WRI03140
BE ERROR2 DISK ?? NOPE, TELL HIM SO WRI03150
CLC CBDSKWPW,PARM7 NOT SPECIAL CASE - COMPARE PASSWORD WRI03160
BNE ERROR3 PASSWORD IS INCORRECT WRI03170
CON100 DS 0H WRI03180
* OK, THE PASSWORD CHECKS. NOW MAKE SURE HE'S GIVEN US A VALID WRI03190
* SUBFUNCTION. CHECK FOR CREATE, REPLACE, INCRVL, APPEND, OR DA WRI03200
* (THE DEFAULT IF BLANK, IS CREATE). ANYTHING ELSE WILL BE WRI03210
* REJECTED. ONCE YOU'VE GOT A VALID SUBFUNCTION, DETERMINE THE WRI03220
* FILE NAME TO BE USED AND TAKE CARE OF ANY OTHER PARAMETERS WRI03230
* PECULIAR TO THIS SUBFUNCTION. WRI03240
LA R8,PARM4 GET ADDRESS OF FILE ID (FN FT FM) WRI03250
CLC PARM2,=CL8' ' CHECK FOR DEFAULT OF CREATE WRI03260
BE CON110 WRI03270
CLC PARM2,=CL8'CREATE' CHECK FOR CREATE WRI03280
BNE CON120 NOPE, CHECK NEXT SUBFUNCTION WRI03290
CON110 DS 0H WRI03300
OI RITFLAGB,CREATE THIS IS A CREATE WRITE WRI03310
* SEE IF THERE'S ALREADY A FILE WITH THIS FILE ID. IF SO, THEN WRI03320
* REJECT THIS REQUEST. DO A FSSTATE. THE FSSTATE WILL ALSO WRI03330
* LET US KNOW IF THE FILENAME OR FILETYPE CONTAINS INVALID WRI03340
* CHARACTERS. WRI03350
FSSTATE (R8) DOES THIS FILE EXIST ?? WRI03360
LTR R15,R15 WRI03370
BZ ERROR4 YES, IT DOES. REJECT THIS WRITE. WRI03380
C R15,=F'28' WAS THE FILE NOT FOUND ?? (EXPECTED) WRI03390
BE CON200 YEP, IT WASN'T FOUND. CONTINUE ON WRI03400
C R15,=F'20' INVALID CHARACTER IN FILE ID ?? WRI03410
BE ERROR5 WRI03420
B ERROR6 SOME OTHER FSSTATE ERROR. WRI03430
* CONTINUE CHECKING FOR VALID SUBFUNCTIONS. WRI03440
CON120 DS 0H WRI03450
CLC PARM2,=CL8'REPLACE' CHECK FOR REPLACE WRITE WRI03460
BNE CON130 WRI03470
OI RITFLAGB,REPLACE THIS IS A REPLACE WRITE WRI03480
* DO AN FSERASE FOR THIS FILE ID. IGNORE A RC = 28 = FILE-NOT-FOUND WRI03490
* RETURN CODE. DON'T IGNORE A RC = 20 = INVALID FILE ID RETURN CODE. WRI03500
* FLAG THAT AS AN ERROR. WRI03510
FSERASE (R8) ERASE THE FILE IF IT EXISTS WRI03520
LTR R15,R15 DID THINGS GO OK ?? WRI03530
BZ CON125 YEP, THE FILE DID EXIST WRI03540
C R15,=F'28' WRI03550
BE CON125 IT'S OK IF THE FILE DID NOT EXIST WRI03560
C R15,=F'20' CHECK FOR INVALID FILE ID WRI03570
BE ERROR5 TSK TSK WRI03580
B ERROR7 SOME OTHER ERROR WITH THE FSERASE WRI03590
CON125 DS 0H WRI03600
B CON200 OTHERWISE, EVERYTHING'S GREAT. CONTINUE ON WRI03610
* CONTINUE CHECKING FOR VALID SUBFUNCTIONS. WRI03620
CON130 DS 0H WRI03630
CLC PARM2,=CL8'INCRVL' CHECK FOR WRITE AND INCREMENT WRI03640
BNE CON140 THE VERSION LEVEL WRI03650
OI RITFLAGB,INCRVL THAT'S WHAT THIS IS WRI03660
* THIS IS WHERE I'VE GOT TO WORK. FIRST SEE IF THIS FILE EXISTS OR WRI03670
* NOT. IF IT DOESN'T, FINE - USE THIS FILE ID. WRI03680
* OTHERWISE, FIND THE FIRST BLANK CHARACTER IN THE FILENAME OR THE WRI03690
* FIFTH CHARACTER, WHATEVER COMES FIRST. CHANGE THE FILENAME WRI03700
* FROM HISNAME ==> TO HISNA000 WRI03710
* OR FROM NAME ==> TO NAME000. REMEMBER WHERE THE 000'S START. WRI03720
* NOW, DOES THAT FILE EXIST ?? IF SO, USE THAT FILE ID. WRI03730
* IF NOT, INCREMENT THE 000'S TO 001, THEN 002, ETC. UNTIL YOU FIND WRI03740
* A FILE ID THAT ISN'T BEING USED OR YOU GO PAST 999. IF YOU GO WRI03750
* PAST 999, THEN REJECT THIS WRITE REQUEST (THE BLOODY FOOL'S GOT WRI03760
* 1,001 FILES ON HIS DISK, HE DESERVES THIS 1,002ND TO BE REJECTED). WRI03770
FSSTATE (R8) DOES THIS FILE EXIST ?? WRI03780
C R15,=F'28' WAS THE FILE NOT FOUND ?? (EXPECTED) WRI03790
BE CON139 GOOD, WE CAN USE HIS ORIGINAL FILE ID. WRI03800
C R15,=F'20' IS THIS FILE ID INVALID ?? WRI03810
BE ERROR5 YEP, BAD CHARACTER IN FILENAME OR TYPE. WRI03820
LTR R15,R15 WAS THE FILE FOUND ?? WRI03830
BNZ ERROR6 NO, SOME OTHER FSSTATE ERROR WRI03840
* OK, HIS ORIGINAL FILE ID IS BEING USED BY ANOTHER FILE. WE'RE WRI03850
* GOING TO HAVE TO START LOOPING, CHANGING THE FILENAME, UNTIL WE WRI03860
* FIND AN UNUSED ONE. FIND WHERE TO PUT THE 000'S IN HIS FILE NAME. WRI03870
LA R9,PARM4+1 START AT SECOND CHARACTER OF FILENAME WRI03880
LA R0,1 INCREMENT 1 CHARACTER AT A TIME AND WRI03890
LA R1,PARM4+4 QUIT AFTER THE FOURTH CHARACTER WRI03900
UP2 CLI 0(R9),C' ' FIND THE FIRST BLANK IN THE FILENAME OR WRI03910
BE CON131 THE FIFTH CHARACTER, WHICHEVER COMES FIRST WRI03920
BXLE R9,R0,UP2 WRI03930
CON131 DS 0H NOW, R9 = ADDRESS OF WHERE TO PUT THE 000'S WRI03940
MVC VL,=PL4'0' INITIALIZE VERSION LEVEL COUNTER TO ZEROES WRI03950
CON132 DS 0H WRI03960
UNPK TEMPA,VL UNPACK VERSION LEVEL COUNTER WRI03970
OI TEMPA+7,X'F0' WRI03980
MVC 0(3,R9),TEMPA+5 MOVE IN THE LAST 3 CHARACTERS WRI03990
FSSTATE (R8) CHECK FOR THE EXISTENCE OF THIS FILE WRI04000
LTR R15,R15 IS THIS FILE NAME FREE ?? WRI04010
BNZ CON139 YEP, FINALLY FOUND ONE WE CAN USE. WRI04020
AP VL,=PL1'1' ELSE INCREMENT THE VERSION LEVEL WRI04030
CP VL,=P'999' ARE WE AT THE END YET ?? WRI04040
BNH CON132 NOPE, STILL OK. KEEP CHECKING. WRI04050
B ERROR8 ALL 1,001 FILE ID'S ARE USED UP. REJECT. WRI04060
CON139 DS 0H WRI04070
B CON200 WE'VE GOT THE FILE ID. CONTINUE ON WRI04080
* CONTINUE CHECKING FOR VALID SUBFUNCTIONS. WRI04090
CON140 DS 0H WRI04100
CLC PARM2,=CL8'APPEND' CHECK FOR WRITE AND APPEND WRI04110
BNE CON150 WRI04120
OI RITFLAGB,APPEND WRI04130
* THERE'S NO CHECKING NEEDED HERE. IF THE FILE EXISTS, GREAT, WRI04140
* EVERYTHING'S FINE. IF IT DOESN'T EXIST, THEN THE FILE WILL BE WRI04150
* CREATED. EITHER WAY, THINGS WILL WORK AS EXPECTED. LET THE WRI04160
* FSOPEN MACRO DETERMINE IF THIS FILE ID IS VALID OR NOT. WRI04170
B CON200 EVERYTHING'S GREAT. CONTINUE ON WRI04180
* CONTINUE CHECKING FOR VALID SUBFUNCTIONS. ONE LAST CHANCE. WRI04190
CON150 DS 0H WRI04200
CLC PARM2,=CL8'DA' CHECK FOR DIRECT ACCESS WRITE WRI04210
BNE ERROR9 THAT WAS THE LAST CHANCE, BUB WRI04220
OI RITFLAGB,DA WRI04230
* MAKE SURE THIS FILE EXISTS. IF NOT, HE BLEW IT. WRI04240
* IF IT DOES EXIST, CHECK TO MAKE THIS IS A FIXED LENGTH FILE. WRI04250
* IF NOT, THEN REJECT THIS REQUEST. I'M NOT GOING TO SUPPORT WRI04260
* WRITING IN THE MIDDLE OF A VARIABLE LENGTH FILE. TO MESSY. WRI04270
* IF WE GOT THIS FAR, CHECK THE STARTING RECORD NUMBER. IF BIGGER WRI04280
* THAN THE NUMBER OF RECORDS IN THE FILE BY MORE THAN ONE, THEN WRI04290
* HE BLEW IT (I WILL ALLOW HIM TO START AT THE END OF THE FILE). WRI04300
FSSTATE (R8) DOES THIS FILE EXIST ?? WRI04310
LTR R15,R15 WRI04320
BZ CON151 YES IT DOES. CONTINUE ON. WRI04330
C R15,=F'28' WAS THE FILE NOT FOUND ?? (EXPECTED) WRI04340
BE ERROR10 YES, IT WAS NOT FOUND. WRI04350
C R15,=F'20' INVALID FILE ID ?? WRI04360
BE ERROR5 YEP WRI04370
B ERROR6 SOME OTHER ERROR WITH FSSTATE WRI04380
CON151 DS 0H WRI04390
USING FSTD,R3 R1 IS POINTING TO THE FILE STATUS TABLE WRI04400
LR R3,R1 SHIFT FST BASE REGISTER TO R3 WRI04410
CLI FSTRECFM,C'F' MAKE SURE THIS IS A FIXED-LENGTH FILE WRI04420
BNE ERROR11 WE DON'T HANDLE VARIABLE-LENGTH FILES WRI04430
* CONVERT THE STARTING RECORD NUMBER TO A DECIMAL NUMBER WRI04440
LA R1,PARM10 PARM10 IS THE STARTING RECORD NUMBER WRI04450
L R15,ACONDEC GO TO THE CONVERT-TO-DECIMAL ROUTINE WRI04460
BALR R14,R15 WRI04470
LTR R15,R15 HOW'D THINGS GO ?? WRI04480
BNZ ERROR12 ERROR IF ALL BLANK OR INVALID WRI04490
LTR R0,R0 IF HE SAID START AT RECORD NUMBER 0, WRI04500
BNZ CON154 HE REALLY MEANS START AT RECORD 1 WRI04510
LA R0,1 WRI04520
CON154 EQU * WRI04530
LH R1,FSTRECCT ADD ONE TO THE NUMBER OF RECORDS WRI04540
DROP R3 DON'T NEED THE FST ANYMORE WRI04550
LA R1,1(R1) IN THE FILE. WRI04560
CR R0,R1 IS THE STARTING RECORD NUMBER GREATER WRI04570
BH ERROR13 THAN THE NUMBER OF RECORDS + 1 ?? WRI04580
ST R0,STARTRCD SAVE THE STARTING RECORD NUMBER WRI04590
CON200 EQU * WRI04600
* FIND OUT HOW MANY BYTES ARE COMING OVER. WRI04610
LA R1,PARM3 PARM3 IS THE BYTE COUNT WRI04620
L R15,ACONDEC GO TO THE CONVERT-TO-DECIMAL ROUTINE WRI04630
BALR R14,R15 WRI04640
LTR R15,R15 DID THE BYTE COUNT CONVERT OK ?? WRI04650
BNZ ERROR14 ERROR IF NOT WRI04660
LTR R0,R0 IT'S ALSO INVALID IF ZERO WRI04670
BZ ERROR14 WRI04680
ST R0,BYTECNT IF IT'S OK, THEN STORE IT AWAY WRI04690
* IS THIS INPUT GOING TO BE IN FIXED, VARIABLE, OR SOURCE FORMAT ?? WRI04700
CLI PARM8,C'S' PARM8 DETERMINES INPUT FORMAT WRI04710
BNE CON210 BRANCH IF NOT IN SOURCE FORMAT WRI04720
OI RITFLAGA,SFORMAT ELSE, IT'LL BE IN SOURCE FORMAT WRI04730
B CON212 CONTINUE ON WRI04740
* IS THIS INPUT GOING TO BE IN FIXED OR VARIABLE FORMAT ?? WRI04750
CON210 DS 0H WRI04760
CLI PARM8,C'V' PARM8 DETERMINES FIXED OR VARIABLE WRI04770
BE CON212 BRANCH IF IT'LL BE IN VARIABLE FORMAT WRI04780
OI RITFLAGA,FIXEDUTS ELSE, DEFAULT TO FIXED FORMAT WRI04790
* FIND OUT WHAT THE INPUT DATA'S LRECL (OR BLOCKING FACTOR) IS. WRI04800
LA R1,PARM9 PARM 9 IS THE RECORD BLOCKING FACTOR WRI04810
L R15,ACONDEC GO TO THE CONVERT-TO-DECIMAL ROUTINE WRI04820
BALR R14,R15 WRI04830
LTR R15,R15 DID IT CONVERT OK ?? WRI04840
BNZ ERROR15 ERROR IF NOT WRI04850
LTR R0,R0 IT'S ALSO INVALID IF ZERO WRI04860
BZ ERROR15 WRI04870
ST R0,UTSLRECL IF IT'S OK, THEN STORE IT AWAY WRI04880
CON212 DS 0H WRI04890
* NOW GO GET THE SPECIFIED NUMBER OF BYTES FROM THE UTS. WRI04900
L R0,BYTECNT NUMBER OF BYTES FROM THE UTS WRI04910
L R1,ABUFFER BUFFER ADDRESS WRI04920
L R15,AREADUTS WRI04930
BALR R14,R15 WRI04940
LTR R15,R15 READ WENT OK, DIDN'T IT ?? WRI04950
BNZ WRITEBYE ABORT IF NOT - RETURN TO ICATS WRI04960
* MAINLINE WRI04970
* ESTABLISH THE OUTPUT BUFFER. THIS'LL BE RIGHT AFTER ALL THE WRI04980
* INPUT DATA AND WILL BE USED TO MOVE A RECORD TO, PAD IT TO THE WRI04990
* LRECL OF THE CMS FILE, AND WRITE IT OUT TO THE CMS FILE. WRI05000
L R9,ABUFFER START OF INPUT BUFFER WRI05010
A R9,BYTECNT + NUMBER OF BYTES IN INPUT WRI05020
ST R9,OUTBUFR = START OF OUTPUT BUFFER WRI05030
* OPEN THE CMS FILE. IF THIS HAPPENS TO BE A NEW FILE, THEN WRI05040
* SET UP THE RECORD FORMAT (FIXED OR VARIABLE) AND THE LRECL OF WRI05050
* THE CMS FILE. MAKE IT THE SAME AS THE INPUT DATA FORMAT. WRI05060
IC R10,=C'V' ASSUME VARIABLE LENGTH UNTIL WRI05070
LA R9,0 PROVEN WRONG WRI05080
TM RITFLAGA,FIXEDUTS WAS I RIGHT ?? WRI05090
BNO CON215 YEP, IT IS GOING TO BE VARIABLE WRI05100
IC R10,=C'F' OTHERWISE CHANGE TO FIXED FORMAT WRI05110
L R9,UTSLRECL AND USE THE CORRECT LRECL WRI05120
CON215 DS 0H WRI05130
MVC PADCHAR,PARM6+7 REMEMBER THE PAD CHARACTER WRI05140
* R9 = LOGICAL RECORD LENGTH WRI05150
* R10 = C'F' IF FIXED FORMAT, ELSE C'V' FOR VARIABLE FORMAT WRI05160
FSOPEN (R8),FSCB=MYFSCB,RECFM=(R10),BSIZE=(R9) WRI05170
LTR R15,R15 DID IT WORK ?? WRI05180
BZ CON305 YEA, WE'RE ALL SET. WRI05190
C R15,=F'28' IS THIS A NEW FILE ?? WRI05200
BE CON300 YEP, REMEMBER THAT FACT. WRI05210
C R15,=F'20' INVALID FILE ID ?? WRI05220
BE ERROR5 YEP WRI05230
B ERROR16 NO, SOME OTHER ERROR WITH FSOPEN. WRI05240
CON300 DS 0H WRI05250
OI RITFLAGA,NEW REMEMBER WE'RE CREATING A NEW FILE WRI05260
CON305 DS 0H THE FILE IS OPENED, AND EVERYTHING'S GROOVY WRI05270
USING FSCBD,R15 TEMPORARILY USE R15 AS A FSCB BASE REG WRI05280
LA R15,MYFSCB WRI05290
CLI FSCBFV,C'V' IS THE CMS FILE VARIABLE LENGTH ?? WRI05300
DROP R15 KEEP R15 FREE WRI05310
BE CON310 SKIP NEXT INSTRUCTION IF SO WRI05320
OI RITFLAGA,FIXEDCMS REMEMBER THE CMS FILE IS FIXED WRI05330
CON310 DS 0H WRI05340
* IF THIS IS A DA WRITE, THEN DO A FSPOINT TO START WRITING WRI05350
* AT THE CORRECT STARTING RECORD NUMBER. WRI05360
TM RITFLAGB,DA IS IT A DA WRITE ?? WRI05370
BNO CON400 NOPE, CONTINUE ON. WRI05380
L R9,STARTRCD GET THE STARTING RECORD NUMBER WRI05390
FSPOINT FSCB=MYFSCB,WRPNT=(R9) WRI05400
LTR R15,R15 THERE SHOULD NEVER BE ANY ERROR, WRI05410
BNZ ERROR17 BUT JUST IN CASE .... WRI05420
CON400 DS 0H WRI05430
* WRI05440
* NOW START DOING THE WRITING INTO THE CMS FILE. WRI05450
* WRI05460
L R9,ABUFFER COMPUTE AND SAVE THE ADDRESS OF THE WRI05470
A R9,BYTECNT FIRST BYTE OUTSIDE THE INPUT BUFFER WRI05480
ST R9,EOBUFFER WRI05490
XC RCDCNTR,RCDCNTR SET TOTAL RECORDS WRITTEN IN FILE=0 WRI05500
XC RCDNO,RCDNO SET # RCDS WRITTEN FROM THIS BLOCK=0 WRI05510
TM RITFLAGA,SFORMAT UTS SOURCE FORMAT ?? WRI05520
BO CON410 YES, GO HANDLE THAT FORMAT WRI05530
L R8,BYTECNT INITIALIZE # BYTES LEFT IN INPUT BUFFER WRI05540
L R9,ABUFFER INITIALIZE INPUT BUFFER POINTER WRI05550
B RITELOOP CONTINUE ON WRI05560
CON410 DS 0H WRI05570
L R9,ABUFFER INITIALIZE NEXT BLOCK ADDRESS WRI05580
B CON411 SKIP NEXT LINE FIRST TIME THROUGH WRI05590
DONEXTB DS 0H WRI05600
L R9,NEXTBLOK SET INPUT BUFFER POINTER TO START OF BLOCK WRI05610
CON411 LA R10,1740(R9) COMPUTE ADDRESS OF FOLLOWING BLOCK WRI05620
ST R10,NEXTBLOK REMEMBER START OF NEXT BLOCK WRI05630
MVC SAVERCNT,1722(R9) SAVE COUNT OF # RCDS IN THIS BLOCK WRI05640
LH R8,8(R9) INITIALIZE # BYTES LEFT IN THIS BLOCK WRI05650
SLL R8,1 MULTIPLY BY 2 TO GET BYTE COUNT WRI05660
LA R9,10(R9) SET INPUT BUFFER POINTER TO START OF DATA WRI05670
L R15,RCDNO ADD NUMBER OF RECORDS WRITTEN IN LAST WRI05680
A R15,RCDCNTR BLOCK TO NUMBER OF RECORDS WRITTIN IN WRI05690
ST R15,RCDCNTR THE CMS FILE THUS FAR WRI05700
XC RCDNO,RCDNO RESET # RCDS WRITTEN THIS BLOCK THUS FAR WRI05710
RITELOOP DS 0H WRI05720
C R9,EOBUFFER ARE WE PAST END OF THE INPUT BUFFER ?? WRI05730
BNL EXITLOOP WRI05740
* FIRST FIND THE LENGTH OF THE INPUT RECORD. PUT IN R10 WRI05750
TM RITFLAGA,FIXEDUTS IS THE INPUT IN FIXED FORMAT ?? WRI05760
BNO CON413 NOPE, GO HANDLE VARIABLE LENGTH WRI05770
L R10,UTSLRECL INPUT RECORD LENGTH IS ALWAYS THE SAME WRI05780
B CON419 CONTINUE ON WRI05790
CON413 DS 0H WRI05800
SH R8,=H'2' DECREMENT 2 BYTES FOR RECORD LENGTH WRI05810
BM ERROR18 THERE WASN'T 2 BYTES THERE TO TAKE WRI05820
CLC 0(2,R9),=X'FFFF' IS THIS AN END-OF-BLOCK MARKER ?? WRI05830
BE QUITLOOP ABORT OUT OF THIS WRITE LOOP IF SO WRI05840
TM RITFLAGA,SFORMAT WRI05850
BNO CON414 WRI05860
CLC 0(2,R9),=X'0000' IF SOURCE FORMAT AND I SEE A WRI05870
BE DONEXTB ZERO LENGTH, GO TO NEXT BLOCK. WRI05880
CON414 DS 0H WRI05890
CLC 0(2,R9),=X'0000' IF NOT SOURCE FORMAT & ZERO LENGTH, WRI05900
BE QUITLOOP THEN THAT'S AN END-OF-FILE MARKER. WRI05910
* IF THE HIGH ORDER BIT IN THE RECORD LENGTH IS ON, THEN THIS RECORD WRI05920
* GETS "TABBED" OVER 6 POSITIONS. SO I'LL HAVE TO INSERT THE 6 WRI05930
* BLANKS IN THE RECORD. NOTICE THAT A LENGTH OF X'8000' WILL RESULT WRI05940
* IN A RECORD WITH 6 BLANKS IN IT. WRI05950
TM 0(R9),X'80' IS THE TAB BIT ON IN THE INPUT ?? WRI05960
BNO CON418 NO, CONTINUE ON WRI05970
NI 0(R9),X'7F' TURN IT OFF BEFORE YOU PICK IT UP WRI05980
LH R10,0(R9) GET THE INPUT RECORD'S LENGTH WRI05990
SLL R10,1 MULTIPLY BY 2 TO GET # BYTES IN RECORD WRI06000
LA R10,6(R10) ADD 6 MORE 'CAUSE OF THE BLANKS WRI06010
SH R9,=H'4' BACK UP INPUT BUFFER TO ALLOW FOR BLANKS WRI06020
MVC 0(6,R9),=CL6' ' MOVE IN 6 BLANKS 'CAUSE OF THE TAB WRI06030
LA R8,6(R8) THERE'S 6 MORE BYTES IN INPUT NOW WRI06040
B CON419 WRI06050
CON418 DS 0H IT'S NOT A TABBED VARIABLE LENGTH INPUT RECORD WRI06060
* IT'S JUST A NORMAL ONE. GET THIS RECORD'S LENGTH WRI06070
LH R10,0(R9) WRI06080
SLL R10,1 MULTIPLY BY 2 TO GET # BYTES IN RECORD WRI06090
LA R9,2(R9) BUMP PAST LENGTH IN INPUT STREAM WRI06100
CON419 DS 0H WRI06110
* AT THIS POINT R8 = NUMBER OF BYTES LEFT IN INPUT STREAM AFTER WRI06120
* GETTING THE LENGTH (MIGHT BE ZERO) WRI06130
* R9 = STARTING ADDRESS OF THE INPUT DATA WRI06140
* R10 = NUMBER OF BYTES IN THIS INPUT RECORD WRI06150
C R10,BIGGEST IS THIS THE BIGGEST RECORD THUS FAR ?? WRI06160
BNH CON420 NOPE, DON'T EXCHANGE WRI06170
ST R10,BIGGEST ELSE WE'VE GOT A NEW BIGGEST RECORD WRI06180
CON420 DS 0H WRI06190
* NOW, GET THE OUTPUT RECORD'S LENGTH, WHICH IS GOING TO DEPEND ON WRI06200
* THE CMS FILE'S RECORD FORMAT. WRI06210
LR R7,R10 ASSUME OUTPUT LRECL = INPUT LRECL WRI06220
TM RITFLAGA,FIXEDCMS I.E. ASSUME VARIABLE LENGTH CMS FILE WRI06230
BNO CON421 BRANCH IF I GUESSED RIGHT WRI06240
USING FSCBD,R15 SET UP A FSCB BASE REGISTER WRI06250
LA R15,MYFSCB WRI06260
L R7,FSCBSIZE ELSE PICK UP THE OUTPUT RECORD SIZE WRI06270
DROP R15 KEEP R15 FREE WRI06280
CR R10,R7 IS THE INPUT RECORD > THE OUTPUT RECORD ?? WRI06290
BNH CON421 IF NOT, THEN IT WON'T GET TRUNCATED WRI06300
OI RITFLAGA,TRUNC REMEMBER WE'VE TRUNCATED A RECORD WRI06310
CON421 DS 0H WRI06320
* AT THIS POINT R7 = NUMBER OF BYTES IN THE OUTPUT RECORD WRI06330
* R8 = NUMBER OF BYTES LEFT IN INPUT STREAM AFTER WRI06340
* GETTING THE LENGTH (STILL MIGHT BE ZERO) WRI06350
* R9 = STARTING ADDRESS OF THE INPUT DATA WRI06360
* R10 = NUMBER OF BYTES IN THIS INPUT RECORD WRI06370
* OUTBUFR = STARTING ADDRESS OF THE OUTPUT BUFFER WRI06380
* NOW MOVE THIS INPUT RECORD TO THE OUTPUT BUFFER. IF THE RECORD WRI06390
* IS GOING TO NEED PADDING, THE MVCL INSTRUCTION WILL DO IT FOR US. WRI06400
* WHAT WE'RE DOING IS MOVING THIS RECORD FROM THE INPUT BUFFER, TO WRI06410
* DIRECTLY AFTER THE END OF THE INPUT DATA. FROM THERE, WE'LL WRI06420
* WRITE IT TO THE CMS FILE. WRI06430
* WRI06440
* FOR THE MVCL, WRI06450
* R14 = DESTINATION ADDRESS (OUTBUFR) WRI06460
* R15 = DESTINATION LENGTH (R12) WRI06470
* R0 = SOURCE ADDRESS (R9) WRI06480
* R1 = PAD CHARACTER (PADCHAR) IN THE HIGH ORDER BYTE AND WRI06490
* THE SOURCE LENGTH IN THE OTHER THREE BYTES WRI06500
* (SMALLER OF R10 AND R8). WRI06510
L R14,OUTBUFR GET THE ADDRESS OF THE OUTPUT BUFFER WRI06520
LR R15,R7 AND THE OUTPUT RECORD LENGTH WRI06530
LR R0,R9 SHIFT INPUT RECORD STARTING ADDRESS WRI06540
LR R1,R10 GET LENGTH OF INPUT RECORD WRI06550
CR R10,R8 HAVE WE RUN OUT OF INPUT DATA YET ?? WRI06560
BNH CON422 NOPE, WE'RE STILL OK WRI06570
LR R1,R8 ELSE WE DON'T HAVE ENOUGH INPUT DATA WRI06580
OI RITFLAGA,LASTINC TO COMPLETE THIS OUTPUT RECORD WRI06590
CON422 DS 0H WRI06600
* R1 = LENGTH OF THIS INPUT RECORD. UPDATE OUR INPUT BUFFER WRI06610
SR R8,R1 POINTERS BEFORE PUTTING IN THE PAD CHAR. WRI06620
AR R9,R1 POINT TO THE NEXT INPUT RECORD WRI06630
TM TEST0108,TEST3 WRI06640
BNO GOGO WRI06650
STM R13,R2,JUNK WRI06660
LINEDIT TEXT='MVCL TO ......, LENGTH = ..........',SUB=(HEXA,JUNK+4,DE-WRI06670
CA,JUNK+8),RENT=NO WRI06680
LINEDIT TEXT=' FROM ......, LENGTH = ..........',SUB=(HEXA,JUNK+12,D-WRI06690
ECA,JUNK+16),RENT=NO WRI06700
LM R13,R2,JUNK WRI06710
B GOGO WRI06720
JUNK DS 6F WRI06730
GOGO DS 0H WRI06740
ICM R1,B'1000',PADCHAR GET THE PAD CHARACTER WRI06750
MVCL R14,R0 PREPARE THE OUTPUT RECORD WRI06760
* AT THIS POINT OUTBUFR = STARTING ADDRESS OF THE OUTPUT RECORD WRI06770
* R7 = LENGTH OF THE OUTPUT RECORD WRI06780
* R8 = NUMBER OF BYTES REMAINING IN THE INPUT WRI06790
* BUFFER AFTER THIS INPUT RECORD WRI06800
* (MIGHT BE LESS THAN OR EQUAL TO ZERO) WRI06810
* R9 = ADDRESS OF NEXT INPUT RECORD WRI06820
* (IF THERE IS ONE) WRI06830
* R10 = LENGTH OF THIS INPUT RECORD, BUT IT'S WRI06840
* NOT NEEDED ANYMORE WRI06850
L R3,OUTBUFR WRI06860
TM TEST0108,TEST4 WRI06870
BNO GOGO2 WRI06880
LINEDIT TEXT='I''M GOING TO WRITE ...... BYTES STARTING AT ...-WRI06890
...',SUB=(DEC,(R7),HEX,(R3)),RENT=NO WRI06900
GOGO2 DS 0H WRI06910
TM TEST0108,TEST8 WRI06920
BNO GOGO3 WRI06930
LINEDIT TEXT='THIS IS RECORD NUMBER .... IN THIS BLOCK AND THE-WRI06940
RE''S ..... BYTES LEFT TO DO',SUB=(DECA,RCDNO,DEC,(R8)),-WRI06950
RENT=NO WRI06960
GOGO3 DS 0H WRI06970
FSWRITE FSCB=MYFSCB,BUFFER=(R3),BSIZE=(R7) WRI06980
LTR R15,R15 I TRUST EVERYTHING WENT OK. DID IT ?? WRI06990
BZ CON500 GOOD. WRI07000
C R15,=F'13' WAS THE DISK FULL ?? WRI07010
BE ERROR19 GO HANDLE FULL DISK WRI07020
C R15,=F'20' WAS THE FILE NAME INVALID OR BLANK ?? WRI07030
BE ERROR20 BLANK FILE NAME GETS CAUGHT HERE. WRI07040
C R15,=F'21' WAS THE FILE TYPE INVALID OR BLANK ?? WRI07050
BE ERROR20 BLANK FILE TYPE GETS CAUGHT HERE. WRI07060
C R15,=F'12' IS THIS A READ ONLY DISK, MAYBE ?? WRI07070
BE ERROR21 AH, THAT'S IT. WRI07080
B ERROR22 IT THOSE AREN'T IT, THEN I GIVE UP. WRI07090
CON500 DS 0H WRI07100
L R1,RCDNO BUMP RECORD COUNTER WRI07110
LA R1,1(R1) WRI07120
ST R1,RCDNO WRI07130
TM RITFLAGA,SFORMAT UTS SOURCE FORMAT ?? WRI07140
BO CON510 YES, GO HANDLE THAT FORMAT WRI07150
C R9,EOBUFFER ARE WE PAST END OF THE INPUT BUFFER ?? WRI07160
BL RITELOOP NO, CONTINUE WRITING DATA TO CMS FILE. WRI07170
B EXITLOOP ELSE, EXIT THIS LOOP. WE'RE DONE. WRI07180
CON510 DS 0H WRI07190
CLC RCDNO,SAVERCNT ARE ALL THE RCDS IN THIS BLOCK DONE ?? WRI07200
BNL DONEXTB YES, GO DO THE NEXT BLOCK. WRI07210
LTR R8,R8 IS THERE ANY MORE DATA IN THIS BLOCK ?? WRI07220
BNP DONEXTB NO, GO DO NEXT BLOCK (IF THERE IS ONE). WRI07230
B RITELOOP ELSE, CONTINUE WRITING INTO CMS FILE. WRI07240
* WRI07250
EJECT WRI07260
* WRI07270
QUITLOOP DS 0H WE FOUND A END-OF-FILE OR END-OF-BLOCK WRI07280
LTR R8,R8 DID WE END EXACTLY AT THE END OF THE INPUT? WRI07290
BZ CON600 YES, DON'T CALL IT AN ERROR, ELSE IT'S A WRI07300
MVC RETCODE,=X'00000004' PREMATURE EOF OR EOB WRI07310
CON600 DS 0H WRI07320
EXITLOOP DS 0H WRI07330
TM RITFLAGA,LASTINC IF LAST INPUT RECORD WAS CHOPPED WRI07340
BNO LEAVE WRI07350
CLC RETCODE,=F'0' AND NO OTHER ERROR OCCURRED, WRI07360
BNE LEAVE WRI07370
MVC RETCODE,=X'00000008' LAST INPUT RECORD WAS INCOMPLETE WRI07380
LEAVE DS 0H WRI07390
L R1,RCDNO ADD # RECORDS WRITTEN IN THIS BLOCK TO WRI07400
A R1,RCDCNTR TOTAL # RECORDS WRITTEN TO THIS CMS FILE WRI07410
ST R1,RCDCNTR REMEMBER NEW TOTAL WRI07420
FSCLOSE FSCB=MYFSCB WRI07430
TM TEST0108,TEST5 WRI07440
BNO SKIP2 WRI07450
LINEDIT TEXT='THE FILE JUST WRITTEN WAS ........ ........ .',S-WRI07460
UB=(CHARA,PARM4,CHARA,PARM5,CHARA,PARM6),RENT=NO WRI07470
SKIP2 EQU * WRI07480
* PREPARE REPLY CONTROL BLOCK. YOU'LL ONLY BE HERE IF THINGS WRI07490
* WENT OK WITH NO ERRORS OR PREMATURE END-OF-FILE OR END-OF-BLOCK. WRI07500
* 1) IF THIS WAS A DA WRITE, ASSUME HE'S GOING TO CONTINUE WRI07510
* TO DA WRITE INTO THIS FILE RIGHT AFTER WHERE HE LEFT OFF. WRI07520
* CALCULATE THE STARTING RECORD NUMBER FOR THE NEXT DA WRI07530
* WRITE, WHICH'LL BE THE STARTING RECORD NUMBER FOR THIS WRI07540
* WRITE + THE NUMBER OF RECORDS I WROTE THIS TIME. WRI07550
* CONVERT THIS NUMBER TO EBCDIC AND PUT IT IN PARM10. WRI07560
* 2) IF THIS WASN'T A DA WRITE, REPLACE THE SUBFUNCTION WRI07570
* WITH 'APPEND', ASSUMING HE'LL WANT TO APPEND, OR WRI07580
* CONTINUE TO APPEND, TO THE END OF THIS FILE. WRI07590
* 3) PUT THE CMS FILE'S CHARACTERISTICS (FIXED OR VARIABLE LENGTH, WRI07600
* LRECL, AND NUMBER OF RECORDS) IN PARM14. ALSO PUT THE SIZE WRI07610
* OF THE BIGGEST RECORD I FOUND IN THE INPUT STREAM THERE. WRI07620
* 4) PUT THE RETURN CODE IN PLACE AND SET THE NUMBER OF DATA WRI07630
* BYTES FOLLOWING THIS CONTROL BLOCK TO ZERO, BOTH IN WRI07640
* PARM15. WRI07650
* | | | | | | | | | WRI07660
* | | | | | | | | | WRI07670
* |---------------------------------------------------------------| WRI07680
* | TODAY'S DATE IN MM/DD/YY FORMAT | WRI07690
* |---------------------------------------------------------------| WRI07700
* | CURRENT TIME IN HH:MM:SS FORMAT | WRI07710
* |---------------------------------------------------------------| WRI07720
* | F | V | FREE | CMS FILE | # RECORDS IN | BIGGEST | WRI07730
* | | | LRECL | CMS FILE | INPUT RECORD | WRI07740
* |---------------------------------------------------------------| WRI07750
* | RETCODE | NUMBER OF DATA BYTES FOLLOWING THIS = 0 | WRI07760
* |---------------------------------------------------------------| WRI07770
TM RITFLAGB,DA WRI07780
BO CON900 GO DO WHAT YOU HAVE TO FOR DA WRITE WRI07790
MVC PARM2,=CL8'APPEND' ASSUME NEXT WRITE WILL BE AN APPEND WRI07800
B CON910 WRI07810
CON900 EQU * WRI07820
L R15,STARTRCD COMPUTE THE NEXT STARTING RECORD # WRI07830
A R15,RCDCNTR WRI07840
CVD R15,TEMPA WRI07850
OI TEMPA+7,X'0F' WRI07860
UNPK TEMPB,TEMPA WRI07870
MVC PARM10,TEMPB MOVE IN STARTING RCD # FOR NEXT READ WRI07880
CON910 EQU * WRI07890
LA R8,PARM4 GET ADDRESS OF FILE ID (FN FT FM) WRI07900
FSSTATE (R8) GET THIS FILE'S FST ?? WRI07910
LTR R15,R15 THE FSSTATE SHOULD NEVER FAIL. WE JUST WRI07920
BZ CON915 GOT THROUGH WRITING THIS FILE. BUT IF WRI07930
XC PARM14,PARM14 IT DOES, JUST ZERO OUT PARM14 AND WRI07940
B CON990 CONTINUE ON WRI07950
CON915 EQU * WRI07960
USING FSTD,R1 R1 IS POINTING TO THE FILE STATUS TABLE WRI07970
MVC PARM14(1),FSTRECFM THIS'LL BE C'F' OR C'V' WRI07980
MVC PARM14+2(2),FSTLRECL+2 CMS FILE'S LRECL WRI07990
MVC PARM14+4(2),FSTRECCT # RECORDS IN CMS FILE WRI08000
MVC PARM14+6(2),BIGGEST+2 BIGGEST INPUT RECORD I SAW WRI08010
DROP R1 DON'T NEED THE FST ANYMORE WRI08020
CON990 EQU * WRI08030
* FALL THROUGH TO PUT THE DATE, TIME, AND THE RETURN CODE IN THE WRI08040
* REPLY CONTROL BLOCK, AND THEN GIVE IT TO THE UTS MACHINE. WRI08050
* IF THERE WAS AN ERROR, WE COME TO HERE. WRI08060
* WRI08070
*-------------------------------------------------------------* WRI08080
* GET THE TIME AND DATE FROM CP * WRI08090
*-------------------------------------------------------------* WRI08100
LA R1,CPDATA ADDRESS OF DATA FROM DIAG WRI08110
DIAG R1,R0,X'000C' REQUEST DATE AND TIME FROM CP WRI08120
*-------------------------------------------------------------* WRI08130
* CPDATA IS NOW IN THE FORMAT OF * WRI08140
* DC CL8'MM/DD/YY' * WRI08150
* DC CL8'HH:MM:SS' * WRI08160
* DS 2D THE REST IS JUNK * WRI08170
*-------------------------------------------------------------* WRI08180
MVC PARM12,CPDATA WRI08190
MVC PARM13,CPDATA+8 WRI08200
TM TEST0108,TEST6 WRI08210
BNO SKIP1 WRI08220
LINEDIT TEXT='AFTER ........ RECORDS, THE RETURN CODE IS .....-WRI08230
.',SUB=(DECA,RCDCNTR,HEXA,RETCODE),RENT=NO WRI08240
SKIP1 DS 0H WRI08250
MVC PARM15(2),RETCODE+2 WRI08260
MVC PARM15+2(6),=X'000000000000' WRI08270
LA R0,128 REPLY CONTROL BLOCK = 128 BYTES BIG WRI08280
LA R1,PARM0 STARTING AT PARM0 WRI08290
L R15,AWRITUTS WRI08300
BALR R14,R15 GO GIVE THE REPLY TO THE UTS MACHINE WRI08310
WRITEBYE EQU * WRI08320
LM R0,R14,REGSAVE RESTORE CALLER'S REGISTERS WRI08330
BR R14 WRI08340
EJECT WRI08350
ERROR1 DS 0H WRI08360
* WE GOT AN ERROR FROM THE ACCESS ROUTINE. WRI08370
* IF R15 = 04, THEN THIS UTS WAS NOT FOUND IN THE UTSCB CHAIN WRI08380
* (CAN NEVER HAPPEN). RETCODE = X'6004' WRI08390
* IF R15 = 08, THEN THIS USER WAS NOT FOUND IN THE USERCB CHAIN WRI08400
* FOR THIS UTS. RETCODE = X'4004' WRI08410
* IF R15 = 12, THEN THIS DISK WAS NOT FOUND IN THE DISKCB CHAIN WRI08420
* FOR THIS USER. RETCODE = X'100C' WRI08430
* IF R15 = 16, THEN THE DISK WAS FOUND, BUT THERE'S NOT A MINIDISK WRI08440
* AT THAT ADDRESS (CONFIGURATION ERROR). WRI08450
* RETCODE = X'4008' WRI08460
* IF R15 = 20, THEN SOME OTHER ERROR HAPPENED IN THE ACCESS WRI08470
* ROUTINE. RETCODE = X'5004' WRI08480
* IF R15 = ??, THEN PROGRAMMING ERROR. RETCODE = X'7004' WRI08490
OI RITFLAGA,ERROR YES, WE HAD AN ERROR WRI08500
C R15,=F'4' WRI08510
BNE ERR1A WRI08520
MVC RETCODE,=X'00006004' UTS NOT FOUND (CAN'T HAPPEN) WRI08530
B ERR1BYE WRI08540
ERR1A C R15,=F'8' WRI08550
BNE ERR1B WRI08560
MVC RETCODE,=X'00004004' USER NOT FOUND IN USERCB CHAIN WRI08570
B ERR1BYE WRI08580
ERR1B C R15,=F'12' WRI08590
BNE ERR1C WRI08600
MVC RETCODE,=X'0000100C' DISK NOT FOUND IN DISKCB CHAIN WRI08610
B ERR1BYE WRI08620
ERR1C C R15,=F'16' WRI08630
BNE ERR1D WRI08640
MVC RETCODE,=X'00004008' NO MINIDISK AT THAT ADDRESS WRI08650
B ERR1BYE WRI08660
ERR1D C R15,=F'20' WRI08670
BNE ERR1E WRI08680
MVC RETCODE,=X'00005004' OTHER ERROR IN ACCESS ROUTINE WRI08690
B ERR1BYE WRI08700
ERR1E MVC RETCODE,=X'00007004' PROGRAMMING ERROR WRI08710
ERR1BYE B CON990 WRI08720
EJECT WRI08730
ERROR2 DS 0H WRI08740
* THIS GUY ISN'T ALLOWED TO WRITE ON THIS DISK. IT PROBABLY IS A WRI08750
* READ ONLY DISK (I.E. THE WRITE PASSWORD = 'NONE'). REJECT THIS WRI08760
* WRITE REQUEST WITH A RETURN CODE = X'2004' WRI08770
MVC RETCODE,=X'00002004' WRI08780
B CON990 WRI08790
SPACE 3 WRI08800
ERROR3 DS 0H WRI08810
* THIS GUY GAVE ME THE WRONG PASSWORD FOR THIS DISK. REJECT THIS WRI08820
* WRITE REQUEST WITH A RETURN CODE = X'1010' WRI08830
MVC RETCODE,=X'00001010' WRI08840
B CON990 WRI08850
SPACE 3 WRI08860
ERROR4 DS 0H WRI08870
* HE TOLD ME TO CREATE THIS FILE BUT THE FILE ALREADY EXISTS. WRI08880
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'201C' WRI08890
MVC RETCODE,=X'0000201C' WRI08900
B CON990 WRI08910
SPACE 3 WRI08920
ERROR5 DS 0H WRI08930
* THE FILE ID (FILE NAME OR FILE TYPE) HE GAVE ME HAS AN INVALID WRI08940
* CHARACTER IN IT. REJECT THIS REQUEST WITH A RETURN CODE = X'1008' WRI08950
MVC RETCODE,=X'00001008' WRI08960
B CON990 WRI08970
SPACE 3 WRI08980
ERROR6 DS 0H WRI08990
* WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSSTATE WRI09000
* MACRO. REPORT THE ERROR WITH A RETURN CODE = X'5008' WRI09010
MVC RETCODE,=X'00005008' WRI09020
B CON990 WRI09030
SPACE 3 WRI09040
ERROR7 DS 0H WRI09050
* WE GOT SOME KIND OF ERROR WITH THE FSERASE MACRO. WRI09060
* FIRST CHECK FOR A RETURN CODE = 36 = THIS IS A READ ONLY DISK. WRI09070
* IF SO, REPORT THE ERROR WITH A RETURN CODE = X'400C' WRI09080
* ELSE, IT'S A RETURN CODE = X'501C' WRI09090
C R15,=F'36' CHECK FOR READ ONLY DISK WRI09100
BE ERR7CONT GOTCHA WRI09110
MVC RETCODE,=X'0000501C' WHO KNOWS WHAT IT IS ?? WRI09120
B CON990 WRI09130
ERR7CONT MVC RETCODE,=X'0000400C' WRI09140
B CON990 WRI09150
SPACE 3 WRI09160
ERROR8 DS 0H WRI09170
* I COULDN'T FIND AN UNUSED FILENAME FOR THIS INCRVL WRITE REQUEST. WRI09180
* THE FOOL'S GOT OVER 1000 FILES ON THIS DISK ALL STARTING WITH THE WRI09190
* SAME CHARACTERS. REPORT THE ERROR WITH A RETURN CODE = X'2018' WRI09200
MVC RETCODE,=X'00002018' WRI09210
B CON990 WRI09220
SPACE 3 WRI09230
ERROR9 DS 0H WRI09240
* INVALID SUBFUNCTION IN THIS REQUEST CONTROL BLOCK. HE'S GOT WRI09250
* 'WRITE' IN THE FUNCTION PARM (PARM1), BUT PARM2 IS NOT BLANK, WRI09260
* 'CREATE', 'REPLACE', 'INCRVL', 'APPEND', OR 'DA'. REJECT THIS WRI09270
* WRITE REQUEST WITH A RETURN CODE = X'101C' WRI09280
MVC RETCODE,=X'0000101C' WRI09290
B CON990 WRI09300
SPACE 3 WRI09310
ERROR10 DS 0H WRI09320
* HE TRIED TO DO A DA WRITE AND THE CMS FILE DOES NOT EXIST. WRI09330
* WHAT CAN I DO NOW, BUT REJECT THIS WRITE REQUEST ?? WRI09340
* RETURN CODE = X'2008' WRI09350
MVC RETCODE,=X'00002008' WRI09360
B CON990 WRI09370
SPACE 3 WRI09380
ERROR11 DS 0H WRI09390
* HE TRIED TO DO A DA WRITE INTO A VARIABLE LENGTH CMS FILE. I WRI09400
* DON'T WANT TO SUPPORT THIS CAPABILITY. IF HE WANTS TO DO THIS, WRI09410
* HE SHOULD MAKE THE CMS FILE FIXED LENGTH, NOT VARIABLE LENGTH. WRI09420
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'2014' WRI09430
MVC RETCODE,=X'00002014' WRI09440
B CON990 WRI09450
SPACE 3 WRI09460
ERROR12 DS 0H WRI09470
* THIS IS A DA WRITE AND THE STARTING RECORD NUMBER IS MISSING OR WRI09480
* INVALID. I DON'T WANT TO DEFAULT TO THE BEGINNING OR THE END OF WRI09490
* THE FILE, 'CAUSE IF HE WENT TO THE TROUBLE TO DO A DA WRITE, THEN WRI09500
* I'M NOT GOING TO TRY TO SECOND GUESS HIM. JUST REJECT THIS WRITE WRI09510
* REQUEST WITH A RETURN CODE = X'1014' WRI09520
MVC RETCODE,=X'00001014' WRI09530
B CON990 WRI09540
SPACE 3 WRI09550
ERROR13 DS 0H WRI09560
* THIS IS A DA WRITE AND THE STARTING RECORD NUMBER IS LARGER THAN WRI09570
* THE NUMBER OF RECORDS IN THIS CMS FILE + 1 (THAT + 1 IS TO ALLOW WRI09580
* HIM TO DA WRITE AFTER THE END OF THIS FILE (I.E. APPEND)). WRI09590
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'200C' WRI09600
MVC RETCODE,=X'0000200C' WRI09610
B CON990 WRI09620
SPACE 3 WRI09630
ERROR14 DS 0H WRI09640
* PARM3, THE NUMBER OF BYTES THE UTS IS GOING TO SEND OVER IS WRI09650
* MISSING OR INVALID. WRI09660
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'1004' WRI09670
MVC RETCODE,=X'00001004' WRI09680
B CON990 WRI09690
SPACE 3 WRI09700
ERROR15 DS 0H WRI09710
* THE UTS INPUT WAS GOING TO BE IN FIXED LENGTH FORMAT AND PARM9, WRI09720
* THE LRECL OF THE INPUT, WAS INVALID, MISSING, OR ZERO. WRI09730
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'1018' WRI09740
MVC RETCODE,=X'00001018' WRI09750
B CON990 WRI09760
SPACE 3 WRI09770
ERROR16 DS 0H WRI09780
* WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSOPEN WRI09790
* MACRO. REPORT THE ERROR WITH A RETURN CODE = X'500C' WRI09800
MVC RETCODE,=X'0000500C' WRI09810
B CON990 WRI09820
SPACE 3 WRI09830
ERROR17 DS 0H WRI09840
* WE GOT SOME KIND OF ERROR I DON'T UNDERSTAND WITH THE FSPOINT WRI09850
* MACRO. THIS SHOULDN'T EVER HAPPEN 'CAUSE I CHECK FOR ALL WRI09860
* POSSIBLE ERRORS BEFORE I DO A FSPOINT. WRI09870
* REPORT THE ERROR WITH A RETURN CODE = X'600C' WRI09880
MVC RETCODE,=X'0000600C' WRI09890
B CON990 WRI09900
SPACE 3 WRI09910
ERROR18 DS 0H WRI09920
* I WAS GOING THROUGH THE VARIABLE LENGTH INPUT AND EVERYTHING WRI09930
* WAS FINE, UNTIL I CAME TO THE END OF THE INPUT AND THERE WAS WRI09940
* ONLY 1 BYTE LEFT. NOT ENOUGH TO PICK UP THE LENGTH OF THE WRI09950
* NEXT RECORD. REPORT THIS CONDITION WITH A RETURN CODE = X'2010' WRI09960
MVC RETCODE,=X'00002010' WRI09970
B LEAVE WRI09980
SPACE 3 WRI09990
ERROR19 DS 0H WRI10000
* I FOUND OUT THIS DISK IS FULL WHEN I TRIED TO DO A WRITE TO IT. WRI10010
* REPORT THIS ERROR WITH A RETURN CODE = X'5024' WRI10020
MVC RETCODE,=X'00005024' WRI10030
B LEAVE WRI10040
SPACE 3 WRI10050
ERROR20 DS 0H WRI10060
* THE FSWRITE DETECTED AN INVALID FILE ID (EITHER FILE NAME OR FILE WRI10070
* TYPE). THIS ERROR SHOULD HAVE ALREADY BEEN CAUGHT BEFORE A WRITE WRI10080
* WAS ATTEMPTED TO THIS FILE, BUT A BLANK FN OR FT DOES GET THIS WRI10090
* FAR. REJECT THIS REQUEST WITH A RETURN CODE = X'1008' AND GO TO WRI10100
* LEAVE TO CLOSE THE FILE, NOT CON990 LIKE ERROR5 DID. WRI10110
MVC RETCODE,=X'00001008' WRI10120
B LEAVE WRI10130
SPACE 3 WRI10140
ERROR21 DS 0H WRI10150
* THIS GUY TRIED TO WRITE TO A FILE THAT I ONLY HAVE READ ACCESS WRI10160
* TO. IT'S ONLY A READ ONLY DISK TO ME, SO IT CAN'T BE READ/WRITE WRI10170
* TO HIM. THIS IS A CONFIGURATION ERROR, SINCE THIS DISK SHOULDN'T WRI10180
* HAVE BEEN ALLOCATED TO THIS GUY IN R/W MODE IN THE FIRST PLACE. WRI10190
* REJECT THIS WRITE REQUEST WITH A RETURN CODE = X'400C' AND WRI10200
* GO TO LEAVE TO CLOSE THE FILE. WRI10210
MVC RETCODE,=X'0000400C' WRI10220
B LEAVE WRI10230
SPACE 3 WRI10240
ERROR22 DS 0H WRI10250
* I GOT SOME OTHER KIND OF ERROR (NOT ANY OF THE ABOVE) FROM THE WRI10260
* FSWRITE MACRO. REPORT THIS ERROR WITH A RETURN CODE = X'5020' WRI10270
MVC RETCODE,=X'00005020' WRI10280
B LEAVE WRI10290
EJECT WRI10300
CPDATA DS 4D FOR CP TO PUT THE CURRENT DATE AND TIME WRI10310
REGSAVE DS 15F READ ROUTINE SAVE AREA WRI10320
SAVEAREA DS 20F MY SAVE AREA FOR WHEN I CALL OTHER SUBROUTINES WRI10330
UTSPARMS DS CL32 SENT TO THE UTS IN THE REPLY CONTROL BLOCK WRI10340
ORG UTSPARMS WRI10350
STARTRCD DS F STARTING RECORD NUMBER IN THE CMS FILE WRI10360
BYTECNT DS F NUMBER OF BYTES THE UTS WILL SEND WRI10370
UTSLRECL DS F LRECL OF FIXED-LENGTH UTS DATA WRI10380
RETCODE DS F RETURN CODE WRI10390
RCDCNTR DS F TOTAL # RECORDS I'VE WRITTEN IN FILE WRI10400
RCDNO DS F # RECORDS WRITTEN FROM THIS BLOCK WRI10410
BIGGEST DS F BIGGEST RECORD SIZE IN INPUT STREAM WRI10420
NEXTSR# DS F STARTING RECORD NUMBER FOR THE NEXT WRITE WRI10430
ORG WRI10440
TEMPA DS D TEMPORARY WORK AREAS FOR UNPACKING, ETC WRI10450
TEMPB DS D TEMPORARY WORK AREAS FOR UNPACKING, ETC WRI10460
LINKCMD DC CL8'CP' WRI10470
DC CL8'LINK' WRI10480
LINK1 DS CL8 I.E. CP LINK JASPER 191 5FF RR PSWD WRI10490
LINK2 DS CL8 WRI10500
DC CL8'5FF' WRI10510
DC CL8'RR' WRI10520
LINK3 DS CL8 WRI10530
DC 8X'FF' WRI10540
ACCCMD DC CL8'ACCESS' I.E. ACCESS 5FF Z WRI10550
DC CL8'5FF' WRI10560
DC CL8'Z' WRI10570
DC 8X'FF' WRI10580
COPYCMD DC CL8'COPYFILE' WRI10590
COPY1 DS CL8 I.E. COPY ICATS ASSEMBLE Z = = C WRI10600
COPY2 DS CL8 WRI10610
DC CL8'Z' WRI10620
DC CL8'=' WRI10630
DC CL8'=' WRI10640
COPY3 DS CL8 WRI10650
DC CL8'(' WRI10660
DC CL8'REPLACE' WRI10670
DC 8X'FF' WRI10680
RELCMD DC CL8'RELEASE' I.E. RELEASE 5FF (DETACH WRI10690
DC CL8'5FF' WRI10700
DC CL8'(' WRI10710
DC CL8'DET' WRI10720
DC 8X'FF' WRI10730
* WRI10740
OUTBUFR DS F STARTING ADDRESS OF THE OUTPUT BUFFER WRI10750
NEXTBLOK DS F ADDRESS OF NEXT SOURCE FORMAT INPUT BLOCK WRI10760
EOBUFFER DS F ADDRESS OF LAST BYTE IN INPUT BUFFER + 1 WRI10770
VL DS PL4 WRI10780
SAVERCNT DS H COUNT OF # RECORDS IN THIS SOURCE FORMAT BLOCK WRI10790
PADCHAR DS C PAD CHARACTER IN CASE WE'RE WRITING A FIXED WRI10800
* LENGTH CMS FILE AND THIS INPUT RECORD LENGTH WRI10810
* IS LESS THAN THE CMS FILE'S LRECL WRI10820
CMSMSG0 DC AL1(CMSMSG0E) WRI10830
DC C'FILE COPIED O.K.' WRI10840
CMSMSG0E EQU *-CMSMSG0-1 WRI10850
* WRI10860
CMSMSG1 DC AL1(CMSMSG1E) WRI10870
DC C'INVALID UTS ID SPECIFIED.' WRI10880
CMSMSG1E EQU *-CMSMSG1-1 WRI10890
* WRI10900
CMSMSG2 DC AL1(CMSMSG2E) WRI10910
DC C'USER NOT FOUND FOR THAT UTS' WRI10920
CMSMSG2E EQU *-CMSMSG2-1 WRI10930
* WRI10940
CMSMSG3 DC AL1(CMSMSG3E) WRI10950
DC C'DISK NOT FOUND FOR THAT USER' WRI10960
CMSMSG3E EQU *-CMSMSG3-1 WRI10970
* WRI10980
CMSMSG4 DC AL1(CMSMSG4E) WRI10990
DC C'GOT SOME BAD ERROR ACCESSING THAT USER''S DISK' WRI11000
CMSMSG4E EQU *-CMSMSG4-1 WRI11010
* WRI11020
CMSMSG5 DC AL1(CMSMSG5E) WRI11030
DC C'WRONG WRITE PASSWORD GIVEN' WRI11040
CMSMSG5E EQU *-CMSMSG5-1 WRI11050
* WRI11060
RITFLAGA DC X'00' STATUS FLAG FOR WRITE ROUTINE WRI11070
FIXEDCMS EQU X'80' 1 = THE CMS FILE HAS FIXED LENGTH RECORDS WRI11080
* ELSE IT HAS VARIABLE LENGTH RECORDS WRI11090
FIXEDUTS EQU X'40' 1 = THE INPUT DATA IS IN UTS FIXED WRI11100
* FORMAT ELSE IT'S IN VARIABLE FORMAT WRI11110
TRUNC EQU X'20' 1 = TRUNCATION OF INPUT DATA HAS OCCURRED WRI11120
LASTINC EQU X'10' 1 = THE LAST INPUT RECORD WAS INCOMPLETE WRI11130
NEW EQU X'08' 1 = I'M CREATING A NEW FILE WRI11140
ERROR EQU X'04' 1 = I GOT SOME KIND OF ERROR WRI11150
SFORMAT EQU X'02' 1 = THIS INPUT IS IN UTS SOURCE FORMAT WRI11160
* WRI11170
RITFLAGB DC X'00' ANOTHER FLAG FOR THE WRITE ROUTINE WRI11180
CREATE EQU X'80' 1 = THIS IS A CREATE WRITE WRI11190
REPLACE EQU X'40' 1 = THIS A WRITE AND REPLACE WRI11200
INCRVL EQU X'20' 1 = THIS IS A WRITE AND INCREMENT THE WRI11210
* VERSION LEVEL WRI11220
APPEND EQU X'10' 1 = THIS IS A WRITE AND APPEND WRI11230
DA EQU X'08' 1 = THIS IS A DIRECT ACCESS WRITE WRI11240
MYFSCB FSCB WRI11250
FSCBD WRI11260
WRITE CSECT GO BACK TO NORMAL CSECT WRI11270
LTORG WRI11280
* WRI11290
FSTD WRI11300
WRITE CSECT GO BACK TO NORMAL CSECT WRI11310
ICDATA WRI11320
END WRI11330