|
|
|
|
|
|
|
|
|
|
370 Assembler Language Program Code |
|---|
|
This is program 7 in the system that unloads and restores
DASD between 2 physical locations.
It executes as the second step in the unload
job to dynamically build the restore job
JCL. |
DBR7JCLR START 0
DBR7JCLR AMODE 31
DBR7JCLR RMODE 24
SAVE (14,12)
LR R12,R15
USING DBR7JCLR,R12
LA R11,4095(,R12)
LA R11,1(,R11)
USING DBR7JCLR+4096,R11
ST R0,ADRPSA
B GETTCB
CODE314 DC F'314'
CODE1217 DC F'1217'
*
* The program inputs and processes the following
* DBR7OUT1 = restore data set name for copy 1
* DBR7OUT2 = restore data set name for copy 2
* DBR7BK1 = backup data set name for copy 1
* DBR7BK2 = backup data set name for copy 2
* JNAMREST = character 1 of the restore jobname
* %VOL% = insert the DASD volser where string
* is in the output data set name mask
*
* Get the Task Control Block address and save it
*
GETTCB DS 0H
USING PSA,R0
L R8,PSATOLD
DROP R0
ST R8,ADRTCB
* Get core for the save area and program work area
*
LR R10,R13
L R9,0(R1)
LA R0,WAREAEND-WAREABGN
GETMAIN R,LV=(0),LOC=(BELOW)
LR R13,R1
USING WAREABGN,R13
*
* R13 = Address program save area and program work area
* Chain the save areas and initialize the work area
*
ST R10,WSAVE+4
ST R13,8(R10)
MVC WSNAPBGN,=CL8'WSNAPBGN'
MVC WEND,=CL8'WAREAEND'
LA W2,WXBGN-WAREABGN(,R13)
LA R4,XAREABGN
L R3,=A(WXEND-WXBGN)
LR R5,R3
MVCL R2,R4
LA R2,WEPAAREA-WAREABGN(,R13)
ST R2,WEPAADDR
LA R2,WJCLIN
*
* Set the end of file address
* Initialize the CAMLST macro
*
USING IHADCB,R2
LA R3,EOJCLIN
STCM R3,B'0111',DCBEODAD+1
DROP R2
*
LA R2,WCAMDSN
ST R2,WCAMLST-WAREABGN+CAMDSN(R13)
LA R2,WCAMAREA
ST R2,WCAMLST-WAREABGN+CAMAREA(R13)
EJECT
*
* Register equates
*
R0 EQU 0
R1 EQU 1
R2 EQU 2
R3 EQU 3
R4 EQU 4
R5 EQU 5
R6 EQU 6
R7 EQU 7
R8 EQU 8
R9 EQU 9
R10 EQU 10
R11 EQU 11 Base register 2
R12 EQU 12 Base register 1
R13 EQU 13 Program save area and work area address
R14 EQU 14
R15 EQU 15
*
MSG14 DS F
RTN14 DS F
ADRPSA DS A
ADRPARM DS A
*
DBRTABLE DS 0F Where to go table
DC AL1(8),AL1(0),AL2(0),A(PBK1),CL12'DBR7BK1='
DBRENTB DC AL1(8),AL1(DBRNREQ),AL2(0),A(PBK2),CL12'DBR7BK2='
DC AL1(9),AL1(0),AL2(0),A(POUT1),CL12'DBR7OUT1='
DBRENTO DC AL1(9),AL1(DBRNREQ),AL2(0),A(POUT2),
DC CL12'DBR7OUT2
DC AL1(9),AL1(0),AL2(0),A(PJREST),CL12'JNAMREST='
DC AL1(0)
*
DBRPARM DCB DDNAME=DBRPARM,DSORG=PS,MACRF=(GL),EODAD=EOPARM
DBRCLC CLC 0(0,R1),DBRCON-DBRENT(R6)
*
PARMFLAG DC X'00' Indicates 1 or 2 outputs
PARMMISS EQU B'10000000' Required parm missing
*
PARMTRL EQU B'00000001' We are trailing programs
*
PASSFLAG DC X'00"
PASSOUT2 EQU B'10000000' We have 2 output data sets
PASSBK2 EQU B'01000000' We have 2 backup data sets
PASSDUP EQU B'00100000' ON when doing 2 outputs
PASS2 EQU B'00010000' ON when doing 2nd pass
*
SAVOUT1L DC H'0' Restore dsname #1 len
SAVOUT1C DC CL44' ' Restore dsname #1
SAVOUT2L DC H'0' Restore dsname #2 len
SAVOUT2C DC CL44' ' Restore dsname #2
*
SAVBK1L DC H'0' Backup dsname #1 len
SAVBK1C DC CL44' ' Backup dsname #1
SAVBK2L DC H'0' Backup dsname #2 len
SAVBK2C DC CL44' ' Backup dsname #2
*
WRKBK1L DC H'0' Full dsname #1 len
WRKBK1C DC CL44' ' Full dsname #1
WRKBK2L DC H'0' Full dsname #2 len
WRKBK2C DC CL44' ' Full dsname #2
*
*
EJECT
*
* Begin main program processing
*
BEGIN DS 0H
MVI JOB1CHAR,JOB1REST Set default jobname char
OI PARMFLAG,PARMTRL Indicate we are trailing the
OPEN (DBRPARM,(INPUT)) system
*
DBR7GET DS 0H
GET DBRPARM Read a record
ST R1,ADRPARM Save record address
LA R5,DBRPARM Get address data DCB
USING IHADCB,R5 Addressability
LH R5,DCBLRECL Length of input record
DROP R5
*
* Skip comment lines, blank lines and leading blanks
*
DBR7C DS 0H
CLI 0(R1),C'*'
BE DBR7GET
DBR7D DS 0H
CLI 0(R1),C' '
BNE DBR7D1
LA R1,0(,R1)
BCT R5,DBR7D
B DBR7GET
*
* At this point the register contents are as follows:
* R1 = A(1st nonblank character on this record at entry)
* R5 = Remaining number of characters in input record
* R6 = A(DBRTABLE entry)
*
DBR7D1 DS 0H
LA R6,DBRTABLE
USING DBRENT,R6
DBR7E DS 0H
CLI DBRLEN,0 End of table
BE DBR7GET Yes. Get next input
SR R3,R3
IC R3,DBRLEN Length of table parameter
BCTR R3,R0 Minus 1 for CLC
EX R3,DBRCLC Is parameter in table
BE DBR7F Yes.
LA R6,DBRENTL(,R6) No. next table entry
B DBR7E Compare it to the next entry
*
* Branch here when the parameter is in the table
* R5 = Number of characters left in the input record
* R1 = A(first parameter character)
*
DBR7F DS 0H
SR R5,R3 # input bytes-parmlen-1
BCTR R5,R0 -1 from input = parm len
C R5,=A(0) Any input left?
BH DBR7G No. nothing after constant
B DBR7GET nothing after constant
DBR7G DS 0H
LA R1,1(R3,R1) A(last constant char + 1)
L R15,DBRWTG A(routine to process parm)
BALR R14,R15 Go process parm and return
B DBR7GET Get next parm until EOF
*
* Come here when it is the end of the input parm dataset
* Test if any required parameter was missing
* If a required parameter is missing, then it is an error
*
EOPARM DS 0H
CLOSE (DBRPARM)
LA R6,DBRTABLE First entry in parm table
EOPARM1 DS 0H
CLI DBRLEN,0 End of parameter table
BE EOPARM3 Yes. chk for all parms
TM DBRFLAG,DBRIN Was this parameter processed
BO EOPARM2 Yes.
TM DBRFLAG,DBRNREQ No. is this parm required
BO EOPARM2 No. so its OK
BAL R14,DBR7ERR2 Yes. we need this parm
EOPARM2 DS 0H
LA R6,DBRENTL(,R6) Next entry in the table
B EOPARM1
EOPARM3 DS 0H
TM PARMFLAG,PARMMISS Got all required parms
BO CATEXIT No. exit the program
TM PASSFLAG,PASSOUT2+PASSBK2 Want 2 outputs
BNO EOPARMS No. only 1 data set
BM EOPARM4 ON/OFF mixed flags
OI PASSFLAG,PASSDUP ON/ON set duplicate copy
B EOPARMS and parms are done
EOPARM4 DS 0H
TM PASSFLAG,PASSOUT2 Is output only flag on
BNO EOPARM5 No.
LA R6,DBRENTB DBR7BK2= is missing
B EOPARM6
EOPARM5 DS 0H
LA R6,DBRENT0 DBR7OUT2= is missing
EOPARM6 DS 0H
BAL R14,DBR7ERR2 Display missing parm err
WTO 'DBR00020: DBR7OUT2 AND DBR7BK2 ARE REQUIRED FOR
BACKUP DATA SETS'
LA R15,CODE554 End program with RC=554
B CATEXIT
CODE554 EQU 554
*
* This code processes the DBR7OUT1 = parameter to build
* the data set name for the first copy of the restore
* dataset
* At entry to this routine
* R1 = A(parameter character 1)
* R5 = Number of bytes left in the input record
*
POUT1 DS 0H
STM R0,R15,RTNSAVE Save all registers at entry
DBR7OUT DS 0H
LA R2,L'SAVOUT1C Maximum chars in dsname
LA R3,SAVOUT1C Where to move the dsname
SR R4,R4 Clear the length register
DBR7OUT1 DS 0H
STCM R4.B'0011',SAVOUT1L Save data set name length
LTR R5,R5 is the length exhausted
BZ DBR7OUT2 Yes.
CLI 0(R1),C' ' End of input parameter
BE DBR7OUT2 Yes.
LTR R2,R2 Max dsname length reached
BP *+16 No.
BAL R14,DBR7ERR1 Yes. it is an error
LA CODE555 Exit with return code 555
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of the data set
LA R3,1(,R3) +1 to receiving address
LA R1,1(,R1) +1 to sending address
LA R4,1(,R4) +1 to receiving field length
BCTR R2,R0 -1 from maximum dsname len
BCTR R5,R0 -1 from input length
B DBR7OUT1 Loop to process next char
*
* Here after we moved the data set name to add ending
* comma
*
DBR7OUT2 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT1L
LTR R4,R4
BP *+16
BAL R14,DBR7ERR1 Whoops, we have a bad length
LA R15,CODE555 Return with condition code 5
B CATEXIT
MVI 0(R3),C'.' End the name with a period
LA R4,1(,R4) +1 to receiving length
STCM R4,B'0011',SAVOUT1L Save dsname length
LM R0,R15,RTNSAVE Restore the registers
BR R14 and return to the caller
*
* This code processes the DBR7OUT2 = parameter
* to build the data set name for the second restore
* data set, if the user wants 2 copies of output
* data set.
*
POUT2 DS 0H
STM R0,R15,RTNSAVE
DBR7OU2 DS 0H
LA R2,L'SAVOUT2C Max dsname chars allowed
LA R3,SAVOUT2C A(more-to dsname)
SR R4,R4 0 to dsname len
DBR7OU21 DS 0H
STCM R4,B'0011',SAVOUT2L Save data set name length
LTR R5,R5 Is there more input
BZ DBR7OU22 No. input is exhausted
CLI 0(R1),C' ' Input ended with a blank
BE DBR7OU22 Yes.
LTR R2,R2 Max # chars reached
BP *+16 No. not max
BAL R14,DBR7ERR1 Yes. is error
LA R15,CODE555 RC=555
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of dsname
LA R3,1(,R3) A(next dsname char)
LA R1,1(,R1) A(next char in input)
LA R4,1(,R4) +1 moved dsname len
BCTR R2,R0 -1 max dsname len
BCTR R5,R0 -1 input dsname len
B DBR7OU21 Loop next dsname char
DBR7OU22 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT2L Dsname length in R4
LTR R4,R4 Is the length 0
BP *+16 No. len greater than 0
BAL R14,DBR7ERR1 Yes. len <= 0
LA R15,CODE555 Display err msg
B CATEXIT
MVC 0(1,R3),0(R1) Move 1 char of the dsname
LA R3,1(,R3) +1 to receiving dsname addr
LA R1,1(,R1) +1 to sending dsname addr
LA R4,1(,R4) +1 to receiving dsname len
BCTR R2,R0 -1 from max dsname len
BCTR R5,R0 -1 from input dsname len
B DBR7OU21 Process next dsname char
DBR7OU22 DS 0H
SR R4,R4
ICM R4,B'0011',SAVOUT2L Length of moved dsname
LTR R4,R4 Is the length 0
BP *+16 No. it is a positive number
BAL R14,DBR7ERR1 Yes. less than or equal to 0
LA R15,CODE555 Is a return code 555 error
B CATEXIT
MVI 0(R3),C'.' Len ok, end name w/period
LA R4,1(,R4) +1 to receiving dsname len
STCM R4,B'0011',SAVOUT2L due to adding the period
OI DBRFLAG,DBRIN Turn on parm done flag
OI PASSFLAG,PASSOUT2 Turn on 2 outputs flag
LM R0,R15,RTNSAVE Restore registers and
SR R15,R15 Set 0 for good return code
BR R14 Return to caller
*
* This code processes the JNAMREST = parameter which has
* the first character of the restore job jobname
*
PJREST DS OH
ST R14,RTN14 Save caller's return address
CLI 1(R1),C' ' Is jobname char +1 blank
BE PJREST1 Yes it is.
BAL R14,DBR7ERR1 No. that is an error
B PJREST2 cuz can only have 1 char
PJREST1 DS 0H
MVC JOB1CHAR,0(R1) Save char 1 of the jobname
OI DBRFLAG,DBRIN Set got jobname char flag
PJREST2 DS 0H
L R14,RTN14 Get callers return address
BR R14 and return to caller
*
* This routine displays error message DBR00011
* for an invalid input parameter
*
DBR7ERR1 DS 0H
ST R14,RTN14 Save callers return address
MVC DBR7MSG1+38(L'DBRCON),DBRCON Move in the con
DBR7MSG1 WTO 'DBR00011: INVALID PARAMETER = XXXXXXXXXXXX' +38
L R14,RTN14 Issue the message and return
BR R14
*
* This routine displays error message DBR00002
* when a required parameter is missing
*
DBR7ERR2 DS 0H
ST R14,RTN14 Display error message,
MVC DBR7MSG2+38(L'DBOCON),DBOCON
DBR7MSG2 WTO 'DBR00002: MISSING PARAMETER - XXXXXXXXXXXX'
OI PARMFLAG,PARMMIS Turn missing parm flag on
L R14,RTN14 and return to caller
BR R14
*
* This routine processes DBR7BK1= parameter and inserts
* the unloaded DASD volume serial number where string
* %VOL% appears in the data set name
*
* For example, while unloading DASD volume serial SYS002,
* if parameter DBR7BK1=UNLOAD.DFDSS.%VOL%.COPY1
* then upon exiting this routine, the data set name will
* have been expanded to
* UNLOAD.DFDSS.SYS002.COPY1
*
* In this routine,
* R1 = A(first character after the equal sign)
* R2 = Max number of chars in save area backup dsname
* R3 = A(Save area backup data set name)
* R4 = Actual length of data set name in the save area
* R5 = Num characters remaining after = sign in input
*
PBK1 DS 0H
STM R0,R15,RTNSAVE Save callers registers
EXTRACT PBKTIOT,'S',FIELDS=TIOT Addr(TIOT)
B DBR7BK
PBKTIOT DS A is stored in this field
DBR7BK DS 0H
LA R2,L'SAVBK1C Max # chars in backup dsname
LA R3,SAVBK1C Data set name move-to addr
SR R4,R4 Clear number of chars moved
L R1,RTNSAVE+4 Restore addr = sign + 1
DBR7BK1 DS 0H
STCM R4,B'0011',SAVBK1L Save data set name length
LTR R5,R5 Any input chars left
BZ DBR7BK20 No. we are finished
CLI O(R1),C' ' Is this end of input
BE DBR7BK20 Yes. a blank also terminates
C R2,=A(0) Did we process max number
BH *+16 No. continue
BAL R14,DBR7ERR1 Yes. not followed by blank
B CATEXIT is an error. Display msg
DBR7BK20 DS 0H
SR R4,R4
ICM R4,B'0011',SAVBK1L Get current dsname length
C R4,=A(0) Is it zero?
BH *+16 Greater than 0, continue
VOL1ERR DS 0H
BAL R14,DBR7ERR1 It is 0, display error msg
LA R15,CODE555
B CATEXIT
VOL1 DS 0H
LA R3,SAVBK1C Address backup data set name
LA R2,L'VOLSTG-1 Length of %VOL% string - 1
S R4,=A(L'VOLSTG) Addr last possible char
MVI WRKBK1C,C' ' Blanks to receiving data set
MVC WRKBK1C+1(L'WRKBK1C-1),WRKBK1C
XC WRKBK1L,WRKBK1L 0 to receiving data set name
LA R6,WRKBK1C A(expanded data set name)
*
* Look for string %VOL% in the parameter data set name
*
VOL1A DS 0H
EX R2,VOLCLC Does string %VOL% start here
BE VOL1B Yes. we found the string
MVC 0(1,R6),0(R3) No. move a char of the data
LA R3,1(,R3) +1 to input backup data set
LA R6,1(,R6) +1 to moved backup dsn addr
BCT R4,VOL1A Keep looking for %VOL% stg
B VOL1ERR
*
* Here when we find string %VOL% in the parameter data
* R3 = Addr 1st character of string %VOL% is save area
* R6 = Addr 1st blank character in the move-to work area
* This program runs as the second step of the unload job
* the unload DASD volume serial number is in characters
* d-8 of the unload jobname.
*
VOL1B DS 0H
L R14,VOL1B31
BSM R0,R15 Switch to 31 bit addressing
VOL1B31 DC A(VOL1B31A+X'80000000')
VOL1B31A DS 0H
L R15,PBKTIOT Restore address of TIOT
USING TIOT1,R15 base in register 15
MVC O(L'VOLSER,R6),TIOCNJOB+2 Move volser
DROP R15 to where %VOL% appears
L R15,VOL1B24
BSM R0,R15 Switch back to 24 bit addr
VOL1B24 DC A(VOL1B24A)
VOL1B24A DS 0H
*
* Move the rest of the data set name from input
* to the first char past the unload volume serial number
*
LA R6,L'LVOLSER(,R6) Continue moving
LA R3,L'VOLSTG(,R3) Past %VOL% string
S R4,=A(L'VOLSTG-1) -5 from character count
C R4,=A(0) Is char count a positive num
BNH VOL1ERR No. we have an error
VOL1C DS 0H
CLI O(R3),C' ' Is there a blank
BE VOL1EXIT Yes. finished with dsname
MVC 0(1,R6),0(R3) No. move next char of dsname
LA R3,1(,R3) +1 to input dsname address
LA R6,1(,R6) +1 to data set name in work
B VOL1C Continue looking for end
*
* Here when we have the end of the input parameter dsname
*
VOL1EXIT DS 0H
SR R15,R15 0 in register 15
LH R15,SAVBK1L Length of input parm dsname
S R15,=A(L'VOLSTG) Minus len of %VOL% string
A R15,=A(L'LVOLSER) Plus the len of volser
STH R15,WRKBK1L Save the new data set name l
STH R15,SAVBK1L in save and work areas
BCTR R15,R0 We are moving new name
MVI SAVBK1C,C' ' the save area after we clear
MVC SAVBK1C+1(L'SAVBK1C-1),SAVBK1C
EX R15,VOLMVC Here goes move to save area
VOL1EXI2 DS 0H
L R6,RTNSAVE+(4*R6) Restore address to reg 6
OI DBRFLAG,DBRIN Turn on 'parm is finished'
LM R0,R15,RTNSAVE Restore the callers register
SR R15,R15 Set 0 return code in reg 15
BR R14 and return to caller
*
VOLCLC CLC 0(0,R3),VOLSTG
VOLMVC MVC SAVBK1C(*-),WRKBK1C
*
* This routine processes input parameter DBR7BK2= when 2
* output copies of the unload data set are requested
* using similar logic as that which processed parm
* DBR7BK1=
*
* In this routine,
* R1 = A(first character after the equal sign)
* R2 = Maximum number of chars in save area backup data
* R3 = A(Save area backup data set name)
* R4 = Actual length of data set name in the save area
* R5 = # characters remaining after = sign in input
*
PBK2 DS 0H
STM R0,R15,RTNSAVE Save callers register
EXTRACT PBKTIOT2'S',FIELDS=TIOT Addr of Task IO Table
B DBR7BK
PBKTIOT2 DS A is stored in this field
DBR7PBK DS 0H
LA R2,L'SAVBK2C Maximum # chars backup dsn
LA R3,SAVBK2C Data set name move-to addr
SR R4,R4 Clear number of chars moved
L R1,RTNSAVE+4 Restore addr = sign + 1
DBR7PBK1 DS 0H
STCM R4,B'0011',SAVBK2L Save data set name length
LTR R5,R5 Any input chars left
BZ DBR7PBK2 No. we are finished
CLI O(R1),C' ' Is this end of input
BE DBR7PBK2 Yes. a blank also terminates
C R2,=A(0) Did we process the max #
BH *+16 No. continue
BAL R14,DBR7ERR1 Yes. not followed by blank
LA R15,CODE555
B CATEXIT is an error. Display msg
DBR7PBK2 DS 0H
SR R4,R4
ICM R4,B'0011',SAVBK2L Current data set name len
C R4,=A(0) Is it zero?
BH *+16 It is greater than 0, loop
*
VOL2ERR DS 0H
BAL R14,DBR7ERR1 It is 0, display error msg
LA R15,CODE555
B CATEXIT
VOLPBK1 DS 0H
LA R3,SAVBK2C Address backup data set name
LA R2,L'VOLSTG-1 Length of %VOL% string - 1
S R4,=A(L'VOLSTG) Address last possible char
MVI WRKBK2C,C' ' Blanks to receiving data set
MVC WRKBK2C+1(L'WRKBK2C-1),WRKBK2C
XC WRKBK2L,WRKBK2L 0 to receiving data set name
LA R6,WRKBK2C A(expand dsname)
*
* Look for string %VOL% in the parameter data set name
*
VOLPBK2A DS 0H
EX R2,VOLCLC Does string %VOL% start here
BE VOLPBK2B Yes. we found the string
MVC 0(1,R6),0(R3) No. move a char of the data
LA R3,1(,R3) +1 to input backup data set
LA R6,1(,R6) +1 to moved backup dsname
BCT R4,VOLPBK2A Keep looking for %VOL% stg
B VOL2ERR
*
* Here when we find string %VOL% in the parameter data
* R3 = Address 1st char of string %VOL% is save area
* R6 = Addr 1st blank character in the move-to work area
* This program runs as the second step of the unload job
* Unload DASD volume serial number is in characters 3-8
* of the unload jobname.
*
VOLPBK2B DS 0H
L R14,VOL2PB31
BSM R0,R15 Switch to 31 bit addressing
VOL2PB31 DC A(VOL2P31A+X'80000000')
VOL2P31A DS 0H
L R15,PBKTIOT2 Restore address of TIOT
USING TIOT1,R15 base in register 15
MVC O(L'VOLSER,R6),TIOCNJOB+2 Move volser from unload
DROP R15 to where %VOL% appears
L R15,VOL2PB24
BSM R0,R15 Switch back to 24 bit addr
VOL2PB24 DC A(VOL2P24A)
VOL2P24A DS 0H
*
* Move the rest of the data set name from the input parm
* to the first char past the unload volume serial number
*
LA R6,L'LVOLSER(,R6) Continue moving remainder
LA R3,L'VOLSTG(,R3) Past %VOL% string
S R4,=A(L'VOLSTG-1) Subtract 5 from char cnt
C R4,=A(0) Is char count a positive num
BNH VOL2ERR No. we have an error
VOLPBK1C DS 0H
CLI O(R3),C' ' Is there a blank at end
BE VOL2EXIT Yes. we are finished
MVC 0(1,R6),0(R3) No. move next char of dsname
LA R3,1(,R3) +1 to input dsname address
LA R6,1(,R6) +1 to data set name in work
B VOLPBK1C Continue looking for end
*
* Here when we have the end of the input parameter dsname
*
VOL2EXIT DS 0H
SR R15,R15 0 in register 15
LH R15,SAVBK2L Length of input parm dsname
S R15,=A(L'VOLSTG) Minus len of %VOL% string
A R15,=A(L'LVOLSER) Plus the len volser
STH R15,WRKBK2L Save the new data set name l
STH R15,SAVBK2L in save and work areas
BCTR R15,R0 We are going to move name
MVI SAVBK2C,C' ' the save area after we clear
MVC SAVBK2C+1(L'SAVBK2C-1),SAVBK2C
EX R15,VOLMVC2 Here goes the move
VOL2EXI2 DS 0H
L R6,RTNSAVE+(4*R6) Restore address to reg 6
OI DBRFLAG,DBRIN Turn on 'parm is finished'
LM R0,R15,RTNSAVE Restore the callers register
SR R15,R15 Set 0 return code in reg 15
BR R14 and return to caller
*
VOLMVC2 MVC SAVBK2C(*-*),WRKBK2C
*
DROP R2 End DBRTABLE addressability
*
* Here after we have processed the parameters in
*
EOPARMS DS 0H
L R15,SEC1B
BSM R0,R15 Switch to 31 bit addressing
SEC1B DC A(SEC1BX+X'80000000')
SEC1BX DS 0H
*
* Here for each output data set whether it be 1 or 2
* backup copies
*
LOOPPASS DS 0H
L R8,ADRTCB Get address of Task Ctlblk
USING TCB,R8
*
L R8,TCBJSCB Get address of Job Step
DROP R8 Control Block
USING IEZJSCB,R8
*
SR R7,R7
ICM R7,B'0111',JSCBJCTA
DROP R8
*
LA R8,WEPAAREA
USING ZB505,R8
STCM R7,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP Change to Supervisor State
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
STM R0,R15 Save all registers
MODESET MODE=PROB Change to Problem Program Sta
*
LTR R15,R15 Test register 15 return code
BZ *+8 It is good, continue
ABEND 2,DUMP It is bad, ABEND
*
L R7,SWBLKPTR
USING INJMJCT,R7
SR R6,R6
ICM R6,B'0111',JCTSDKAD
DROP R7
*
LOOPSCT DS 0H
XC SWBLKPTR(LAB505),SWBLKPTR
STCM R6,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP Back to supervisor mode for
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB then back to problem program
LTR R15,R15
BZ *+8 Continue on good return code
ABEND 3,DUMP Else abend at this spot
*
L R7,SWBLKPTR
USING INSMSCT,R7
SR R6,R6
ICM R6,B'0111',SCTFSIOT
LOOPSIOT DS 0H
XC SWBLKPTR(LZB404),SWBLKPTR
STCM R6,B'0111',SWVA
LA R2,WSWAREQ
LA R3,WEPAADDR-WAREABGN(,R15)
*
MODESET MODE=SUP
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB
LTR R15,R15
BZ *+8
ABEND 4,DUMP
*
L R6,SWBLKPTR
USING INDMSIOT,R6
SR R5,R5
ICM R5,B'0111',SCTPJFCB
XC SWBLKPTR(LZB505),SWBLKPTR
STCM R5,B'0111',SWVA
LA R2,WSWQREQ
LA R3,WEPAADDR-WAREABGN(,R13)
*
MODESET MODE=SUP
SWAREQ FCODE=RL,EPA=((R3)),MF=(E,(R2))
MODESET MODE=PROB
L R5,SWBLKPTR
ST R5,WSAVJFCB Save Job File Control Block
USING INFMJFCB,R5
MVC WDSNM,JFCBDSNM Move JFCB data set name into
TM PASSFLAG,PASS2 Are we on output copy 2
BO *+14 Yes.
MVC WRKBK1C,JFCBDSNM No. we are on output copy 1
B *+10
MVC WRKBK2C,JFCBDSNM We are on output copy 2
TM PASSFLAG,PASS2
BO *+18
CLC SAVBK1C,WRKBK1C Compare output copy 1 dsnames
BNE NEXTSIOT They do not match get next na
B BUNAME They match, continue
CLC SAVBK2C,WRKBK2C Compare output copy 2 dsnames
BNE NEXTSIOT No match, get next data set
B BUNAME
*
* Here after we have the backup data set name from the
* operating system control blocks and it matches the
* name in the work area
*
BUNAME DS 0H
MVI WDSNM,C' ' Blanks to data set name
MVC WDSNM+1(L'WDSNM-1),WDSNM
LA R2,WDSNM
LA R3,JFCBDSNM
LA R4,L'WDSNM 0 to data set name length in
SR R1,R1
STC R1,WDSNML
BULOOP1 DS 0H
CLI O(R3),C' ' Look for blank at end of data
BE BULOOP1X
MVC 0(1,R2),O(R3) Move dsname 1 char at a time
LA R1,1(,R1) +1 to data set name length
LA R2,1(,R2) +1 to work area data set name
LA R3,1(,R3) +1 to JFCB data set name addr
BCT R4,BULOOP1 -1 from maximum data set name
BULOOP1X DS 0H
*
* Read the job JCL mask and save each JCL statement in
* GETMAIN area
*
L R15,SW01A
BSM R0,R15 Switch to 24 bit addressing
SW01A DC A(SW01AX) for sequential input/output
SW01AX DS 0H
LA R3,WJCLIN Address of the input data
LA R1,WOPENIN
OPEN ((R3),(INPUT)),MODE=24,MF=(E,(1)) open the data
L R15,sw02a
BSM R0,R15 Back to 31 bit addressing
SW02A DC A(SW02AX+X'80000000')
SW02AX DS 0H
LA R1,WJCLIN Input DCB address in Reg 1
USING IHADCB,R1
MVC WAVLRECL,DCBLRECL Input record length
DROP R1
LH R0,WAVLRECL Get logical record length in
GETMAIN R,LV=(0),LOC=(BELOW) Get memory for 1 input
ST R1,WJCLWORK Save memory address
BUGET DS 0H
LA R1,WJCLIN
GET (R3) Get a JCL mask statement
LR R3,R1 Card input address in Reg 3
L R15,SW04B
BSM R0,R15 Back to 31 bit addressing
SW04B DC A(SW04BX+X'80000000')
SW04BX DS 0H
LH R4,WAVLRECL Number bytes in a JCL mask
LA R4,LJCLDSEC(,R4) + number of bytes in rec
GETMAIN R,LV=((R4)),LOC=(BELOW)
USING JCLDSECT,R1
BCTR R4,R0 -1 from logical rec ctlblk
EX R4,WCAREA clear logical record control
LR R4,R1 block
*
* At this point the register contents are:
* R1 = Address current JCL image control block
* R3 = Address input JCL mask statement
* R4 = Address new jcl image control block
* This code chains the JCL mask control blocks together
*
CLC WJCL,=A(0) First time through
BNE BUGET1 No.
ST R4,WJCL Save getmain address 1st time
B BUGET4
BUGET1 DS 0H Here when it is not the first
L R1,WJCL
BUGET2 DS 0H
L R2,JCLNEXT
LTR R2,R2 Addr next JCL mask
BZ BUGET3
LR R1,R2
B BUGET2 Looking for last JCL mask
BUGET3 DS 0H
ST R4,JCLNEXT Chain new image to last image
LR R0,R1 Last completed control block
LR R1,R4 Make new image current
ST R0,JCLPREV Addr previous image
BUGET4 DS 0H
LH R4,WAVLRECL Logical record length again
BCTR R4,R0 Minus 1
EX R4,WMVCJCL Move input JCL mask to ctlblk
L R14,WRKSEQ +1 to JCL mask input count
LA R14,1(,R14)
ST R14,JCLSEQ
ST R14,WRKSEQ
DROP R1
B BUGET Go processing next JCL mask
*
* Here after reading all JCL masks into control blocks
*
EOJCLIN DS 0H
L R15,SW05C
BSM R0,R15 Switch to 24 bit addressing
SW05C DS A(SW05CX)
SW05CX DS 0H
LA R3,WJCLIN
CLOSE ((R3)),MODE=24,MF=(E,(1)) Close JCL mask input
L R15,SW06C
BSM R0,R15 Switch to 31 bit addressing
SW06C DC A(SW06CX+X'80000000')
SW06CX DS 0H
CLC WJCL,=A(0) Was the JCL mask file empty
BNE GOTJCL No. we read 'some' JCL masks
WTO 'DBR00012: JCLIN DATA SET EMPTY' Yes. display err
LA R15,CODE4
B CATEXIT and exit
*
* Here after reading all JCL masks and closing dataset
*
GOTJCL DS 0H
L R1,WJCL Addr 1st JCL mask in the chai
USING JCLDSECT,R1
*
* Previously we built the data set name
* Here we build the JCL for the restore job
*
SCANJCL DS 0H
LA R3,INSTBL Addr of insert table
USING INSDSECT,R3
*
SCANSTR DS 0H
LA R1,JCLIMAGE Start of JCL image
LH W4,WAVLRECL JCL image length
SR R9,R9
IC R9,INSLEN Get the string length
BCTR R9,R0 -1 from insert string length
SR R4,R9 -insert stg len-1 from JCL im
SCANCHAR DS 0H
EX R9,WCLCINS Look for the keyword
BE SCANHIT We found a keyword
LA R2,1(,R2) No hit. Addr next
BCT R4,SCANCHAR Keep on looking
LA R3,LINSENT(,R3) Addr next keyword in table
CLC INSWTG,=A(0) Are there more JCL masks?
BNZ SCANSTR Yes. look for next keyword
*
* Here when there is no keyword in the JCL mask and/or
* a keyword has been inserted into the JCL mask
*
LOOPJCL DS 0H
L R1,JCLNEXT Addr next JCL mask ctlblk
LTR R1,R1 Or was that the last JCL mask
BNZ SCANJCL No. there are more JCL masks
B SCANDONE Yes. all done
*
* Here when we find a keyword in the JCL mask
* Register usage is:
* R1 = Address JCL image control block
* R2 = Address first char of keyword string, which is %
* R5 = Address Job File Control Block
* R9 = Length of keyword string - 1
*
SCANHIT DS 0H
L R15,INSWTG Get keyword routine address
BALR R14,R15 Go to keyword routine
LTR R15,R15 Routine end with good return
BZ LOOPJCL Yes. keep going til all mask
ABEND (15),DUMP No. Abend program
DROP R3
*
NEXTSIOT DS 0H
SR R1,R1
ICM R1,B'0111',SCTPSIOT
LTR R1,R1
BZ NEXTSCT
LR R6,R1
B LOOPSIOT
*
NEXTSCT DS 0H
SR R1,R1
ICM R1,B'0111',SCTANSCT
LTR R1,R1
BZ SCTDONE
LR R6,R1
B LOOPSCT
SCTDONE DS 0H
LA R15,CODE0 End program with good rc
B CATEXIT
*
DROP R5
DROP R6
DROP R7
DROP R8
*
* Here when all JCL masks have been processed
*
SCANDONE DS 0H
*
* Allocate the output partitioned data set that contains
* restore job JCL for all DASD volumes in this shipment
* Use SVC 99 to dynamically allocate the dataset.
* RESERVE restore JCL dataset device to prevent
* multiple programs from updating it simultaneously and
* 'clobbering' it. When the DASD device is reserved,
* write the restore job to shipment's restore ds
*
SVC99 DS 0H
LA R15,W99RBPTR
USING S99RBP,R14
LA R2,W99RB
ST R2,S99RBPTR
OI S99RBPTR,S99TUPLN
DROP R14
*
LA R14,W99RB
USING S99RB,R14
LA R2,W99TUPTR
ST R2,S99TXTPP
DROP R14
*
LR R14,R2
USING S99TUPL,R14
LA R2,WALDSNAM
ST R2,S99TUPTR
MVI WDSNAME,C' '
MVC WDSNAME+1(L'WDSNAME-1),WDSNAME
TM PASSFLAG,PASS2 Are we on copy 2 of 2
BO *+16 Yes.
LA R5,SAVOUT1C No. we are on the 1st copy
LH R6,SAVOUT1L
B *+12
LA R5,SAVOUT2C
LH R6,SAVOUT2L
BCTR R6,R0 -1 from length
LA R15,WDSNAME
EX R6,MVCDSN
B *+10
MVCDSN MVC 0(*-*,R15),0(R5)
LA R15,1(R6,R15) Addr where to put shipment
MVC 0(L'WDSNSUF,R15),WDSNSUF ID which is A-Z
LA R15,1(,R15) +1 for shipment ID
LA R6,WDSNAME
SR R15,R6 Calculate dsname length
STCM R15,B'0011',WDSNAMEL and save it
*
LA R14,L'S99TUPTR(,R14)
LA R2,WALSTATS
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALNDISP Addr DISP=x parameter
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALCDISP Addr DISP=(.,x) parameter
ST R2,S99TUPTR
LA R14,L'S99TUPTR(,R14)
LA R2,WALDDNAM Addr DDNAME parameter
ST R2,S99TUPTR
OI S99TUPTR,S99TUPLN Last parameter flag
*
LA R2,W99RB SVC 99 request block
USING S99RB,R2
XC S99FLAG1,S99FLAG1 Clear the flag bytes
XC S99ERROR,S99ERROR
XC S99INFO,S99INFO
XC S99FLAG2,S99FLAG2
DROP R2
*
LA R1,W99RBPTR
SVC 99 Allocate restore JCL ds
LTR R15,R15 Did we allocate it
BZ SVCOK Allocated restore JCL ds
CVD R15,WDOUBLE No. convert the return code
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC SVCWTO+29(3),WDOUBLE Put return code in error msg
LA R2,W99RB
USING S99RB,R2
MVC HEXCHAR,S99INFO Convert SVC99 information
NI HEXCHAR,X'F0' from hexadecimal to char
TR HEXCHAR,HEXTBL by translating the first 4
MVC SVCWTO+41(1),HEXCHAR bits
MVC HEXCHAR,S99INFO and by translating the last
NI HEXCHAR,X'0F' in the first info byte
TR HEXCHAR,HEXTBL
MVC SVCWTO+42(1),HEXCHAR
MVC HEXCHAR,S99INFO+1 and then doing the same to
NI HEXCHAR,X'F0' second info byte
TR HEXCHAR,HEXTBL in order to display the info
MVC SVCWTO+43(1),HEXCHAR in the error msg.
MVC HEXCHAR,S99INFO+1
NI HEXCHAR,X'0F'
TR HEXCHAR,HEXTBL
MVC SVCWTO+44(1),HEXCHAR
*
MVC HEXCHAR,S99ERR0R Now translate the error code
NI HEXCHAR,X'F0' from hexadecimal to
TR HEXCHAR,HEXTBL character
MVC SVCWTO+55(1),HEXCHAR Move translated bits to err
MVC HEXCHAR,S99ERROR
NI HEXCHAR,X'0F' Do same for last 4 bits
TR NEXCHAR,HEXTBL
MVC SVCWTO+56(1),HEXCHAR And move to error msg
MVC HEXCHAR,S99ERROR+1
NI HEXCHAR,X'F0' Isolate 1st 4 bits of error
TR HEXCHAR,HEXTBL byte 2
MVC SVCWTO+57(1),HEXCHAR
MVC HEXCHAR,S99ERROR+1 Isolate last 4 bits of error
NI HEXCHAR,X'0F' byte 2
TR HEXCHAR,HEXTBL
MVC SVCWTO+58(1),HEXCHAR
MVC SVCWTO1+18(L'RNAMEDSN),RNAMEDSN Dsname errmsg
*
SVCWTO WTO 'DBR00003: SVC 99 R15=XXX,S99INFO=XXXX,S99ERROR=C
XXXX'
SVCWTO1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
ABEND CODE532,DUMP End the program with a dump
CODE532 EQU 532
*
* We are here because we successfully allocated
* this shipment's restore JCL partitioned data set (PDS).
* Now we have to RESERVE the DASD device the JCL PDS
* so only 1 program at a time can write to the file.
*
SVCOK DS 0H
L R15,SW07D Switch to 24 bit addressing
SW07D DC A(SW07DX)
SW07DX DS 0H
LA R2,ADDRTIOT TIOT address
EXTRACT ((R7)),FIELDS=TIOT TIOT table address
L R7,ADDRTIOT
LA R7,24(,R7)
NEXTDD DS 0H
CLC WRESERVE(LWRESERV),4(R7)
BE FINDUCB
SR R1,R1
IC R1,0(R7)
CLC 0(4,R7),=F'0'
BNE NEXTDD Could not find restore
ABEND 200,DUMP dataset UCB
*
FINDUCB DS 0H
LA R8,16(,R7)
L R8,0(R8)
LA R8,0(R8) We found the UCB for
ST R8,ADDRUCB device the restore dataset
USING UCBOB,R8 is on
LR R9,R8
S R9,=A(UCBPRFX) Subtract UCB prefix length
USING UCB,R9
CLI UCBID,UCBSTND Is this a standard UCB
BE STDUCB
ABEND 400,DUMP No. abend
* Here when we have a standard UCB (unit control block)
*
STDUCB DS 0H
TM PASSFLAG,PASS2 Are we on the second output
BO STDUCB1 Yes.
MVC RNAMEDSN,SAVOUT1C No. 1st copy, move dsname
LH R15,SAVOUT1L Len of dsname
B STDUCB2
STDUCB1 DS 0H
MVC RNAMEDSN,SAVOUT2C Yes. move dsname for copy 2
LH R15,SAVOUT2L
STDUCB2 DS 0H
LA R7,RNAMEDSN
LA R7,0(R15,R7)
MVC O(L'WDSNSUF,R7),WDSNSUF Use shipment #
RESERVE (QNAME,RNAME,E,0,SYSTEMS),RET=HAVE,UCB=ADDRUCB
LTR R15,R15 Did we successfully RESERVE
BZ RESVOK Yes.
SR R7,R7 No. put return code in error
IC R7,E(R15) message
LR R15,R7
CVD R15,WDOUBLE
OI WDOUBLE+7,X'0F'
UNPK RWTOR2A+47(8),WDOUBLE+3(5)
MVC RWTO42AA+18(L'RNAMEDSN),RNAMEDSN Move data set
RWTOR2A WTO 'DBR00021: RESERVE RET=HAVE RETURN CODE=XXXXXXX'
RWTOR2AA WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
B STOWDONE
*
* We successfully reserved the DASD device the restore
* restore JCL dataset in on. Everyone else locked out
* Open the restore JCL shipment data set
*
RESVOK DS 0H
MVC RESVOKM+27(L'RNAMEDSN),RNAMEDSN move dsname
RESVOKM WTO 'DBR00022: RESERVED XXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXX'
LA R3,WJCLOUT
LA R1,WOPENOUT
OPEN ((R3),(OUTPUT)),MODE=24,MF=(E,(1)) open the JCL
L R15,SW08D dataset
BSM R0,R15
SW08D DC A(SW08DX+X'80000000')
SW08DX DS 0H
L R9,WJCL Get address first JCL stmt
USING JCLDSECT,R9
*
* Now ... we are going to write the job JCL to the
* restore JCL partitioned data set one line at a time
*
PUTJCL DS 0H
L R15,SW09E
BSM R0,R15
SW09E DC A(SW09EX)
SW09EX DS 0H
LA R8,JCLIMAGE-JCLDSECT(,R9) position to JCL
LA R3,WJCLOUT statement
LH R7,WAVLRECL
USING IHADCB,R3
STH R7,DCBBLKSI Set the blocksize in the DCB
DROP R3
WRITE DECBOUT,SF,((R3)),((R8)),((R7)) there it goes
CHECK DECBOUT Test the WRITE return code
L R15,SW10D
BSM R0,R15
SW10D DC A(SW10D+X'80000000')
SW10DX DS 0H
*
* After the JCL is written out, STOW the member name
* in the partitioned data set directory
*
WRTOK DS 0H
STOWPDS DS 0H
L R15,SW11D
BSM R0,R15
SW11D DC A(SW11DX)
SW11DX DS 0H
LA R3,WJCLOUT
STOW ((R3)),PDSENT,A First try to ADD the name
LTR R15,R15 Did we do it?
BNZ STOWAERR No. we had an error
MVC STOWAMSG+18(L'PDSNAME),PDSNAME issue msg
MVC STOWAMSG+36(L'RNAMEDSN),RNAMEDSN
WTO 'DBR00023: XXXXXXXX ADDED TO XXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXXXXXXXXXXX'
B STOWDONE We're rolling now ...
*
* Display this message when the STOW macro failed
*
STOWAERR DS 0H
CVD R15,WDOUBLE Translate return code
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWAWTO+36(3),WDOUBLE
CVD R0,WDOUBLE
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWAWTO+43(3),WDOUBLE
MVC STOWAWTO+18(L'PDSNAME),PDSNAME
MVC STOWAWT1+18(L'RNAMEDSN),RNAMEDSN)
STOWAWTO WTO 'DBR00025: XXXXXXXX STOW R15=XXX R0=XXX NOT ADDED
STOWAWT1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
STOWREP DS 0H If we couldn't add it, re
LA WJCLOUT
STOW ((R3)),PDSENT,R
LTR R15,415 Did we replace it?
BNZ STOWRERR No. we did not replace it
*
* If we replaced the JCL member, issue this message
*
MVC STOWRMSG+18(L'PDSNAME),PDSNAME
MVC STOWRMSG+39(L'RNAMEDSN),RNAMEDSN
STOWRMSG WTO 'DBR00024: XXXXXXXX REPLACED IN XXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXXXXXXXXXXXXXX'
B STOWDONE We have the restore job n
*
* We are here because we could not add OR replace restore
* JCL member in this shipment's partitioned data set
*
STOWRERR DS 0H
CVD R15,WDOUBLE Retcode in error msg
OI WDOUBLE+7,X'0F'
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWRWTO+36(3),WDOUBLE
CVD R0,WDOUBLE
OI WDOUBLE+7,X'0F' Turn the sign bit on
UNPK WDOUBLE(3),WDOUBLE+6(2)
MVC STOWRWTO+43(3),WDOUBLE+6(2)
MVC STOWRWTO+18(L'PDSNAME),PDSNAME
MVC STOWRWT1+18(L'RNAMEDSN),RNAMEDSN
STOWRWTO WTO 'DBR00026: XXXXXXXX STOW R15=XXX R0=XXX NOT REPLC
ACED'
STOWRWT1 WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
*
* We were either successful or unsuccessful in writing
* restore job JCL in the restore shipment JCL data set.
* Regardless, CLOSE the restore shipment JCL data set and
* release the DASD volume it is on from the RESERVE
*
STOWDONE DS 0H
LA R1,WCLS
LA R3,WJCLOUT
CLOSE ((R3)),MODE=24,MF=(E,(1))
DEQRES DS 0H
DEQ (QNAME,RNAME,0,SYSTEMS),RET=HAVE,UCB=ADDRUCB
LTR R15,R15 Release good
BZ DEQOK Yes
SR R7,R7 No
IC R7,3(R15) It will be released when
LR R15,R7 program ends
CVD R15,WDOUBLE Add DEQ return code to
OI WDOUBLE+7,X'0F' err msg
UNPK RWTOR3A+35(8),WDOUBLE+3(5)
MVC RWTOR3AA+18(L'RNAMEDSN),RNAMEDSN
RWTOR3A WTO 'DBR00027: DEQ RETURN CODE=XXXXXXXX IGNORED'
RWTOR3AA WTO ' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX'
*
DEQOK DS 0H Tell operator we release
MVC DEQWTOK+27(L'RNAMEDSN),RNAMEDSN
DEQWTOK WTO 'DBR00028: DEQUEUED XXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXXXXXXXXXXX'
L R15,SW12D
BSM R0,R15
SW12D DC A(SW12DX+X'80000000')
SW12DX DS 0H
DROP R9
*
* We are finished with writing out the JCL, closed the
* data set we wrote it to and, released the DASD volume
* the data set was on
*
TM PASSFLAG,PASS2 Was this for the second
BO DEQOK1 Yes. we are finished
TM PASSFLAG,PASSDUP No. do we want a second
BNO DEQOK1 No. we only want 1 copy
LA R2,W99BGN Yes. we want 2 copies
LA R4,X99BGN So let's do it again
LA R3,W99END-W99BGN
LA R5,X99END-X99BGN
MVCL R2,R4 Reinit SVC 99 parameters
MVC WJCLIN(XJCLINL),XJCLIN
LA R2,WJCLIN
USING IHADCB,R2
*
LA R3,EOJCLIN
STCM R3,B'0111',DCBEODAD+1 Reinit end-of-JCLIN rtn
DROP R2 address
*
* Deallocate the restore JCL partitioned data set with SV
*
MVC WJCL1,WJCL Save GETMAIN address
XC WJCL,WJCL
MVC WJCLOUT(XJCLOUTL),XJCLOUT
LA R2,WD9RB
ST R2,WD9RBPTR
OI WD9RBPTR,X'80'
LA R2,WD9TU1
ST R2,WD9TXTPP
OI WD9TU1,X'80 Last text unit ptr in
LA R1,WD9RBPTR the list
SVC 99
LTR R15,R15
BZ SVCDOK
*
* Deallocate failed, display error msg with return and
* error codes in it
*
CVD R15,WDOUBLE SVC 99 had a bad return
OI WDOUBLE+7,X'0F' turn on sign bit and
UNPK WDOUBLE(3),WDOUBLE+6(2) unpack
MVC SVCWTOD+29(3),WDOUBLE
LA R2,WD9RB
USING S99RB,R2
*
MVC HEXCHAR,S99INFO Convert SVC99 info code
NI HEXCHAR,X'F0' from hex to character
TR HEXCHAR,HEXTBL translate first 4 bits
MVC SVCWTOD+1(1),HEXCHAR
MVC HEXCHAR,S99INFO and by translating the last
NI HEXCHAR,X'0F' 4 in the first info byte
TR HEXCHAR,HEXTBL
MVC SVCWTOD+42(1),HEXCHAR
MVC HEXCHAR,S99INFO+1 do same to
NI HEXCHAR,X'F0' second info byte
TR HEXCHAR,HEXTBL to display info code
MVC SVCWTOD+43(1),HEXCHAR in the error msg.
MVC HEXCHAR,S99INFO+1
NI HEXCHAR,X'0F'
TR HEXCHAR,HEXTBL
MVC SVCWTOD+44(1),HEXCHAR
*
MVC HEXCHAR,S99ERR0R Now translate the error code
NI HEXCHAR,X'F0' from hexadecimal to print
TR HEXCHAR,HEXTBL characters
MVC SVCWTOD+55(1),HEXCHAR Translated bits to err msg
MVC HEXCHAR,S99ERROR
NI HEXCHAR,X'0F' Do same for last 4 bits
TR NEXCHAR,HEXTBL
MVC SVCWTOD+56(1),HEXCHAR And move to error msg
MVC HEXCHAR,S99ERROR+1
NI HEXCHAR,X'F0' Isolate 1st 4 bits of error
TR HEXCHAR,HEXTBL byte 2
MVC SVCWTOD+57(1),HEXCHAR
MVC HEXCHAR,S99ERROR+1 Isolate last 4 bits of error
NI HEXCHAR,X'0F' byte 2
TR HEXCHAR,HEXTBL
MVC SVCWTOD+58(1),HEXCHAR We have all err info
MVC SVCWTOD1+18(L'RNAMEDSN),RNAMEDSN Dsname to msg
*
SVCWTOD WTO 'DBR00003: SVC 99 R15=XXX S99INFO=XXXX S99ERROR=C
XXXX;'
WTO ' DEALLOCATION FAILED'
ABEND CODE532,DUMP End program with a dump
DROP R2
*
* We successfully deallocated the restore JCL data set
*
SVCDOK DS 0H
MVC RNAMEDSN,SAVOUT2C Move data set name
LH R15,SAVOUT2L Data set name length
LA R7,RNAMEDSN
LA R7,0(,R15,R7) .+1 after dsname INDEX
MVC 0(L'WDSNSUF,R7),WDSNSUF Move shipment number for
B LOOPPASS RESERVE macro
DEQOK1 DS 0H
LA R15,CODE0 DEQ successful
B CATEXIT
*
CODE0 EQU 0 Return code for good end of job
CODE4 EQU 4 JCLIN file was empty
CODE8 EQU 8 Insufficient columns in which to expand
CODE12 EQU 12 Bad program parameter
CODE16 EQU 16 LOCATE macro nonzero RC in byte 3
CODE555 EQU 555 DBRPARM had invalid parameter
EJECT
*
* This is where we exit the program
*
CATEXIT DS 0H
L R2,WSAVE+4
ST R15,16(R2) Save return code
LA R0,WAREAEND-WAREABGN Length of GETMAIN area
LR R1,R13
FREEMAIN R,LV=(0),A=(1) Free the GETMAIN area
LR R13,R2
RETURN (14,12) Return to caller
*
LTORG
*
* The following work areas are not moved to the
* GETMAIN AREA
*
MAXIMAGE EQU 72 Max number columns on a JCL mask stmt
MAXSER EQU 6 Max number output cartridge volsers
* This is the where-to-go table for JCL masks
INSTBL DC V(RTN1),AL1(5),CL11'%DSN%'
DC V(RTN2),AL1(8),CL11'%SERIAL%'
DC V(RTN3),AL1(5),CL11'%JOB%'
DC V(RTN4),AL1(5),CL11'%VOL%'
DC A(0) End of where to go table
*
ADDRTIOT DS F Address of the Task Input/Output Table
ADDRUCB DS F Address of the Unit Control Block
*
QNAME DC CL8'SYSDSN
RNAME DC CL256' '
ORG RNAME
DC X'0B'
RNAMEDSN DC CL44' ' Example: SYS.DFDSS.RESTORE.
ORG RNAME+256
*
HEXCHAR DC C' '
HEXTBL DC C'0123456789ABCDEF'
DC X'F1',C'123456789ABCDEF'
DC X'F2',C'123456789ABCDEF'
DC X'F3',C'123456789ABCDEF'
DC X'F4',C'123456789ABCDEF'
DC X'F5',C'123456789ABCDEF'
DC X'F6',C'123456789ABCDEF'
DC X'F7',C'123456789ABCDEF'
DC X'F8',C'123456789ABCDEF'
DC X'F9',C'123456789ABCDEF'
DC C'A123456789ABCDEF'
DC C'B123456789ABCDEF'
DC C'C123456789ABCDEF'
DC C'D123456789ABCDEF'
DC C'E123456789ABCDEF'
DC C'F123456789ABCDEF'
*
* The following areas are moved to the GETMAIN area
*
XAREABGN DS 0D
DC C'XAREABGN'
XEPAADDR DC A(XEPAAREA)
XEPAAREA DC 4F'0'
XCAMAREA DS 0D
DS CL265' '
XCAMDSN DS CL44' '
XCAMLST CAMLST NAME,XCAMDSN,,XCAMAREA
*
XTIOT DS F
XEXTRACT EXTRACT XTIOT,'S',FIELDS=TIOT,MF=L
*
X99BGN EQU *
X99RBPTR DC A(X99RB)
X99RB DS 0F
X99RBLN DC AL1(20)
X99VERB DC AL1(S99VRBAL)
X99FLAG1 DC AL2(0)
X99ERROR DC AL2(0)
X99INFO DC AL2(0)
X99TXTPP DC AL4(0)
DC AL4(0)
X99FLAG2 DC AL4(0)
*
X99TUPTR DS 0F Text unit addresses
X99TU1 DC A(XALDSNAM) Data set name
X99TU2 DC A(XALSTATS) Data set status, new
X99TU3 DC A(XALNDISP) Normal disposition
X99TU4 DC A(XALCDISP) Conditional disposition
X99TULAS EQU *
X99TU5 DC A(XALDDNAM) DDNAME
*
XALDSNAM DS 0F Data set name specification
DC AL2(DALDSNAM) Data set name to be allocated
DC AL2(1) Must be a 1
XDSNAMEL DC AL2(44) Data set name length
XDSNAME DC CL44' ' Data set name
*
XALSTATS DS 0F Data set status
DC AL2(DALSTATS)
DC AL2(1) Must be a 1
DC AL2(1) Length is 1
DC AL1(WSHR) Disposition
*
XALNDISP DS 0F Data set normal disposition
DC AL2(DALNDISP)
DC AL2(1)
DC AL2(1) Length is 1
DC AL1(WKEEP)
*
XALCDISP DS 0F Data set conditional disposition
DC AL2(DALCDISP)
DC AL2(1)
DC AL2(1)
DC AL1(WKEEP)
*
XALDDNAM DS 0F DDNAME
DC AL2(DALDDNAM)
DC AL2(1)
DC AL2(6)
DC CL6' '
*
XRESERVE DC C'JCLOUT'
DC CL2' '
LXRESERV EQU *-XRESERVE
*
XD9RBPTR DC A(XC9RB) Deallocation parameter list
XD9RB DC AL1(20)
XD9VERB DC AL1(S99VRBUN)
XD9FLAG1 DC AL2(0)
XD9ERROR DC AL2(0)
XD9INFO DC AL2(0)
XD9TXTPP DC AL4(0)
DC AL4(0)
XD9FLAG2 DC AL4(0)
SC9TUPTR DS 0F
XD9TULAS EQU *
XD9TU1 DC A(XDLDDNAM)
XDLDDNAM DS 0F
DC AL2(DUNDDNAM)
DC AL1(1)
DC AL2(6)
DC C'JCLOUT'
DC CL2' '
*
XSWAREQ SWAREQ FCODE=RL,EPA=XEPAADDR,MF=L
XSYSIN DCB DDNAME=SYSIN,DSORG=PS,MACRF=PM,BLKSIZE=80, X
LRECL=80
XJCLOUT DCB DDNAME=JCLOUT,DSORG=PO,MACRF=W
XJCLIN DCB DDNAME=JCLIN,DSORG=PS,MACRF=GL,EODAD=EOJCLIN
XJCLINL EQU *-XJCLIN
*
XARMMSG WTO 'DBR7JCLR: PROGRAM PARM ERROR IN POSITION XXXX',X
MF=L
XMSGERR1 WTO 'DBR00015: INPUT IMAGEXXXX INSUFFICIENT COLUMNS X
TO EXPAND',MF=L
XMSGERR2 WTO 'DBR00016: XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXC
XXXXXXX',MF=L Input image where err occurred
*
XXCAREA XC 0(*-*,R1),0(R1)
XLCINS CLC 0(*-*,R2),INSLIT-INSDSECT(R3)
XVCJCL MVC JCLIMAGE-JCLDSECT(*-*,R1),0(R3)
XVCLEAD MVC 0(*-*,R3),JCLIMAGE-JCLDSECT(R1)
XVCDSN MVC 0(*-*,R3),WDSNM
XVCTRAIL MVC 0(*-*,R3),0(R2)
XMVCJOB MVC 0(*-*,R3),0(R14)
*
DC CL8'XAREAEND'
XAREAEND EQU *
XAREAENL EQU *-XAREABGN
EJECT
*
* This routine process keyword %DSN% in the JCL mask
* The actual data set name will be substituted in the
* location where the keyword string is
*
RTN1 CSECT ,
STM R0,R15,RTNSAVE
XC RTNSAVE+(15*4)(4),RTNSAVE+(15*4) Expect RC=0
LR R12,R15
USING RTN1,R12 Setup a new base register
*
LR R4,R2 Addr char 1 of insert string
LA R3,JCLIMAGE Address JCL image char 1
LH R14,WAVLRECL Input logical record length
S R14,=A(MAXSEQ+1) Minus columns 72-80
STH R14,WRKLRECL Max # columns that have data
LA R14,0(R3,R14) Scan backwards truncating
BCTR R14,R0 trailing blanks
BCTR R14,R0
LH R15,WRKLRECL
RTN1A DS 0H
CLI O(R14),C' '
BNE RTN1B
BCTR R14,R0 Backup past trailing blank
BCT R15,RTN1A Keep going to we hit data
RTN1B DS 0H
SR R14,R3 # chars to last data char
SR R14,R9 Length of insert string - 1
SR R4,R3 Len of preceding JCL characters
SR R14,R4
ST R14,JCLEN
LH R14,WRKLRECL Do we have room to move leading
SR R14,R4
LTR R14,R14
BNM RTN1C Yes we do
L R15,=V(RTNERR1) No we do not, it is an error
BALR R14,R15
LA R15,CODE8 Return to caller with retcode
ST R15,RTNSAVE+(15*4)
B RTN1X Exit
RTN1C DS 0H
STH R14,WRKLRECL Save number of chars left
BCTR R4,R0
L R3,WJCLWORK
LR R14,R3
LH R15,WAVLRECL
RTN1D DS 0H
MVI 0(R14),C' '
LA R14,1(,R14)
BCT R15,RTN1D
EX R4,WMVCLEAD Move chars before the keyword