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