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