The SARSAMRX Program Source
Article ID: 6561
Updated On:
Products
Issue/Introduction
Provided herein is the source code for program SARSAMRX.
Environment
Resolution
The source code for program SARSAMRX:
TITLE 'SARSAMRX - PERFORMS SAR DATABASE I/0 FOR REXX PROGRAMS'
PUNCH ' MODE AMODE(31),RMODE(ANY)'
***********************************************************************
** **
** **
** * * ***** ******* *** ***** ***** **
** ** * * * * * * * **
** * * * * * * * * * **
** * * * * * * * * *** **
** * * * * * * * * * **
** * ** * * * * * * **
** * * ***** * *** ***** ***** **
** **
** **
**-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**
** **
** THESE USER CONTRIBUTED EXITS ARE DISTRIBUTED AS A COURTESY **
** ONLY. **
** **
** THEY MAY OR MAY NOT HAVE BEEN TESTED BY COMPUTER ASSOCIATES **
** INTERNATIONAL, INC.; THEY ARE NOT CERTIFIED THAT THEY WILL **
** FUNCTION IN ANY FASHION WHATSOEVER, AND THEY ARE NOT SUPPORTED **
** BY COMPUTER ASSOCIATES INTERNATIONAL, INC. **
** **
** THERE IS NO WARRANTY, EXPRESS OR IMPLIED, AS TO THEIR **
** USABILITY IN YOUR ENVIRONMENT. **
** **
** USE AT YOUR OWN DISCRETION AND RISK. **
** **
***********************************************************************
SARSAMRX CSECT ,
SARSAMRX AMODE 31
SARSAMRX RMODE ANY
***********************************************************************
* *
* SARSAMRX - *
* PERFORMS SAR DATABASE I/O FOR REXX PROGRAMS. *
* *
* INPUTS - *
* R0 - ADDRESS OF THE ENVIRONMENT BLOCK (IRXENVB) *
* R1 - ADDRESS OF THE EXTERNAL FUNCTION PARM LIST (IRXEFPL) *
* *
* RETURN CODES - *
* ALWAYS ZERO *
* *
* ATTRIBUTES - *
* RENT, REUS *
* *
* SAMPLE REXX CALL - *
* CALL SARSAMRX 'OPEN', 'SARP.SYSTEM1', 'FREE' *
* CALL SARSAMRX 'CLOSE' *
* CALL SARSAMRX 'GET', KEY, 'EQ' *
* CALL SARSAMRX 'INVL' *
* CALL SARSAMRX 'MSG' *
* CALL SARSAMRX 'SOPN', GCR *
* CALL SARSAMRX 'SGET' *
* CALL SARSAMRX 'SCLS' *
* CALL SARSAMRX 'AOPN', GCR *
* CALL SARSAMRX 'AGET' *
* CALL SARSAMRX 'ACLS' *
* *
* VALUES RETURNED IN THE REXX RESULT VARIABLE - *
* 01-02 RETURN CODE FROM SARSAM (IN DECIMAL 00-99) *
* 03-32762 RECORD RETURNED FROM SARSAM *
* *
* WARNING! IF YOU ARE RUNNING SARSAM 6.1 OR LATER, VERIFY *
* THE LINK ATTRIBUTES. *
* *
* FOR BEST PERFORMANCE, USE THE NORENT,NOREUS (THE CORRECT *
* ATTRIBUTES). ANY OTHER ATTRIBUTES CAUSE THE ROUTINE TO RUN *
* SLOWLY. *
* *
* SOME VERSIONS OF SARSAM WERE INCORRECTLY LINKED *
* AS RENT,REUS. *
* *
***********************************************************************
BEGIN SAVE (14,12),,'SARSAMRX &SYSDATE &SYSTIME'
LR R12,R15 LOAD BASE REGISTER
USING SARSAMRX,R12 ADDRESSABILITY FOR PROGRAM
*---------------------------------------------------------------------*
* ACQUIRE STORAGE AND CHAIN SAVE AREAS *
*---------------------------------------------------------------------*
GETMAIN R,LV=AREALEN GET DYNAMIC STORAGE
LR R2,R1 SAVE TARGET ADDRESS
LR R0,R1 SET TARGET ADDRESS
L R1,=A(AREALEN) SET TARGET LENGTH
SLR R14,R14 SET SOURCE ADDRESS
LR R15,R14 SET SOURCE LENGTH AND PAD
MVCL R0,R14 ZERO OUT WORK AREA
ST R2,8(R13) COMPLETE CHAINS
ST R13,4(R2) COMPLETE CHAINS
LM R0,R1,20(R13) RELOAD R0 - R1
LR R13,R2 ESTABLISH SAVEAREA
USING AREA,R13
STM R0,R1,ADDRENVB
*---------------------------------------------------------------------*
* USE QUERY FUNCTION TO DETERMINE IF ENTRY ALREADY THERE *
*---------------------------------------------------------------------*
MVC SCMSTR,SCMHCET INIT HOST CMD TABLE ENTRY
LA R1,SCMSTR ADDR OF AREA FOR HCE ENTRY
ST R1,SCMSTRA SAVE ADDR
LA R1,L'SCMSTR TABLE ENTRY LENGTH
ST R1,SCMSTRL INIT HCE LENGTH PARAMETER
L R0,ADDRENVB
LA R1,PARMLIST
L R15,ADDRENVB GET ADDRESS OF ENVIRONMENT BLOCK
L R15,ENVBLOCK_IRXEXTE-ENVBLOCK(,R15) ADDR OF EXT VECTOR
L R15,IRXSUBCM-IRXEXTE(,R15) ADDRESS OF IRXSUBCM ROUTINE
CALL (15),(SCMQRYF,SCMSTRA,SCMSTRL,SCMENV),VL,MF=(E,(R1))
LTR R15,R15 DOES ENVIRONMENT EXIST?
BNZ LOADSAM NO
MVC ADDRSAM,SCMTOK SAVE ADDRESS OF SARSAM ROUTINE
B GETPARMS YES - GET PARMS
*
LOADSAM LOAD EP=SARSAM NO --
ST R0,ADDRSAM SAVE THE ADDRESS
MVI RFRHSAM,C'Y' INDICATE FRESH COPY
*
*---------------------------------------------------------------------*
* USE ADD FUNCTION TO CREATE A NEW TABLE ENTRY *
*---------------------------------------------------------------------*
MVC SCMSTR,SCMHCET INIT HOST CMD TABLE ENTRY
ST R0,SCMTOK INITIALIZE ENVIRONMENT TOKEN
LA R1,SCMSTR ADDR OF AREA FOR HCE ENTRY
ST R1,SCMSTRA SAVE ADDR
LA R1,L'SCMSTR TABLE ENTRY LENGTH
ST R1,SCMSTRL INIT HCE LENGTH PARAMETER
L R0,ADDRENVB
LA R1,PARMLIST
L R15,ADDRENVB GET ADDRESS OF ENVIRONMENT BLOCK
L R15,ENVBLOCK_IRXEXTE-ENVBLOCK(,R15) ADDR OF EXT VECTOR
L R15,IRXSUBCM-IRXEXTE(,R15) ADDRESS OF IRXSUBCM ROUTINE
CALL (15),(SCMADDF,SCMSTRA,SCMSTRL,SCMENV),VL,MF=(E,(R1))
LTR R15,R15
BZ LOADSAM1
DC X'00DEAD'
DC AL1(L'ERMSG1)
ERMSG1 DC C'UNABLE TO ADD SARSAMRX ENVIRONMENT'
LOADSAM1 LOAD EP=SARSAMRX LOCK SARSAMRX IN MEMORY
*
*---------------------------------------------------------------------*
* EXTRACT REXX PARMS *
*---------------------------------------------------------------------*
GETPARMS LM R0,R1,ADDRENVB RELOAD R0/ R1
USING EFPL,R1
L R2,EFPLARG ADDRESS OF PARMS
DROP R1
USING ARGTABLE_ENTRY,R2
LA R0,PARMS INITIALIZE PARMS
LA R1,PARMLEN
SLR R14,R14
LR R15,R14
ICM R15,B'1000',SPACES
MVCL R0,R14
*
CLC HIVALUES(L'ARGTABLE_END),ARGTABLE_ENTRY
BE CKRTN
LA R0,PARM1 GET PARM 1
LA R1,L'PARM1
L R14,ARGTABLE_ARGSTRING_PTR
L R15,ARGTABLE_ARGSTRING_LENGTH
ICM R15,B'1000',SPACES
MVCL R0,R14
OC PARM1,SPACES CONVERT TO UC
LA R2,ARGTABLE_NEXT NEXT ARGTABLE ENTRY
*
CLC HIVALUES(L'ARGTABLE_END),ARGTABLE_ENTRY
BE CKRTN
LA R0,PARM2 GET PARM 2
LA R1,L'PARM2
L R14,ARGTABLE_ARGSTRING_PTR
L R15,ARGTABLE_ARGSTRING_LENGTH
ICM R15,B'1000',SPACES
MVCL R0,R14
LA R2,ARGTABLE_NEXT NEXT ARGTABLE ENTRY
*
CLC HIVALUES(L'ARGTABLE_END),ARGTABLE_ENTRY
BE CKRTN
LA R0,PARM3 GET PARM 3
LA R1,L'PARM3
L R14,ARGTABLE_ARGSTRING_PTR
L R15,ARGTABLE_ARGSTRING_LENGTH
ICM R15,B'1000',SPACES
MVCL R0,R14
OC PARM3,SPACES CONVERT PARM3 TO UC
DROP R2
*---------------------------------------------------------------------*
* SARSAM FUNCTION SELECTION ROUTINE *
*---------------------------------------------------------------------*
CKRTN CLC PARM1,=CL8'GET'
BE GET
CLC PARM1,=CL8'SGET'
BE SGET
CLC PARM1,=CL8'SOPN'
BE SOPN
CLC PARM1,=CL8'SCLS'
BE SCLS
CLC PARM1,=CL8'AGET'
BE AGET
CLC PARM1,=CL8'AOPN'
BE AOPN
CLC PARM1,=CL8'ACLS'
BE ACLS
CLC PARM1,=CL8'INVL'
BE INVL
CLC PARM1,=CL8'OPEN'
BE OPEN
CLC PARM1,=CL8'CLOSE'
BE CLOSE
CLC PARM1,=CL8'MSG'
BE MSG
CLC PARM1,=CL8'SAMGET'
BE GET
CLC PARM1,=CL8'SAMSGET'
BE SGET
CLC PARM1,=CL8'SAMSOPN'
BE SOPN
CLC PARM1,=CL8'SAMSCLS'
BE SCLS
CLC PARM1,=CL8'SAMINVL'
BE INVL
CLC PARM1,=CL8'SAMOPEN'
BE OPEN
CLC PARM1,=CL8'SAMCLOSE'
BE CLOSE
CLC PARM1,=CL8'SAMMSG'
BE MSG
B ERR1 INVALID FUNCTION CALL
*---------------------------------------------------------------------*
* SAMOPEN ROUTINE *
*---------------------------------------------------------------------*
OPEN CLI RFRHSAM,C'Y' IS THIS A FRESH COPY?
BE OPEN1 YES
DELETE EP=SARSAM REFRESH SARSAM ON EVERY OPEN
LOAD EP=SARSAM
ST R0,ADDRSAM
ST R0,SCMTOK
L R0,ADDRENVB
LA R1,PARMLIST
L R15,ADDRENVB GET ADDRESS OF ENVIRONMENT BLOCK
L R15,ENVBLOCK_IRXEXTE-ENVBLOCK(,R15) ADDR OF EXT VECTOR
L R15,IRXSUBCM-IRXEXTE(,R15) ADDRESS OF IRXSUBCM ROUTINE
CALL (15),(SCMUPDF,SCMSTRA,SCMSTRL,SCMENV),VL,MF=(E,(R1))
LTR R15,R15
BZ OPEN1
DC X'00DEAD'
DC AL1(L'ERMSG2)
ERMSG2 DC C'UNABLE TO UPDATE SARSAMRX ENVIRONMENT'
OPEN1 LA R1,PARMLIST
L R15,ADDRSAM
OC PARM2(17),SPACES CONVERT NAME TO UPPER CASE
CALL (15),(=CL8'SAMOPEN',PARM2,PARM3),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) SET RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMCLOSE ROUTINE *
*---------------------------------------------------------------------*
CLOSE LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMCLOSE'),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) SET RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMGET ROUTINE *
*---------------------------------------------------------------------*
GET DS 0H
* LOAD EP=XDC
* XC PARMLIST(24),PARMLIST
* ESTAE (R0),MF=(E,PARMLIST)
* DC X'00DEAD'
* DC AL1(L'ERMSG)
* MSG DC C'START GET ROUTINE '
*
L R1,=V(SARIFK) LOAD ADDRESS OF KEY LENGTH TABLE
SLR R15,R15 ZERO FOR KEY LENGTH
IC R15,PARM2 GET FIRST CHARACTER OF KEY
IC R15,0(R1,R15) GET KEY LENGTH
BCTR R15,0
EX R15,GETMVC COPY KEY FIELD
*
LA R1,PARMLIST
L R15,ADDRSAM
CALL (15), X
(=CL8'SAMGET',RETRCD,RCDLEN,PARM3,RETLEN),VL,MF=(E,(R1))
STH R15,RETRC SET RESULT RETURN CODE
LA R2,2 SET DEFAULT RECORD LENGTH
LTR R15,R15 NON-ZERO RETURN CODE?
BNZ GETX YES - IGNORE RECORD LENGTH
AH R2,RETLEN ADD IN RECORD LENGTH
GETX ST R2,RETLEN SET RESULT LENGTH
B EXITPGM
GETMVC MVC RETRCD(*-*),PARM2 COPY KEY FIELD
*---------------------------------------------------------------------*
* SAMINVL ROUTINE *
*---------------------------------------------------------------------*
INVL LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMINVL'),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) SET RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMMSG ROUTINE *
*---------------------------------------------------------------------*
MSG LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMMSG',RETRCD,RCDLEN),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC+133) RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMSOPN ROUTINE *
*---------------------------------------------------------------------*
SOPN LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMSOPN',PARM2),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) SET RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMSGET ROUTINE *
*---------------------------------------------------------------------*
SGET LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMSGET',RETRCD,RCDLEN,RETLEN),VL,MF=(E,(R1))
STH R15,RETRC SET RESULT RETURN CODE
L R2,=A(L'RETRC) SET RESULT LENGTH
AH R2,RETLEN
ST R2,RETLEN
B EXITPGM
*---------------------------------------------------------------------*
* SAMSCLS ROUTINE *
*---------------------------------------------------------------------*
SCLS LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMSCLS'),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMAOPN ROUTINE *
*---------------------------------------------------------------------*
AOPN LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMAOPN',PARM2),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) SET RESULT LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* SAMAGET ROUTINE *
*---------------------------------------------------------------------*
AGET LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMAGET',RETRCD,RCDLEN,RETLEN),VL,MF=(E,(R1))
STH R15,RETRC SET RESULT RETURN CODE
L R2,=A(L'RETRC) SET RESULT LENGTH
AH R2,RETLEN
ST R2,RETLEN
B EXITPGM
*---------------------------------------------------------------------*
* SAMACLS ROUTINE *
*---------------------------------------------------------------------*
ACLS LA R1,PARMLIST
L R15,ADDRSAM
CALL (15),(=CL8'SAMACLS'),VL,MF=(E,(R1))
MVC RETLEN,=A(L'RETRC) LENGTH
STH R15,RETRC SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* ERROR ROUTINE *
*---------------------------------------------------------------------*
ERR1 MVC RETLEN,=A(L'RETRC) LENGTH
MVC RETRC,=H'99' SET RESULT RETURN CODE
B EXITPGM
*---------------------------------------------------------------------*
* EXIT ROUTINE *
*---------------------------------------------------------------------*
EXITPGM EQU *
L R1,ADDREFPL
USING EFPL,R1
L R2,EFPLEVAL
L R3,0(R2)
DROP R1
USING EVALBLOCK,R3
L R4,EVALBLOCK_EVSIZE
SLL R4,3
S R4,=A(EVALBLOCK_EVDATA-EVALBLOCK)
C R4,RETLEN
BNL EXITPGM1
* ALLOCATE A NEW EVAL BLOCK
MVC RLTPARMS,RLTMODEL INITIALIZE DYNAMIC STORAGE
L R15,ADDRENVB GET ADDRESS OF ENVIRONMENT BLOCK
L R15,ENVBLOCK_IRXEXTE-ENVBLOCK(R15) ADDRESS OF EXT VECTOR
L R15,IRXRLT-IRXEXTE(R15) ADDRESS OF IRXRLT ROUTINE
MVC RLTNLEN,RETLEN
LA R1,PARMLIST
CALL (15),(RLTFUNC,RLTADDR,RLTNLEN),VL,MF=(E,(R1))
L R3,RLTADDR
ST R3,0(R2) SET ADDRESS OF NEW EVAL BLOCK
EXITPGM1 LH R15,RETRC CONVERT RC TO DECIMAL
CVD R15,DWORD
UNPK RETRC,DWORD
OI RETRC+1,X'F0'
LA R0,EVALBLOCK_EVDATA
L R1,RETLEN
ST R1,EVALBLOCK_EVLEN
LA R14,RETRC
LR R15,R1
MVCL R0,R14 FILL IN EVAL BLOCK
LR R1,R13 FREE DYNAMIC STORAGE
L R13,4(,R13) RESTORE LAST SAVE AREA ADDRESS
DROP R13
FREEMAIN R,LV=AREALEN,A=(R1)
SLR R15,R15
RETURN (14,12),RC=(15) RETURN TO CALLER
*---------------------------------------------------------------------*
* PROGRAM STORAGE (CONSTANTS) *
*---------------------------------------------------------------------*
SPACES DC 133C' '
LOVALUES DC 20X'00'
HIVALUES DC 20X'FF'
RCDLEN DC AL2(L'RETRCD)
*
RLTMODEL DS 0CL16
DC CL8'GETBLOCK'
DC F'0'
DC F'0'
*
SCMQRYF DC CL8'QUERY'
SCMADDF DC CL8'ADD'
SCMUPDF DC CL8'UPDATE'
SCMHCET DC CL8'SARSAMRX',CL8'SARSAMXX',XL16'00'
SCMHCEL EQU *-SCMHCET
LTORG
*---------------------------------------------------------------------*
* DYNAMIC STORAGE *
*---------------------------------------------------------------------*
AREA DSECT
SAVEAREA DS 9D
ADDRENVB DS A
ADDREFPL DS A
ADDRSAM DS A
PARMLIST DS 6F
DWORD DS D
RFRHSAM DS CL1
*
PARMS DS 0CL(PARMLEN) INPUT PARAMETERS
PARM1 DS CL8 ROUTINE NAME
PARM2 DS CL300 OPTION_1
PARM3 DS CL6 OPTION_2
PARMLEN EQU *-PARM1
*
DS 0F
RLTPARMS DS 0CL16 GET RESULT PARAMETER LIST
RLTFUNC DC CL8'GETBLOCK'
RLTADDR DC F'0'
RLTNLEN DC F'0'
*
DS 0F
SCMPARMS DS 0CL16 IRXSUBCM PARAMETER LIST
SCMFUNC DS CL8 FUNCTION
SCMSTRA DS F STRING ADDRESS
SCMSTRL DS F STRING LENGTH
SCMSTR DS 0CL(SCMHCEL) HOST COMMAND ENV STRING
SCMENV DS CL8 ENVIRONMENT NAME
SCMRTN DS CL8 PROCESSING ROUTINE NAME
SCMTOK DS XL16 USER TOKEN
*
RETLEN DS F
RETRC DS H
RETRCD DS CL32760
AREALEN EQU *-AREA
*
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
R12 EQU 12
R13 EQU 13
R14 EQU 14
R15 EQU 15
IRXARGTB
IRXENVB
IRXEXTE
IRXEVALB
IRXEFPL
END BEGIN
Feedback
