Sample Assembler user exit
ADUEUEUE TITLE 'ADUEUEUE - UNLOAD PLUS USER EXIT USER EXAMPLE - V13'
ADUEUEUE CSECT
ADUEUEUE AMODE 31
ADUEUEUE RMODE 24
**********************************************************************
* D I S C L A I M E R
**********************************************************************
*
* THIS IS A SAMPLE UNLOAD PLUS USER EXIT. THIS EXIT WOULD BE USED
* IN ORDER TO INSPECT AND/OR MANIPULATE UNLOAD DATA RECORDS PRIOR
* TO THEIR BEING WRITTEN TO THE OUTPUT DATASET.
*
* THIS EXIT WILL ONLY BE INVOKED WHEN IT IS SPECIFICALLY NAMED
* IN THE 'UNLOADEXIT --NAME--' PARAMETER.
*
* NOTE: PLEASE REVIEW THE DOCUMENTATION IN THE REFERENCE MANUAL,
* AND THE FOLLOWING USAGE NOTES PRIOR TO IMPLEMENTING THIS EXIT.
*
* PLEASE CALL BMC PRODUCT SUPPORT WITH ANY QUESTIONS YOU MAY
* HAVE IN THIS AREA.
*
* PHONE: 1-800-537-1813
*
**********************************************************************
SPACE
**********************************************************************
* N O T E S
**********************************************************************
*
* ADUEUEUE IS CALLED AT 3 POINTS IN PROCESSING A TABLE UNLOAD.
*
* WHEN INVOKED, R0 CONTAINS A FUNCTION CODE.
*
* R1 CONTAINS THE ADDRESS OF A USER EXIT BLOCK DESCRIBED BY THE
* ADUEXITP DSECT. FIELDS FOR YOUR USE IN THIS BLOCK ARE DESCRIBED
* IN THE DSECT. THE USER EXIT BLOCK IS UNIQUE FOR EACH TASK INVOKING
* THE EXIT AND IS NOT SHAREABLE BY MULTIPLE TASKS.
*
* THE MAIN FIELD OF INTEREST IS THE PSEUDO-SQLDA POINTER XPSQLDA@
* WHICH POINTS TO AN 'SQLDA' PREPARED FOR EACH SELECTED UNLOAD TABLE.
* THIS SQLDA HAS THE SAME FORMAT AND CONTENTS OF A DB2 SQLDA, WITH THE
* MAIN EXCEPTION BEING THAT THE DESCRIPTIONS OF THE DATA FIELDS ARE
* THE OUTPUT DESCRIPTIONS (AFTER CONVERSIONS IF ANY), AND THE DATA
* POINTERS ARE POINTING TO THE OUTPUT RECORD OFFSETS IN THE RECORD
* ABOUT TO BE WRITTEN (FUNCTION CALL 0 ONLY).
*
* FUNCTION CODES:
*
* X'00' = PROCESS RECORD
*
* THIS CALL IS MADE AFTER A RECORD IS PREPARED FOR WRITING.
* ALL FIELDS ARE CONVERTED READY FOR OUTPUT. THE SQLDA
* PROVIDES THE FIELD TYPES AND RECORD POSITIONS OF THE DATA.
* THE UNLOAD EXIT PARM BLOCK PASSED WITH THIS FUNCTION IS
* UNIQUE FOR EACH UNLOAD TASK INVOKING THE EXIT AND IS NOT
* SHARABLE AMONG MULTIPLE TASKS.
*
* R15 RETURN CODES FROM PROCESS:
*
* 0 = ACCEPT THIS RECORD
* 4 = DISCARD THIS RECORD
* ANYTHING ELSE = TERMINATE THE RUN.
*
*
* X'01' = INITIALIZATION CALL
*
* THIS CALL IS MADE DURING TABLE UNLOAD INITIALIZATION. IT
* HAPPENS ONCE PER TABLE TO BE UNLOADED TO ALLOW SELECTION OF
* WHETHER OR NOT TO PROCESS THE TABLE WITH THE EXIT.
*
* R15 RETURN CODES FROM INITIALIZE:
*
* 0 = ACTIVATE EXIT FOR RECORDS FROM THIS TABLE
* 4 = DON'T USE THE EXIT FOR THIS TABLE.
* ANYTHING ELSE = TERMINATE THE RUN.
*
*
* X'02' = TERMINATION/CLEANUP CALL
*
* THIS CALL IS MADE JUST PRIOR TO TERMINATION OF THE UNLOAD
* TO ALLOW YOU TO PERFORM ANY CLEANUP FUNCTIONS NECESSARY.
*
* RETURN CODES FOR TERMINATE ARE IGNORED.
*
*
* FOR ANY EXIT FUNCTION, THE EXIT MAY INSERT MESSAGE TEXT IN THE
* MESSAGE AREA FOR PRINTING UPON RETURN.
*
* ANOTHER AREA OF INTEREST IS THE COMMON AREA DATA BLOCK. ITS STORAGE
* IS GETMAIN'D DURING THE INITIALIZATION CALL AND IS SHARABLE BY
* EACH TASK INVOKING THE EXIT. AS A RESULT, A LOCKING MECHANISM MUST
* BE USED TO SERIALIZE PROCESSING(FUNCTION CALL 0 ONLY) WITH THE LOCK
* BEING RELEASED AFTER EACH RECORD IS PROCESSED. THIS COMMON AREA
* ALLOWS OUTPUT OF SELECTED RECORDS TO A DATASET WRITTEN BY THE EXIT.
* USAGE OF AN AREA LIKE THIS IS NOT REQUIRED UNLESS MODIFICATION OF
* DATA, OUTPUT TO A DATASET, ETC. IS PLANNED FOR THE EXIT AND A
* MULTITASKING ENVIRONMENT IS IN EFFECT.
*
**********************************************************************
EJECT
**********************************************************************
* INTERNAL REGISTER USAGE
**********************************************************************
*
* 0 - ON ENTRY TO MODULE = FUNCTION CODE = COPIED TO R2
* 1 - ON ENTRY TO MODULE = A(ADUEXITP BLOCK) COPIED TO R10
* 2 - FUNCTION CODE HOLDER UNTIL BRANCH CODE
* 3 -
* 4 - A(COMMON AREA) GETMAIN AREA
* 5 - A(DCB) USED FOR OUTPUT OF SELECTED RECORDS BY THE EXIT
* 6 -
* 7 -
* 8 -
* 9 -
* 10 - A(ADUEXITP DSECT BLOCK)
* 11 - A(WORKAREA) CONTAINING THE SAVE AREA, TABLE CREATOR AND
* TABLE NAME. THIS AREA IS GETMAIN'D ON EACH ENTRY AND FREEMAIN'D
* ON EACH EXIT TO ALLOW EXIT INVOCATION IN A MULTITASKING
* ENVIRONMENT.
* 12 - BASEREG
* 13 - SAVEAREA
* 14 -
* 15 -
*
**********************************************************************
*
R0 EQU 0 R
R1 EQU 1 E
R2 EQU 2 G
R3 EQU 3 I
R4 EQU 4 S
R5 EQU 5 T
R6 EQU 6 E
R7 EQU 7 R
R8 EQU 8
R9 EQU 9 E
R10 EQU 10 Q
R11 EQU 11 U
R12 EQU 12 A
R13 EQU 13 T
R14 EQU 14 E
R15 EQU 15 S
*
**********************************************************************
* ADUEXITP DEFINES THE UNLOAD USER EXIT PARM BLOCK
* YOU MAY NOT MODIFY THE FIELDS IN FRONT OF THE USER AREA
*
* NOTE THAT THE UNLOAD USER EXIT PARM BLOCK IS UNIQUE FOR EACH
* INVOCATION OF THE EXIT. ANY ADDRESSES STORED INTO/MODIFICATIONS
* MADE TO THE USER PORTION OF THIS Control BLOCK ARE NOT SHARABLE
* IN A MULTITASKING ENVIRONMENT.
**********************************************************************
*
ADUEXITP DSECT , PARMS PASSED TO EXIT
XPFUNC DS F 0 = PROCESS, 1 = INIT, 2=TERMINATE
XPSQLDA@ DS F A(SQLDA) FOR THIS TABLE
XPTABLE@ DS F A(TABLE NAME BEING UNLOADED)
* THE ABOVE POINTS TO 128 BYTE CREATOR, FOLLOWED BY 128 BYTE NAME
DS H RESERVED FOR UNLOAD PLUS
XPREF# DS H BLOCK REFERENCE#
XPSSID@ DS F A(SSID) 4 BYTES
XPUSER@ DS F A(USERID) 8 BYTES
XPUTID@ DS F A(UTILITY ID) 16 BYTES
DS 6F RESERVED FOR UNLOAD PLUS
*
** USER AREA
*
* XPUSRMSG CONTAINS A SINGLE MESSAGE ENTRY. ON RETURN FROM THE EXIT,
* IF THIS FIELD IS NON-BLANK, IT IS PRINTED THEN BLANKED.
*
* XPUSRMS@ POINTS TO A MESSAGE BUFFER THAT CAN CONTAIN MULTIPLE EXIT
* MESSAGES OF EQUAL LENGTH. THESE MESSAGE(S) WILL BE
* PRINTED AFTER XPUSRMSG (IF ANY).
* FORMAT OF THE MESSAGE BUFFER AT THIS ADDRESS IS:
*
* #MSGS DS H NUMBER OF LINES, 0 = NO PRINT
* MSGSIZE DS H SIZE OF EACH LINE (MAX = 100)
* MSGTEXT DS CL(#MSGS*MSGSIZE) USER MESSAGES
*
XPUSERW@ DS F USER WORK AREA ADDRESS
XPUSERF1 DS F USER FIELD
XPUSERF2 DS F USER FIELD
XPUSERF3 DS F USER FIELD
XPUSERF4 DS F USER FIELD
XPUSERM@ DS F USER MESSAGE BUFFER ADDRESS
XPUSERM$ DS F USER MESSAGE BUFFER TOTAL SIZE
XPUSRMSG DS CL100 USER SINGLE MESSAGE AREA
*
XPFLAGS DS X VARIOUS FLAGS FOR EXIT
XPFDEBUG EQU X'01' DEBUG IS ON
DS X
*
** USER WORK SPACE
*
XPUSER DS 0F USER WORK AREA
*
XPUSRPAD DS (1024-(*-ADUEXITP))C PADDING
XPUSER$ EQU *-XPUSER
XP$ EQU *-ADUEXITP
EJECT
*
** MACRO GENERATED SQLDA AREA SAME AS EXEC SQL INCLUDE SQLDA
*
* THE SQLDA AREA IS ALSO UNIQUE FOR EACH INVOCATION OF THE EXIT.
* ANY MODIFICATIONS MADE TO DATA IN THIS AREA ARE NOT SHARABLE
* AMONG TASKS IN A MULTITASKING ENVIRONMENT.
*
SQLDA DSECT
SQLDAID DS CL8 ID
SQLDABC DS F BYTE COUNT
SQLN DS H TOTAL VARS
SQLD DS H PERTINENT VARS
SQLVAR DS 0F BEGIN VARS
SQLDSIZ EQU *-SQLDA SIZE OF FIXED PART
SQLVARN DSECT , NTH VARIABLE
SQLTYPE DS H TYPE CODE
SQLLEN DS 0H NAME LENGTH
SQLPRCSN DS X DEC PRECISION
SQLSCALE DS X DEC SCALE
SQLDATA DS A ADDR OF DATA IN OUTPUT RECORD
SQLIND DS A ADDR OF NULL FIELD BYTE (? IF NULL)
SQLNAME DS H,CL30 DESCRIBE NAME
ORG SQLNAME
SQLNAM$ DS H SIZE OF COL NAME
SQLNAM DS CL30 NAME ALONE
SQLVSIZ EQU *-SQLVARN
EJECT
**********************************************************************
* LOCAL PROGRAM WORK AREA DSECT - UNIQUE AREA THAT IS NOT SHARABLE
* DURING MULTIPLE INVOCATIONS (MULTITASKING ENVIRONMENT) -
* POINTED TO BY R11
**********************************************************************
WORKAREA DSECT ,
SAVE DS 18F LOCAL SAVE AREA
TBCREAT DS CL128 TABLE CREATOR
TBNAME DS CL128 TABLE NAME
SPARES DS XL926
WRKAREA$ EQU *-WORKAREA
EJECT
**********************************************************************
* COMMON PROGRAM WORK AREA DSECT - SHARED AREA WHOSE USE MUST BE
* SERIALIZED DURING MULTIPLE INVOCATIONS (MULTITASKING ENVRIONMENT)
* THIS AREA IS GETMAIN'D DURING THE INITIALIZATION CALL. ITS
* ADDRESS IS STORED IN THE XPUSERW@ FIELD OF ADUEXITP AND IS COPIED
* TO EACH ADUEXITP BLOCK BY UNLOAD PLUS PRIOR TO ANY PROCESS CALLS.
* THIS AREA IS POINTED TO BY R4.
**********************************************************************
COMNAREA DSECT ,
COMNLOKW DS F COMMON AREA LOCKWORD
COMN#FRE EQU 0 ..COMMON AREA UNLOCKED
COMN#HLD EQU 1 ..COMMON ARE LOCKED
*
COMNREC# DS F OUTPUT RECORD COUNT
COMNDBLW DS D DOUBLE WORD
COMNUNPK DS CL16 UNPACK AREA
COMNDATE DS CL10 DATE HOLDING AREA
*
COMNFLAG DS XL1 FLAG WORD
COMN#FND EQU X'80' ..GAMES_BEHIND COLUMN FOUND
COMN#KEP EQU X'40' ..PROCESS/DONT WRITE RECORD
COMN#DIS EQU X'20' ..DONT PROCESS/WRITE RECORD
COMN#OFF EQU X'00' ..FLAG RESET
DS XL3 SPARE
DS 4F SPARE
*
COMNMSGA DS 0F PROCESSING MESSAGE AREA
COMNMSG1 DS CL28 MESSAGE AREA 1
COMNMS1$ EQU *-COMNMSG1 MESSAGE AREA 1 LENGTH
COMNMSG2 DS CL18 MESSAGE AREA 2
COMNMS2$ EQU *-COMNMSG2 MESSAGE AREA 2 LENGTH
COMNMSG3 DS CL9 MESSAGE AREA 3
COMNMS3$ EQU *-COMNMSG3 MESSAGE AREA 3 LENGTH
COMNMSGP DS CL45 MESSAGE AREA PAD
COMNMSG$ EQU *-COMNMSGA MESSAGE AREA TOTAL LENGTH
*
COMNRECA DS CL80 DISCARD RECORD AREA
*
COMNOPNL OPEN (0),MF=L LIST FORM OF OPEN
DS 4F SPARE
*
COMNCLSL CLOSE (0),MF=L LIST FORM OF CLOSE
DS 4F SPARE
*
COMNODCB DCB DSORG=PS,MACRF=PM,DDNAME=WHATEVER
DS 0F FULLWORD ALIGN
COMNODC$ EQU *-COMNODCB DCB LENGTH
COMNAREL EQU *-COMNAREA COMMON AREA LENGTH
EJECT
PRINT NOGEN
DCBD DSORG=(PS,PO),DEVD=(DA,TA)
PRINT GEN
EJECT
**********************************************************************
* PROGRAM START
**********************************************************************
ADUEUEUE CSECT
LA R15,4 >>>>> 4 = DONT PROCESS CURRENT TABLE <<<<<
BSM 0,R14 >>>>> JUST RETURN TO CALLER <<<<<
*
STM R14,R12,12(R13) SAVE CALLERS REGS
LR R12,R15 R12 IS MY BASEREG
USING ADUEUEUE,R12 ESTABLISH ADDRESSABLITY
*
LR R2,R0 SAVE FUNCTION CODE
LR R10,R1 GET A(PASSED BLOCK)
USING ADUEXITP,R10 MAP IT
*
GETMAIN RC,LV=WRKAREA$,LOC=BELOW GET WORK AREA
LTR R15,R15 OK?
BNZ INIT9900 ..NO, ERROR
LR R11,R1 R11 = A(USER WORK AREA)
USING WORKAREA,R11 ADDRESS WORKAREA DSECT
LA R15,SAVE MY SAVE AREA@
ST R15,8(,R13) SAVE IN CALLERS SAVE AREA
ST R13,4(,R15) SAVE CALLERS SAVE AREA@ IN MINE
LR R13,R15 SET OURS CURRENT
EJECT
*
**********************************************************************
* CHECK THE FUNCTION CODE AND BRANCH TO PROCESSING ROUTINE
**********************************************************************
CHKF0000 DS 0H
C R2,MAXFUNC MAKE SURE VALID FUNC CODE
BNH CHKF0010 IF <= MAX THEN PICK A ROUTINE
MVC XPUSRMSG(L'MBADFUNC),MBADFUNC INDICATE BAD FUNCTION CODE
B RETC0008 GIVE BAD RETURN CODE
*
CHKF0010 SLL R2,2 CONVERT FOR BRANCHING
B *+4(R2) TO THE REQUESTED ROUTINE
B PROC0000 FUNC X'00' -- PROCESS A ROW
B INIT0000 FUNC X'01' -- INITIALIZE
B CLEAN000 FUNC X'02' -- CLEANUP CALL
EJECT
**********************************************************************
* INITIALIZATION ROUTINE
**********************************************************************
*
INIT0000 DS 0H
L R15,XPUTID@ GET A(UTILITY ID)
CLC =C'DEBUG',0(R15) DOES USER WANT DEBUG MESSAGES?
BNE INIT0010 ..NO, SKIP MESSAGE PROCESSING
OI XPFLAGS,XPFDEBUG ..YES, SET DEBUG FLAG
*
INIT0010 DS 0H
L R3,XPTABLE@ GET A(TABLE NAME BEING UNLOADED)
MVC TBCREAT,0(R3) COPY TABLE CREATOR
MVC TBNAME,128(R3) COPY TABLE NAME
CLC TBNAME,BBALLTBL CORRECT TABLE?
BNE RETC0004 ..NO, DONT PROCESS
*
GETMAIN RC,LV=COMNAREL, GET COMMON AREA FOR IO *
LOC=BELOW BELOW 16M
LTR R15,R15 OK?
BNZ INIT9900 ..NO, ISSUE ERROR
ST R1,XPUSERW@ SAVE GETMAIN ADDRESS
LR R4,R1 SET UP COMNAREA DSECT
USING COMNAREA,R4 ADDRESSABILITY
*
MVI COMNAREA,X'00' INITIALIZE GETMAIN AREA
L R1,=A(COMNAREL-1) LENGTH OF COMMON AREA-1
LA R0,COMNAREA+1 TARGET @ FOR MVCL
LA R14,COMNAREA FROM @ FOR MVCL
LA R15,1 SET LENGTH = 1
MVCL R0,R14 PERFORM MOVE
MVC COMNODCB(COMNODC$),OUTDCB INITIALIZE COMMON OUTPUT DCB
LA R5,COMNODCB OUTPUT DCB
USING IHADCB,R5 SET DCB ADDRESSABILITY
MVI COMNOPNL,X'80' SET END OF LIST
*
OPEN ((5),(OUTPUT)), OPEN OUTPUT DATASET *
MF=(E,COMNOPNL) MAKE IT REENTRANT
*
TM DCBOFLGS,DCBOFOPN SUCCESSFUL?
BNO INIT9910 ..NO, ISSUE ERROR
*
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO RETC0000 ..NO, NO MESSAGES
*
MVC XPUSRMSG(L'IGOT2INI),IGOT2INI SAY I GOT HERE
MVC XPUSRMSG+L'IGOT2INI(18),0(R3) I GOT THIS TABLE
B RETC0000 PROCESS THIS TABLE
*
* ERROR CONDITIONS
*
INIT9900 DS 0H GETMAIN ERROR
MVC XPUSRMSG(L'MGETMERR),MGETMERR
B RETC0008 TERMINATE THE EXECUTION
*
INIT9910 DS 0H OPEN ERROR
MVC XPUSRMSG(L'MOPENERR),MOPENERR
B RETC0008 TERMINATE THE EXECUTION
EJECT
**********************************************************************
* PROCESS A RECORD PRIOR TO WRITE
* THIS SECTION INTERROGATES A RECORD CONTAINING TEAM STANDINGS IN
* MAJOR LEAGUE BASEBALL. RECORDS FOR TEAMS THAT WERE 10 OR MORE
* GAMES BEHIND PRIOR TO JULY 1, 1994 ARE WRITTEN TO A SEPARATE
* DATASET(SYSEXIT) BY THE EXIT INSTEAD OF BEING WRITTEN TO THE
* UNLOAD DATASET(SYSREC) BY UNLOADPLUS.
**********************************************************************
PROC0000 DS 0H
ICM R4,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ PROC9900 NO COMMON AREA - ERROR
*
PROC0010 DS 0H
LA R14,COMN#FRE SERIALIZE ON COMMON AREA
LA R15,COMN#HLD
CS R14,R15,COMNLOKW ATTEMPT LOCK
BE PROC0020 GOT IT, CONTINUE
CALLDISP , RELEASE CPU
B PROC0010 TRY AGAIN
*
PROC0020 DS 0H
L R8,XPSQLDA@ GET SQLDA ADDRESS
USING SQLDA,R8
LH R9,SQLN GET NUMBER OF COLUMNS IN RECORD
LA R8,SQLDSIZ(,R8) PASS FIXED AREA
USING SQLVARN,R8
*
PROC0030 DS 0H COLUMN LOOP
CLC SQLNAM,DTCLNAME DATE COLUMN?
BNE PROC0040 ..NO, CHECK FOR GAMES BEHIND
L R7,SQLDATA GET A(DATE FIELD)
MVC COMNRECA(80),0(R7) SAVE ENTIRE RECORD
MVC COMNDATE,0(R7) SAVE DATE VALUE
B PROC0050 NOW FIND GAMES BEHIND FIELD
*
PROC0040 DS 0H
CLC SQLNAM,GBCLNAME GAMES BEHIND DATA?
BNE PROC0050 ..NO, CHECK NEXT FIELD
OI COMNFLAG,COMN#FND INDICATE COLUMN FOUND
L R7,SQLDATA GET A(GAMES BEHIND FIELD)
CLC 0(5,R7),=C' 10.0' 10 OR MORE GAMES BEHIND?
BL PROC0060 ..NO, PROCESS/DONT WRITE
CLC COMNDATE,DATECHEK ..YES, PRIOR JULY 1, 1994?
BL PROC0070 ..YES, DONT PROCESS/WRITE
B PROC0060 ..NO, PROCESS/DONT WRITE
*
PROC0050 DS 0H
LA R8,SQLVSIZ(R8) ..NO, POINT TO NEXT FIELD
BCT R9,PROC0030 LOOP
B PROC9900 GAMES BEHIND NOT FOUND - FATAL
*
* PROCESS RECORD IN UNLOAD - DONT WRITE RECORD IN EXIT
*
PROC0060 DS 0H
OI COMNFLAG,COMN#KEP SET KEEP FLAG
B PROC9000 GO FINISH UP
*
* DONT PROCESS RECORD IN UNLOAD - WRITE RECORD IN EXIT
*
PROC0070 DS 0H
OI COMNFLAG,COMN#DIS SET DISCARD FLAG
LA R5,COMNODCB GET A(OUTPUT DCB)
LA R7,COMNRECA GET A(OUTPUT RECORD)
LA R14,*+6 SET AMODE=24
BSM 0,R14
*
PUT (5),(7) WRITE RECORD TO SYSEXIT
*
LA R14,*+10 SET AMODE=31
O R14,=X'80000000'
BSM 0,R14
*
PROC9000 DS 0H
L R1,COMNREC# GET RECORD COUNT
LA R1,1(R1) INCREMENT
ST R1,COMNREC# SAVE NEW RECORD COUNT
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO PROC9050 ..NO, SKIP MESSAGE PROCESSING
CVD R1,COMNDBLW CONVERT RECORD COUNT TO DECIMAL
MVI COMNUNPK,X'40' BLANK 1ST BYTE OF UNPK AREA
MVC COMNUNPK+1(L'COMNUNPK-1),COMNUNPK AND PROPOGATE
MVI COMNMSGA,X'40' BLANK 1ST BYTE OF MSGAREA
MVC COMNMSGA+1(COMNMSG$-1),COMNMSGA AND PROPOGATE
UNPK COMNUNPK,COMNDBLW UNPACK RECORD COUNT
OI COMNUNPK+15,X'F0' TURN OFF SIGN
MVC COMNMSG1(COMNMS1$),IGOT2PRO MOVE MESSAGE TEXT
MVC COMNMSG2(COMNMS2$-2),COMNUNPK MOVE RECORD NUMBER
TM COMNFLAG,COMN#KEP KEEP THIS RECORD?
BNO PROC9010 ..NO, CHECK FOR DISCARD
MVC COMNMSG3(COMNMS3$),ACCEPT .YES, SIGNAL ACCEPTED
B PROC9020
*
PROC9010 DS 0H
TM COMNFLAG,COMN#DIS DISCARD THIS ONE?
BNO PROC9020 ..NO, MOVE COMPLETE MESSAGE
MVC COMNMSG3(COMNMS3$),DISCARD ..YES, SIGNAL ACCEPTED
*
PROC9020 DS 0H
MVC XPUSRMSG(COMNMSG$),COMNMSGA MOVE ENTIRE MESSAGE
*
PROC9050 DS 0H
TM COMNFLAG,COMN#KEP LET UNLOAD PROCESS THIS ONE??
BO RETC0000 ..YES
TM COMNFLAG,COMN#DIS ..NO, VERIFY DISCARD
BO RETC0004 DISCARD, DONT PROCESS
B RETC0000 DONT KNOW, PROCESS IN UNLOAD
*
* ERROR CONDITION
*
PROC9900 DS 0H
MVC XPUSRMSG(L'MFATLERR),MFATLERR SOMETHING IS WRONG
B RETC0008 TERMINATE PROCESSING
EJECT
**********************************************************************
* SET RETURN CODE AND EXIT POINTS
**********************************************************************
*
RETC0000 DS 0H
LA R3,0 SAVE RETURN CODE
B RET9000 NORMAL PROCESSING
*
RETC0004 DS 0H
LA R3,4 SAVE RETURN CODE
B RET9000 DONT PROCESS/DISCARD
*
RETC0008 DS 0H
LA R3,8 SAVE RETURN CODE
* TERMINATE UNLOAD+ EXEC
RET9000 DS 0H
ICM R1,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ RET9010 NO COMMON, SKIP RESETS
MVC COMNFLAG,=A(COMN#OFF) RESET FLAGS
MVC COMNLOKW,=A(COMN#FRE) RELEASE LOCK ON COMMON AREA
*
RET9010 DS 0H
L R13,SAVE+4
FREEMAIN RC,LV=WRKAREA$,A=(R11) FREE LOCAL WORK AREA
LR R15,R3 RESTORE RETURN CODE
L R14,12(,R13)
LM R0,R12,20(R13)
BSM 0,R14 RETURN
EJECT
**********************************************************************
* CLEANUP (FUNCTION CALL = 2)
**********************************************************************
CLEAN000 DS 0H
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO CLEAN010 ..NO, SKIP MESSAGE
MVC XPUSRMSG(L'IGOT2CLN),IGOT2CLN SAY I GOT HERE
*
CLEAN010 DS 0H
ICM R4,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ CLEAN020 NO @, NO CLOSE OR FREEMAIN
LA R5,COMNODCB GET A(OUTPUT DCB)
MVI COMNCLSL,X'80' SET END OF LIST
CLOSE ((5),REREAD),MF=(E,COMNCLSL) ISSUE CLOSE
*
FREEMAIN RC,LV=COMNAREL,A=(R1) FREE STORAGE
*
CLEAN020 DS 0H RETURN
L R13,SAVE+4
FREEMAIN RC,LV=WRKAREA$,A=(R11) FREE LOCAL WORK AREA
L R14,12(,R13)
LM R0,R12,20(R13)
LA R15,0
BSM 0,R14
EJECT
**********************************************************************
* CONSTANTS
**********************************************************************
DS 0F
MAXFUNC DC F'2'
ACCEPT DC CL9'ACCEPTED '
DISCARD DC CL9'DISCARDED'
MBADFUNC DC CL36'BAD FUNCTION CODE RECEIVED FROM MAIN'
MGETMERR DC CL34'GETMAIN ERROR GETTING USER STORAGE'
MOPENERR DC CL30'ERROR OPENING DDNAME SYSEXIT'
MFATLERR DC CL30'UNDETERMINED ERROR IN USEREXIT'
IGOT2INI DC CL28'UNLOAD EXIT INIT FOR TABLE: '
IGOT2PRO DC CL28'UNLOAD EXIT PROCESSING ROW: '
IGOT2CLN DC CL24'UNLOAD EXIT CLEANUP DONE'
DATECHEK DC CL10'1994-07-01'
BBALLTBL DC CL128'DXHBBALL'
DTCLNAME DC CL30'DATE'
GBCLNAME DC CL30'GAMES_BEHIND'
BLANKS DC CL8' ' SOME BLANKS
OUTDCB DCB DSORG=PS,RECFM=FB,DDNAME=SYSEXIT, *
MACRF=(PM),OPTCD=C
SPACE
LTORG ,
SPACE
END ADUEUEUE
ADUEUEUE CSECT
ADUEUEUE AMODE 31
ADUEUEUE RMODE 24
**********************************************************************
* D I S C L A I M E R
**********************************************************************
*
* THIS IS A SAMPLE UNLOAD PLUS USER EXIT. THIS EXIT WOULD BE USED
* IN ORDER TO INSPECT AND/OR MANIPULATE UNLOAD DATA RECORDS PRIOR
* TO THEIR BEING WRITTEN TO THE OUTPUT DATASET.
*
* THIS EXIT WILL ONLY BE INVOKED WHEN IT IS SPECIFICALLY NAMED
* IN THE 'UNLOADEXIT --NAME--' PARAMETER.
*
* NOTE: PLEASE REVIEW THE DOCUMENTATION IN THE REFERENCE MANUAL,
* AND THE FOLLOWING USAGE NOTES PRIOR TO IMPLEMENTING THIS EXIT.
*
* PLEASE CALL BMC PRODUCT SUPPORT WITH ANY QUESTIONS YOU MAY
* HAVE IN THIS AREA.
*
* PHONE: 1-800-537-1813
*
**********************************************************************
SPACE
**********************************************************************
* N O T E S
**********************************************************************
*
* ADUEUEUE IS CALLED AT 3 POINTS IN PROCESSING A TABLE UNLOAD.
*
* WHEN INVOKED, R0 CONTAINS A FUNCTION CODE.
*
* R1 CONTAINS THE ADDRESS OF A USER EXIT BLOCK DESCRIBED BY THE
* ADUEXITP DSECT. FIELDS FOR YOUR USE IN THIS BLOCK ARE DESCRIBED
* IN THE DSECT. THE USER EXIT BLOCK IS UNIQUE FOR EACH TASK INVOKING
* THE EXIT AND IS NOT SHAREABLE BY MULTIPLE TASKS.
*
* THE MAIN FIELD OF INTEREST IS THE PSEUDO-SQLDA POINTER XPSQLDA@
* WHICH POINTS TO AN 'SQLDA' PREPARED FOR EACH SELECTED UNLOAD TABLE.
* THIS SQLDA HAS THE SAME FORMAT AND CONTENTS OF A DB2 SQLDA, WITH THE
* MAIN EXCEPTION BEING THAT THE DESCRIPTIONS OF THE DATA FIELDS ARE
* THE OUTPUT DESCRIPTIONS (AFTER CONVERSIONS IF ANY), AND THE DATA
* POINTERS ARE POINTING TO THE OUTPUT RECORD OFFSETS IN THE RECORD
* ABOUT TO BE WRITTEN (FUNCTION CALL 0 ONLY).
*
* FUNCTION CODES:
*
* X'00' = PROCESS RECORD
*
* THIS CALL IS MADE AFTER A RECORD IS PREPARED FOR WRITING.
* ALL FIELDS ARE CONVERTED READY FOR OUTPUT. THE SQLDA
* PROVIDES THE FIELD TYPES AND RECORD POSITIONS OF THE DATA.
* THE UNLOAD EXIT PARM BLOCK PASSED WITH THIS FUNCTION IS
* UNIQUE FOR EACH UNLOAD TASK INVOKING THE EXIT AND IS NOT
* SHARABLE AMONG MULTIPLE TASKS.
*
* R15 RETURN CODES FROM PROCESS:
*
* 0 = ACCEPT THIS RECORD
* 4 = DISCARD THIS RECORD
* ANYTHING ELSE = TERMINATE THE RUN.
*
*
* X'01' = INITIALIZATION CALL
*
* THIS CALL IS MADE DURING TABLE UNLOAD INITIALIZATION. IT
* HAPPENS ONCE PER TABLE TO BE UNLOADED TO ALLOW SELECTION OF
* WHETHER OR NOT TO PROCESS THE TABLE WITH THE EXIT.
*
* R15 RETURN CODES FROM INITIALIZE:
*
* 0 = ACTIVATE EXIT FOR RECORDS FROM THIS TABLE
* 4 = DON'T USE THE EXIT FOR THIS TABLE.
* ANYTHING ELSE = TERMINATE THE RUN.
*
*
* X'02' = TERMINATION/CLEANUP CALL
*
* THIS CALL IS MADE JUST PRIOR TO TERMINATION OF THE UNLOAD
* TO ALLOW YOU TO PERFORM ANY CLEANUP FUNCTIONS NECESSARY.
*
* RETURN CODES FOR TERMINATE ARE IGNORED.
*
*
* FOR ANY EXIT FUNCTION, THE EXIT MAY INSERT MESSAGE TEXT IN THE
* MESSAGE AREA FOR PRINTING UPON RETURN.
*
* ANOTHER AREA OF INTEREST IS THE COMMON AREA DATA BLOCK. ITS STORAGE
* IS GETMAIN'D DURING THE INITIALIZATION CALL AND IS SHARABLE BY
* EACH TASK INVOKING THE EXIT. AS A RESULT, A LOCKING MECHANISM MUST
* BE USED TO SERIALIZE PROCESSING(FUNCTION CALL 0 ONLY) WITH THE LOCK
* BEING RELEASED AFTER EACH RECORD IS PROCESSED. THIS COMMON AREA
* ALLOWS OUTPUT OF SELECTED RECORDS TO A DATASET WRITTEN BY THE EXIT.
* USAGE OF AN AREA LIKE THIS IS NOT REQUIRED UNLESS MODIFICATION OF
* DATA, OUTPUT TO A DATASET, ETC. IS PLANNED FOR THE EXIT AND A
* MULTITASKING ENVIRONMENT IS IN EFFECT.
*
**********************************************************************
EJECT
**********************************************************************
* INTERNAL REGISTER USAGE
**********************************************************************
*
* 0 - ON ENTRY TO MODULE = FUNCTION CODE = COPIED TO R2
* 1 - ON ENTRY TO MODULE = A(ADUEXITP BLOCK) COPIED TO R10
* 2 - FUNCTION CODE HOLDER UNTIL BRANCH CODE
* 3 -
* 4 - A(COMMON AREA) GETMAIN AREA
* 5 - A(DCB) USED FOR OUTPUT OF SELECTED RECORDS BY THE EXIT
* 6 -
* 7 -
* 8 -
* 9 -
* 10 - A(ADUEXITP DSECT BLOCK)
* 11 - A(WORKAREA) CONTAINING THE SAVE AREA, TABLE CREATOR AND
* TABLE NAME. THIS AREA IS GETMAIN'D ON EACH ENTRY AND FREEMAIN'D
* ON EACH EXIT TO ALLOW EXIT INVOCATION IN A MULTITASKING
* ENVIRONMENT.
* 12 - BASEREG
* 13 - SAVEAREA
* 14 -
* 15 -
*
**********************************************************************
*
R0 EQU 0 R
R1 EQU 1 E
R2 EQU 2 G
R3 EQU 3 I
R4 EQU 4 S
R5 EQU 5 T
R6 EQU 6 E
R7 EQU 7 R
R8 EQU 8
R9 EQU 9 E
R10 EQU 10 Q
R11 EQU 11 U
R12 EQU 12 A
R13 EQU 13 T
R14 EQU 14 E
R15 EQU 15 S
*
**********************************************************************
* ADUEXITP DEFINES THE UNLOAD USER EXIT PARM BLOCK
* YOU MAY NOT MODIFY THE FIELDS IN FRONT OF THE USER AREA
*
* NOTE THAT THE UNLOAD USER EXIT PARM BLOCK IS UNIQUE FOR EACH
* INVOCATION OF THE EXIT. ANY ADDRESSES STORED INTO/MODIFICATIONS
* MADE TO THE USER PORTION OF THIS Control BLOCK ARE NOT SHARABLE
* IN A MULTITASKING ENVIRONMENT.
**********************************************************************
*
ADUEXITP DSECT , PARMS PASSED TO EXIT
XPFUNC DS F 0 = PROCESS, 1 = INIT, 2=TERMINATE
XPSQLDA@ DS F A(SQLDA) FOR THIS TABLE
XPTABLE@ DS F A(TABLE NAME BEING UNLOADED)
* THE ABOVE POINTS TO 128 BYTE CREATOR, FOLLOWED BY 128 BYTE NAME
DS H RESERVED FOR UNLOAD PLUS
XPREF# DS H BLOCK REFERENCE#
XPSSID@ DS F A(SSID) 4 BYTES
XPUSER@ DS F A(USERID) 8 BYTES
XPUTID@ DS F A(UTILITY ID) 16 BYTES
DS 6F RESERVED FOR UNLOAD PLUS
*
** USER AREA
*
* XPUSRMSG CONTAINS A SINGLE MESSAGE ENTRY. ON RETURN FROM THE EXIT,
* IF THIS FIELD IS NON-BLANK, IT IS PRINTED THEN BLANKED.
*
* XPUSRMS@ POINTS TO A MESSAGE BUFFER THAT CAN CONTAIN MULTIPLE EXIT
* MESSAGES OF EQUAL LENGTH. THESE MESSAGE(S) WILL BE
* PRINTED AFTER XPUSRMSG (IF ANY).
* FORMAT OF THE MESSAGE BUFFER AT THIS ADDRESS IS:
*
* #MSGS DS H NUMBER OF LINES, 0 = NO PRINT
* MSGSIZE DS H SIZE OF EACH LINE (MAX = 100)
* MSGTEXT DS CL(#MSGS*MSGSIZE) USER MESSAGES
*
XPUSERW@ DS F USER WORK AREA ADDRESS
XPUSERF1 DS F USER FIELD
XPUSERF2 DS F USER FIELD
XPUSERF3 DS F USER FIELD
XPUSERF4 DS F USER FIELD
XPUSERM@ DS F USER MESSAGE BUFFER ADDRESS
XPUSERM$ DS F USER MESSAGE BUFFER TOTAL SIZE
XPUSRMSG DS CL100 USER SINGLE MESSAGE AREA
*
XPFLAGS DS X VARIOUS FLAGS FOR EXIT
XPFDEBUG EQU X'01' DEBUG IS ON
DS X
*
** USER WORK SPACE
*
XPUSER DS 0F USER WORK AREA
*
XPUSRPAD DS (1024-(*-ADUEXITP))C PADDING
XPUSER$ EQU *-XPUSER
XP$ EQU *-ADUEXITP
EJECT
*
** MACRO GENERATED SQLDA AREA SAME AS EXEC SQL INCLUDE SQLDA
*
* THE SQLDA AREA IS ALSO UNIQUE FOR EACH INVOCATION OF THE EXIT.
* ANY MODIFICATIONS MADE TO DATA IN THIS AREA ARE NOT SHARABLE
* AMONG TASKS IN A MULTITASKING ENVIRONMENT.
*
SQLDA DSECT
SQLDAID DS CL8 ID
SQLDABC DS F BYTE COUNT
SQLN DS H TOTAL VARS
SQLD DS H PERTINENT VARS
SQLVAR DS 0F BEGIN VARS
SQLDSIZ EQU *-SQLDA SIZE OF FIXED PART
SQLVARN DSECT , NTH VARIABLE
SQLTYPE DS H TYPE CODE
SQLLEN DS 0H NAME LENGTH
SQLPRCSN DS X DEC PRECISION
SQLSCALE DS X DEC SCALE
SQLDATA DS A ADDR OF DATA IN OUTPUT RECORD
SQLIND DS A ADDR OF NULL FIELD BYTE (? IF NULL)
SQLNAME DS H,CL30 DESCRIBE NAME
ORG SQLNAME
SQLNAM$ DS H SIZE OF COL NAME
SQLNAM DS CL30 NAME ALONE
SQLVSIZ EQU *-SQLVARN
EJECT
**********************************************************************
* LOCAL PROGRAM WORK AREA DSECT - UNIQUE AREA THAT IS NOT SHARABLE
* DURING MULTIPLE INVOCATIONS (MULTITASKING ENVIRONMENT) -
* POINTED TO BY R11
**********************************************************************
WORKAREA DSECT ,
SAVE DS 18F LOCAL SAVE AREA
TBCREAT DS CL128 TABLE CREATOR
TBNAME DS CL128 TABLE NAME
SPARES DS XL926
WRKAREA$ EQU *-WORKAREA
EJECT
**********************************************************************
* COMMON PROGRAM WORK AREA DSECT - SHARED AREA WHOSE USE MUST BE
* SERIALIZED DURING MULTIPLE INVOCATIONS (MULTITASKING ENVRIONMENT)
* THIS AREA IS GETMAIN'D DURING THE INITIALIZATION CALL. ITS
* ADDRESS IS STORED IN THE XPUSERW@ FIELD OF ADUEXITP AND IS COPIED
* TO EACH ADUEXITP BLOCK BY UNLOAD PLUS PRIOR TO ANY PROCESS CALLS.
* THIS AREA IS POINTED TO BY R4.
**********************************************************************
COMNAREA DSECT ,
COMNLOKW DS F COMMON AREA LOCKWORD
COMN#FRE EQU 0 ..COMMON AREA UNLOCKED
COMN#HLD EQU 1 ..COMMON ARE LOCKED
*
COMNREC# DS F OUTPUT RECORD COUNT
COMNDBLW DS D DOUBLE WORD
COMNUNPK DS CL16 UNPACK AREA
COMNDATE DS CL10 DATE HOLDING AREA
*
COMNFLAG DS XL1 FLAG WORD
COMN#FND EQU X'80' ..GAMES_BEHIND COLUMN FOUND
COMN#KEP EQU X'40' ..PROCESS/DONT WRITE RECORD
COMN#DIS EQU X'20' ..DONT PROCESS/WRITE RECORD
COMN#OFF EQU X'00' ..FLAG RESET
DS XL3 SPARE
DS 4F SPARE
*
COMNMSGA DS 0F PROCESSING MESSAGE AREA
COMNMSG1 DS CL28 MESSAGE AREA 1
COMNMS1$ EQU *-COMNMSG1 MESSAGE AREA 1 LENGTH
COMNMSG2 DS CL18 MESSAGE AREA 2
COMNMS2$ EQU *-COMNMSG2 MESSAGE AREA 2 LENGTH
COMNMSG3 DS CL9 MESSAGE AREA 3
COMNMS3$ EQU *-COMNMSG3 MESSAGE AREA 3 LENGTH
COMNMSGP DS CL45 MESSAGE AREA PAD
COMNMSG$ EQU *-COMNMSGA MESSAGE AREA TOTAL LENGTH
*
COMNRECA DS CL80 DISCARD RECORD AREA
*
COMNOPNL OPEN (0),MF=L LIST FORM OF OPEN
DS 4F SPARE
*
COMNCLSL CLOSE (0),MF=L LIST FORM OF CLOSE
DS 4F SPARE
*
COMNODCB DCB DSORG=PS,MACRF=PM,DDNAME=WHATEVER
DS 0F FULLWORD ALIGN
COMNODC$ EQU *-COMNODCB DCB LENGTH
COMNAREL EQU *-COMNAREA COMMON AREA LENGTH
EJECT
PRINT NOGEN
DCBD DSORG=(PS,PO),DEVD=(DA,TA)
PRINT GEN
EJECT
**********************************************************************
* PROGRAM START
**********************************************************************
ADUEUEUE CSECT
LA R15,4 >>>>> 4 = DONT PROCESS CURRENT TABLE <<<<<
BSM 0,R14 >>>>> JUST RETURN TO CALLER <<<<<
*
STM R14,R12,12(R13) SAVE CALLERS REGS
LR R12,R15 R12 IS MY BASEREG
USING ADUEUEUE,R12 ESTABLISH ADDRESSABLITY
*
LR R2,R0 SAVE FUNCTION CODE
LR R10,R1 GET A(PASSED BLOCK)
USING ADUEXITP,R10 MAP IT
*
GETMAIN RC,LV=WRKAREA$,LOC=BELOW GET WORK AREA
LTR R15,R15 OK?
BNZ INIT9900 ..NO, ERROR
LR R11,R1 R11 = A(USER WORK AREA)
USING WORKAREA,R11 ADDRESS WORKAREA DSECT
LA R15,SAVE MY SAVE AREA@
ST R15,8(,R13) SAVE IN CALLERS SAVE AREA
ST R13,4(,R15) SAVE CALLERS SAVE AREA@ IN MINE
LR R13,R15 SET OURS CURRENT
EJECT
*
**********************************************************************
* CHECK THE FUNCTION CODE AND BRANCH TO PROCESSING ROUTINE
**********************************************************************
CHKF0000 DS 0H
C R2,MAXFUNC MAKE SURE VALID FUNC CODE
BNH CHKF0010 IF <= MAX THEN PICK A ROUTINE
MVC XPUSRMSG(L'MBADFUNC),MBADFUNC INDICATE BAD FUNCTION CODE
B RETC0008 GIVE BAD RETURN CODE
*
CHKF0010 SLL R2,2 CONVERT FOR BRANCHING
B *+4(R2) TO THE REQUESTED ROUTINE
B PROC0000 FUNC X'00' -- PROCESS A ROW
B INIT0000 FUNC X'01' -- INITIALIZE
B CLEAN000 FUNC X'02' -- CLEANUP CALL
EJECT
**********************************************************************
* INITIALIZATION ROUTINE
**********************************************************************
*
INIT0000 DS 0H
L R15,XPUTID@ GET A(UTILITY ID)
CLC =C'DEBUG',0(R15) DOES USER WANT DEBUG MESSAGES?
BNE INIT0010 ..NO, SKIP MESSAGE PROCESSING
OI XPFLAGS,XPFDEBUG ..YES, SET DEBUG FLAG
*
INIT0010 DS 0H
L R3,XPTABLE@ GET A(TABLE NAME BEING UNLOADED)
MVC TBCREAT,0(R3) COPY TABLE CREATOR
MVC TBNAME,128(R3) COPY TABLE NAME
CLC TBNAME,BBALLTBL CORRECT TABLE?
BNE RETC0004 ..NO, DONT PROCESS
*
GETMAIN RC,LV=COMNAREL, GET COMMON AREA FOR IO *
LOC=BELOW BELOW 16M
LTR R15,R15 OK?
BNZ INIT9900 ..NO, ISSUE ERROR
ST R1,XPUSERW@ SAVE GETMAIN ADDRESS
LR R4,R1 SET UP COMNAREA DSECT
USING COMNAREA,R4 ADDRESSABILITY
*
MVI COMNAREA,X'00' INITIALIZE GETMAIN AREA
L R1,=A(COMNAREL-1) LENGTH OF COMMON AREA-1
LA R0,COMNAREA+1 TARGET @ FOR MVCL
LA R14,COMNAREA FROM @ FOR MVCL
LA R15,1 SET LENGTH = 1
MVCL R0,R14 PERFORM MOVE
MVC COMNODCB(COMNODC$),OUTDCB INITIALIZE COMMON OUTPUT DCB
LA R5,COMNODCB OUTPUT DCB
USING IHADCB,R5 SET DCB ADDRESSABILITY
MVI COMNOPNL,X'80' SET END OF LIST
*
OPEN ((5),(OUTPUT)), OPEN OUTPUT DATASET *
MF=(E,COMNOPNL) MAKE IT REENTRANT
*
TM DCBOFLGS,DCBOFOPN SUCCESSFUL?
BNO INIT9910 ..NO, ISSUE ERROR
*
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO RETC0000 ..NO, NO MESSAGES
*
MVC XPUSRMSG(L'IGOT2INI),IGOT2INI SAY I GOT HERE
MVC XPUSRMSG+L'IGOT2INI(18),0(R3) I GOT THIS TABLE
B RETC0000 PROCESS THIS TABLE
*
* ERROR CONDITIONS
*
INIT9900 DS 0H GETMAIN ERROR
MVC XPUSRMSG(L'MGETMERR),MGETMERR
B RETC0008 TERMINATE THE EXECUTION
*
INIT9910 DS 0H OPEN ERROR
MVC XPUSRMSG(L'MOPENERR),MOPENERR
B RETC0008 TERMINATE THE EXECUTION
EJECT
**********************************************************************
* PROCESS A RECORD PRIOR TO WRITE
* THIS SECTION INTERROGATES A RECORD CONTAINING TEAM STANDINGS IN
* MAJOR LEAGUE BASEBALL. RECORDS FOR TEAMS THAT WERE 10 OR MORE
* GAMES BEHIND PRIOR TO JULY 1, 1994 ARE WRITTEN TO A SEPARATE
* DATASET(SYSEXIT) BY THE EXIT INSTEAD OF BEING WRITTEN TO THE
* UNLOAD DATASET(SYSREC) BY UNLOADPLUS.
**********************************************************************
PROC0000 DS 0H
ICM R4,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ PROC9900 NO COMMON AREA - ERROR
*
PROC0010 DS 0H
LA R14,COMN#FRE SERIALIZE ON COMMON AREA
LA R15,COMN#HLD
CS R14,R15,COMNLOKW ATTEMPT LOCK
BE PROC0020 GOT IT, CONTINUE
CALLDISP , RELEASE CPU
B PROC0010 TRY AGAIN
*
PROC0020 DS 0H
L R8,XPSQLDA@ GET SQLDA ADDRESS
USING SQLDA,R8
LH R9,SQLN GET NUMBER OF COLUMNS IN RECORD
LA R8,SQLDSIZ(,R8) PASS FIXED AREA
USING SQLVARN,R8
*
PROC0030 DS 0H COLUMN LOOP
CLC SQLNAM,DTCLNAME DATE COLUMN?
BNE PROC0040 ..NO, CHECK FOR GAMES BEHIND
L R7,SQLDATA GET A(DATE FIELD)
MVC COMNRECA(80),0(R7) SAVE ENTIRE RECORD
MVC COMNDATE,0(R7) SAVE DATE VALUE
B PROC0050 NOW FIND GAMES BEHIND FIELD
*
PROC0040 DS 0H
CLC SQLNAM,GBCLNAME GAMES BEHIND DATA?
BNE PROC0050 ..NO, CHECK NEXT FIELD
OI COMNFLAG,COMN#FND INDICATE COLUMN FOUND
L R7,SQLDATA GET A(GAMES BEHIND FIELD)
CLC 0(5,R7),=C' 10.0' 10 OR MORE GAMES BEHIND?
BL PROC0060 ..NO, PROCESS/DONT WRITE
CLC COMNDATE,DATECHEK ..YES, PRIOR JULY 1, 1994?
BL PROC0070 ..YES, DONT PROCESS/WRITE
B PROC0060 ..NO, PROCESS/DONT WRITE
*
PROC0050 DS 0H
LA R8,SQLVSIZ(R8) ..NO, POINT TO NEXT FIELD
BCT R9,PROC0030 LOOP
B PROC9900 GAMES BEHIND NOT FOUND - FATAL
*
* PROCESS RECORD IN UNLOAD - DONT WRITE RECORD IN EXIT
*
PROC0060 DS 0H
OI COMNFLAG,COMN#KEP SET KEEP FLAG
B PROC9000 GO FINISH UP
*
* DONT PROCESS RECORD IN UNLOAD - WRITE RECORD IN EXIT
*
PROC0070 DS 0H
OI COMNFLAG,COMN#DIS SET DISCARD FLAG
LA R5,COMNODCB GET A(OUTPUT DCB)
LA R7,COMNRECA GET A(OUTPUT RECORD)
LA R14,*+6 SET AMODE=24
BSM 0,R14
*
PUT (5),(7) WRITE RECORD TO SYSEXIT
*
LA R14,*+10 SET AMODE=31
O R14,=X'80000000'
BSM 0,R14
*
PROC9000 DS 0H
L R1,COMNREC# GET RECORD COUNT
LA R1,1(R1) INCREMENT
ST R1,COMNREC# SAVE NEW RECORD COUNT
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO PROC9050 ..NO, SKIP MESSAGE PROCESSING
CVD R1,COMNDBLW CONVERT RECORD COUNT TO DECIMAL
MVI COMNUNPK,X'40' BLANK 1ST BYTE OF UNPK AREA
MVC COMNUNPK+1(L'COMNUNPK-1),COMNUNPK AND PROPOGATE
MVI COMNMSGA,X'40' BLANK 1ST BYTE OF MSGAREA
MVC COMNMSGA+1(COMNMSG$-1),COMNMSGA AND PROPOGATE
UNPK COMNUNPK,COMNDBLW UNPACK RECORD COUNT
OI COMNUNPK+15,X'F0' TURN OFF SIGN
MVC COMNMSG1(COMNMS1$),IGOT2PRO MOVE MESSAGE TEXT
MVC COMNMSG2(COMNMS2$-2),COMNUNPK MOVE RECORD NUMBER
TM COMNFLAG,COMN#KEP KEEP THIS RECORD?
BNO PROC9010 ..NO, CHECK FOR DISCARD
MVC COMNMSG3(COMNMS3$),ACCEPT .YES, SIGNAL ACCEPTED
B PROC9020
*
PROC9010 DS 0H
TM COMNFLAG,COMN#DIS DISCARD THIS ONE?
BNO PROC9020 ..NO, MOVE COMPLETE MESSAGE
MVC COMNMSG3(COMNMS3$),DISCARD ..YES, SIGNAL ACCEPTED
*
PROC9020 DS 0H
MVC XPUSRMSG(COMNMSG$),COMNMSGA MOVE ENTIRE MESSAGE
*
PROC9050 DS 0H
TM COMNFLAG,COMN#KEP LET UNLOAD PROCESS THIS ONE??
BO RETC0000 ..YES
TM COMNFLAG,COMN#DIS ..NO, VERIFY DISCARD
BO RETC0004 DISCARD, DONT PROCESS
B RETC0000 DONT KNOW, PROCESS IN UNLOAD
*
* ERROR CONDITION
*
PROC9900 DS 0H
MVC XPUSRMSG(L'MFATLERR),MFATLERR SOMETHING IS WRONG
B RETC0008 TERMINATE PROCESSING
EJECT
**********************************************************************
* SET RETURN CODE AND EXIT POINTS
**********************************************************************
*
RETC0000 DS 0H
LA R3,0 SAVE RETURN CODE
B RET9000 NORMAL PROCESSING
*
RETC0004 DS 0H
LA R3,4 SAVE RETURN CODE
B RET9000 DONT PROCESS/DISCARD
*
RETC0008 DS 0H
LA R3,8 SAVE RETURN CODE
* TERMINATE UNLOAD+ EXEC
RET9000 DS 0H
ICM R1,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ RET9010 NO COMMON, SKIP RESETS
MVC COMNFLAG,=A(COMN#OFF) RESET FLAGS
MVC COMNLOKW,=A(COMN#FRE) RELEASE LOCK ON COMMON AREA
*
RET9010 DS 0H
L R13,SAVE+4
FREEMAIN RC,LV=WRKAREA$,A=(R11) FREE LOCAL WORK AREA
LR R15,R3 RESTORE RETURN CODE
L R14,12(,R13)
LM R0,R12,20(R13)
BSM 0,R14 RETURN
EJECT
**********************************************************************
* CLEANUP (FUNCTION CALL = 2)
**********************************************************************
CLEAN000 DS 0H
TM XPFLAGS,XPFDEBUG IS DEBUG ON?
BNO CLEAN010 ..NO, SKIP MESSAGE
MVC XPUSRMSG(L'IGOT2CLN),IGOT2CLN SAY I GOT HERE
*
CLEAN010 DS 0H
ICM R4,B'1111',XPUSERW@ GET A(COMMON AREA)
BZ CLEAN020 NO @, NO CLOSE OR FREEMAIN
LA R5,COMNODCB GET A(OUTPUT DCB)
MVI COMNCLSL,X'80' SET END OF LIST
CLOSE ((5),REREAD),MF=(E,COMNCLSL) ISSUE CLOSE
*
FREEMAIN RC,LV=COMNAREL,A=(R1) FREE STORAGE
*
CLEAN020 DS 0H RETURN
L R13,SAVE+4
FREEMAIN RC,LV=WRKAREA$,A=(R11) FREE LOCAL WORK AREA
L R14,12(,R13)
LM R0,R12,20(R13)
LA R15,0
BSM 0,R14
EJECT
**********************************************************************
* CONSTANTS
**********************************************************************
DS 0F
MAXFUNC DC F'2'
ACCEPT DC CL9'ACCEPTED '
DISCARD DC CL9'DISCARDED'
MBADFUNC DC CL36'BAD FUNCTION CODE RECEIVED FROM MAIN'
MGETMERR DC CL34'GETMAIN ERROR GETTING USER STORAGE'
MOPENERR DC CL30'ERROR OPENING DDNAME SYSEXIT'
MFATLERR DC CL30'UNDETERMINED ERROR IN USEREXIT'
IGOT2INI DC CL28'UNLOAD EXIT INIT FOR TABLE: '
IGOT2PRO DC CL28'UNLOAD EXIT PROCESSING ROW: '
IGOT2CLN DC CL24'UNLOAD EXIT CLEANUP DONE'
DATECHEK DC CL10'1994-07-01'
BBALLTBL DC CL128'DXHBBALL'
DTCLNAME DC CL30'DATE'
GBCLNAME DC CL30'GAMES_BEHIND'
BLANKS DC CL8' ' SOME BLANKS
OUTDCB DCB DSORG=PS,RECFM=FB,DDNAME=SYSEXIT, *
MACRF=(PM),OPTCD=C
SPACE
LTORG ,
SPACE
END ADUEUEUE
Tip: For faster searching, add an asterisk to the end of your partial query. Example: cert*