Functions
This is a sample CA IDMS VSAM Transparency user exit written in Assembler. It is functionally equivalent to the sample COBOL exit in Sample COBOL User Exit. The source code for this program is provided on the installation media with CA IDMS VSAM Transparency (member name ESVSXITA).
This exit allows you to convert the VSAM structure into CA IDMS/DB structure.
VSAM Structure (Variable Length KSDS Record)
CA IDMS Structure
The user exit must navigate the database and build the record that the VSAM application program is expecting.
Functions as Before Exit
This exit is invoked both before and after any DML processing. As a before exit, it performs the following functions:
Functions as After Exit
As an after exit, it performs the following functions:
Sample Assembler Exit
*** *
*** THIS EXIT IS INVOKED USING STANDARD z/OS LINKAGE; *
*** BALR 14,15 (FROM CALLING PROGRAM) *
*** STM 14,12,12(13) (FIRST THING IN CALLED PROGRAM) *
*** BR 14 (TO RETURN) *
*** *
*** REGISTER USAGE CONVENTIONS ARE: *
*** *
*** R1 -─► SET UP TO SSC FOR EXITIDMS *
*** R2 -─► SUBSCHEMA CONTROL DSECT *
*** R3 -─► EXIT DSECT *
*** R4 -─► COVERAGE RECORD DSECT/WORK REGISTER *
*** R5 -─► WORK AREA FOR MOVE OF RECORD *
*** R6 -─► WORK REGISTER *
*** R7 -─► WORK AREA FOR CONVERSION *
*** R8 -─► POLICY RECORD DSECT *
*** R9 -─► TCE *
*** R10 -─► CSA *
*** R11 -─► SAVE AREA *
*** R12 -─► BASE REGISTER *
*** R13 -─► SAVE AREA *
*** R14 -─► USED BY CALL CONVENTION *
*** R15 -─► USED BY CALL CONVENTIONS *
*** *
*** INPUT: *
*** *
*** R1 -─► PARAMETER LIST *
*** R1+0 -─► ADDRESS OF EXB *
*** R1+4 -─► ADDRESS OF SSC *
*** R1+8 -─► ADDRESS OF RECORD BUFFER *
*********************************************************************
EJECT
ESVSXITA CSECT
#MOPT ENV=USER
@MODE MODE=BATCH,QUOTES=YES,DEBUG=YES
* SPECIFY OPERATING ENVIRONMENT,
* NOTATION CONVENTION, DEBUG OPTION
BEGIN STM R14,R12,12(R13) SAVE CALLER'S REGISTERS
BALR R12,0 ESTABLISH R12 AS BASE
USING *,R12
SPACE
B START BRANCH AROUND LITERAL
*
DC CL8'ESVSXITA' EYECATCHER
*
USING SSC,R2 SUBSCHEMA CONTROL ADDRESSIBILITY
USING EXBDS,R3 EXIT DSECT ADDRESSABILITY
USING COVERAGE,R4 COVERAGE RECORD ADDRESSIBILITY
USING RECORD,R8 POLICY RECORD ADDRESSIBILITY
USING CSA,R10 COMMON SYSTEM AREA ADDRESSIBILITY
SPACE
START EQU *
LR R7,R13 SAVE R13
L R3,0(R1) R3 ─► EXB
L R2,4(R1) R2 ─► SSC
L R8,8(R1) R8 ─► RECORD BUFFER
LA R13,EXBSAVE R13 ─► USER SAVE AREA
SPACE
***
*** ACQUIRE STORAGE FOR EXIT TO USE
***
GETSTG #GETSTG TYPE=(USER,SHORT),PLIST=*,LEN=50,INIT=0, X
ADDR=(R4),ERROR=STGERROR
SPACE
*
EJECT
* CHECK TO SEE IF THIS IS A BEFORE EXIT WITH A PUT REQUEST
CHKBEFOR CLI EXBXEXIT,C'B' CALLING BEFORE EXIT??
BNE CHKAFTER NO, CHECK FOR AFTER EXIT
CLC EXBRTYPE,=CL6'PUT' IS THIS A PUT REQUEST??
BNE CHKERASE NO, DON'T DO ANYTHING ELSE
SPACE
* BEFORE EXIT - PUT REQUEST
* MOVE ZERO TO CONTROL FIELD
BEFORPUT MVC CNTLFLD,=H'00' MOVE ZERO TO OCCURS FIELD
B RTN RETURN
EJECT
* CHECK TO SEE IF THIS IS AN BEFORE EXIT WITH A ERASE REQUEST
CHKERASE CLI EXBXEXIT,C'B' YES, CALLING BEFORE EXIT??
BNE RTN NO, DON'T DO ANYTHING ELSE
CLC EXBRTYPE,=CL6'ERASE' IS THIS AN ERASE REQUEST??
BNE RTN NO, DON'T DO ANYTHING ELSE
SPACE
* BEFORE EXIT - ERASE REQUEST
* GET POLICY RECORD AND ERASE ALL COVERAGE RECORDS WITHIN
* POLICY-COVG SET.
SPACE
BEFORERA EQU *
CLC POLTYP,=CL4'1040' IS RECORD TYPE 1040??
BNE REC1041 NO, CHECK FOR TYPE 1041
LA R6,4 R6 ─► 4 COVERAGE RECORDS TO GET
B BINDPOL GO BIND POLICY RECORD
REC1041 CLC POLTYP,=CL4'1041' IS RECORD TYPE 1041??
BNE RTN NO, DON'T DO ANYTHING ELSE
LA R6,3 R6 ─► 3 COVERAGE RECORDS TO GET
SPACE
*** BIND POLICY RECORD
BINDPOL EQU 0
@BIND REC=POLREC,IOAREA=(R4) BIND COVERAGE RECORD TO R4
CLC SSCSTAT,=CL4'0000' STATUS ZERO
BNE RTNERR NO, RETURN ERROR
SPACE
*** OBTAIN POLICY RECORD
OBTPOLCY @FIND CALC,REC=POLREC OBTAIN CALC POLICY RECORD
*
CLC SSCSTAT,=CL4'0000' STATUS ZERO??
BNE RTNERR NO, RETURN ERROR
*** BIND COVERAGE RECORD
@BIND REC=COVGREC,IOAREA=(R4) BIND COVERAGE RECORD TO R4
CLC SSCSTAT,=CL4'0000' STATUS ZERO
BNE RTNERR NO, RETURN ERROR
SPACE
*** OBTAIN COVERAGE RECORDS
OBTCOVG @OBTAIN NEXT,SET=SETNAME,REC=COVGREC
* OBTAIN ALL COVERAGE RECORDS FOR
* THIS POLICY
CLC SSCSTAT,=CL4'0000' STATUS ZERO??
BNE RTNERR NO, RETURN ERROR
SPACE
*** ERASE COVERAGE RECORD
@ERASE ALL,REC=COVGREC ERASE COVERAGE RECORD FOR
* THIS POLICY
CLC SSCSTAT,=CL4'0000' STATUS ZERO??
BNE RTNERR NO, RETURN ERROR
BCT R6,OBTCOVG WALK THE SET, OBTAIN THE NEXT
SPACE
B RTN RETURN
EJECT
* CHECK TO SEE IF THIS IS AN AFTER EXIT WITH A GET REQUEST
CHKAFTER CLI EXBXEXIT,C'A' YES, CALLING AFTER EXIT??
BNE RTN NO, DON'T DO ANYTHING ELSE
CLC EXBRTYPE,=CL6'GET' IS THIS A GET REQUEST??
BNE CHKPUT NO, CHECK FOR PUT REQUEST
CLC SSCSTAT,=CL4'0000' STATUS OF LAST CALL = ZERO??
BNE RTN NO, RETURN
SPACE
* AFTER EXIT - GET REQUEST
* GET MEMBERS IN IDMS SET AND BUILD VSAM RECORD IN BUFFER
* WE HAVE THE OWNER RECORD. OBTAIN ALL MEMBERS WITHIN
* POLICY-COVG SET, AND BUILD VSAM TYPE RECORD FOR PROGRAM.
AFTERGET EQU *
CLC POLTYP,=CL4'1040' IS RECORD TYPE 1040??
BNE TYP1041 NO, CHECK FOR TYPE 1041
LA R6,4 R6 ─► 4 COVERAGE RECORDS TO GET
B SETUP GO OBTAIN THE RECORDS
TYP1041 CLC POLTYP,=CL4'1041' IS RECORD TYPE 1041??
BNE NOTREC NO, DON'T DO ANYTHING ELSE
LA R6,3 R6 ─► 3 COVERAGE RECORDS TO GET
SPACE
SETUP MVC OCCURS,=CL40' ' CLEAR OUT AREA TO STORE COVERAGE
LA R5,27(0,R8) R5 ─► START OF COVERAGE RECORDS
* IN POLICY RECORD
*** BIND COVERAGE RECORD
@BIND REC=COVGREC,IOAREA=(R4) BIND COVERAGE RECORD TO R4
CLC SSCSTAT,=CL4'0000' STATUS ZERO
BNE RTNERR NO, RETURN ERROR
SPACE
*** OBTAIN COVERAGE RECORD
GETREC @OBTAIN NEXT,SET=SETNAME OBTAIN NEXT COVERAGE RECORD
* WITHIN POLICY-COVG SET
CLC SSCSTAT,=CL4'0000' STATUS ZERO??
BNE RTNERR NO, RETURN ERROR
MVC 0(10,R5),COVERAGE MOVE COVERAGE REC INTO POLICY REC
LA R5,10(0,R5) R5 ─► LOC OF NEXT COVERAGE RECORD
BCT R6,GETREC WALK THE SET, OBTAIN THE NEXT
* MOVE ZERO TO CONTROL FIELD
PACK MVC CNTLFLD,=PL2'00' MOVE ZERO TO OCCURS FIELD
MVI EXBSETLN,C'X' HAVE PRPL SET NEW RECORD LENGTH
B RTN RETURN
EJECT
* CHECK TO SEE IF THIS A PUT REQUEST AND CALLING AFTER EXIT
CHKPUT CLI EXBXEXIT,C'A' CALLING AFTER EXIT??
BNE RTN NO, DON'T DO ANYTHING ELSE
CLC EXBRTYPE,=CL6'PUT' IS THIS A PUT REQUEST??
BNE RTN NO, DON'T DO ANYTHING ELSE
CLC SSCSTAT,=CL4'0000' STATUS OF LAST CALL = ZERO??
BNE RTN NO
SPACE
* AFTER EXIT - PUT REQUEST
* STORE COVERAGE (MEMBER) RECORDS WITHIN POLICY-COVG SET
* WE HAVE THE OWNER RECORD. STORE ALL MEMBERS WITHIN POLICY-COVG
* SET.
AFTERPUT EQU *
CLC POLTYP,=CL4'1040' IS RECORD TYPE 1040??
BNE TYPE1041 NO, RECORD CHECK FOR TYPE 1041
LA R6,4 R6 ─► 4 COVERAGE RECORDS TO STORE
B SETUPS GO STORE THE RECORDS
TYPE1041 CLC POLTYP,=CL4'1041' IS RECORD TYPE 1041??
BNE RTN NO, DON'T DO ANYTHING ELSE
LA R6,3 R6 ─► 3 COVERAGE RECORDS TO STORE
SPACE
SETUPS LA R5,27(0,R8) R5 ─► START OF COVERAGE RECORDS
* IN POLICY RECORD
*** BIND COVERAGE RECORD
@BIND REC=COVGREC,IOAREA=(R4) BIND COVERAGE RECORD TO R4
CLC SSCSTAT,=CL4'0000' STATUS ZERO
BNE RTNERR NO, RETURN ERROR
SPACE
*** STORE COVERAGE RECORD
PUTREC MVC DATA,0(R5) MOVE POLICY/COVG INFO TO COVG REC
@STORE REC=COVGREC STORE COVERAGE RECORD
SPACE
CLC SSCSTAT,=CL4'0000' STATUS ZERO
BNE RTNERR NO, RETURN ERROR
LA R5,10(0,R5) R5 ─► LOC OF NEXT COVERAGE RECORD
BCT R6,PUTREC STORE THE NEXT RECORD
B RTN RETURN
EJECT
NOTREC MVC OCCURS,=CL40' ' CLEAR OUT AREA TO STORE COVERAGE
SPACE
RTNERR EQU *
MVI EXBSETFB,C'X' TELL ESVS EXIT SET FEEDBACK CODE
MVC EXBFDBK,SSCSTAT MOVE SSCSTAT TO EXBFDBK
RTN EQU *
#FREESTG ADDR=(R4) FREE ACQIURED STORAGE
LR R13,R7 RESTORE R13
LM R14,R12,12(R13) RESTORE CALLER'S REGISTERS
SR R15,R15 ZERO RETURN CODE
BR R14 RETURN TO CALLER
SPACE
STGERROR EQU *
DC H'0' ABEND WITH 0C1
BR R14 RETURN TO CALLER
SPACE
EJECT
STARS DC CL8'********' END OF EXECUTABLE CODE
DMLSEQ DC F'0' NEEDED AT DML EXPANSION TIME
SETNAME DC CL16'POLICY-COVG' SET-NAME
COVGREC DC CL16'COVERAGE' RECORD-NAME
POLREC DC CL16'POLICY' RECORD-NAME
LTORG
RECORD DSECT POLICY RECORD LAYOUT
DS 0F
POLICY DS 0CL27
POLKEY DS 0CL15
POLKEYDA DS CL11
POLTYP DS CL4
POLDAT DS CL10
CNTLFLD DS CL2
OCCURS DS 0CL40
COVG1 DS CL10
COVG2 DS CL10
COVG3 DS CL10
COVG4 DS CL10
SPACE
COVERAGE DSECT COVERAGE RECORD LAYOUT
DATA DS CL10
EJECT
COPY #EVEXBDS
EJECT
COPY #SSCDS
EJECT
PRINT OFF
PRINT NOGEN
COPY #CSADS
PRINT GEN
END ESVSXITA
|
Copyright © 2014 CA.
All rights reserved.
|
|