enrico-sorichetti
Superior Member
Joined: 14 Mar 2007
Posts: 10873
Location: italy
|
|
|
|
here is a code snippet that will provide the function required
I pulled from the CBT tape file 814 and as such i believe it is in the public domain
| Code: |
Extended EXECIO
Problem addressed
The I/O model for sequential dataset processing as implemented
in REXX under MVS has one significant deficiency, namely the
lack of support for undefined format records (RECFM=U). The
XEXECIO command described in this article provides such
processing.
Solution
To simplify its use, XEXECIO has the same general syntax as the
standard EXECIO command. The solution as presented in this
article assumes that an installation environment user has a router
program that interprets that first word in the specified expression
as a subcommand and passes the remainder of the expression to
the appropriate processing program (in this case the XEXECIO
program code). XEXECIO could, of course, run in its own
environment. The major difference between the XEXECIO and
EXECIO syntax is the absence of the FINIS parameter - the
implemented version of XEXECIO always closes the specified
dataset.
Invocation syntax
XEXECIO count DISKW ddname (STEM varname
* DISKR ddname (STEM varname
FIFO
LIFO
count
The maximum number of records to be processed. * indicates a
high-value (ie no limit). In write mode, the processing ends when
this number is reached, the end of the stack is reached, or a null
stem variable is referenced, whichever occurs first. In read mode,
the processing ends when this number is reached or the end of the
input file is reached, whichever occurs first.
DISKW
Write mode.
DISKR
Read mode.
ddname
The name of the DD statement that specifies the dataset to be
processed.
FIFO
The queue is processed in first-in/first-out sequence. This is the
default.
LIFO
The queue is processed in last-in/first-out sequence.
STEM
The STEM keyword specifies that stem variables are to be used.
The stack is used if this parameter is omitted.
varname
The name of the stem variable that contains (is to contain) the
records to be processed. The records are named varname.1,... .
Return code
XEXECIO returns one of the values:
0 OK.
4 OK, no records written.
8 OK, one or more records truncated (one or more records to
be written were longer than the blocksize specified for the
dataset - the records are truncated to the maximum permitted
blocksize).
12 Open error.
16 ESPIE exit taken (invalid parameter).
20 Parsing error.
24 ENVBLOCK locate error.
28 Internal error (buffer overflow).
Sample invocation
/* REXX - XEXECIO sample */
ADDRESS TSO "ALLOC F(DD) DA('U.DATA') SHR REUS";
SAY "stack fifo"
ADDRESS USER "XEXECIO * READ DD (FIFO";
SAY "XEXECIO RC" RC
SAY "queued" queued();
DO i = 1 TO queued()
PARSE PULL a
SAY a
END
SAY "stack lifo"
ADDRESS USER "XEXECIO * READ DD (LIFO";
SAY "XEXECIO RC" RC
SAY "queued" queued();
DO i = 1 TO queued()
PARSE PULL a
SAY a
END
SAY "stem"
ADDRESS USER "XEXECIO * READ DD (STEM A."
SAY 1 A.1
SAY 2 A.2
SAY 3 A.3
EXIT
B.1 = "gamma"
B.2 = "delta"
B.3 = "a23456789b123456789c123456789d123456789e123456789";
ADDRESS USER "XEXECIO 3 WRITE DD (STEM B.";
push "zzzzzzzsdfsdfsfdsfsdfsdfsfsd"
ADDRESS USER "XEXECIO * WRITE DD";
SAY "RC" RC
Program code
Programs that use REXX services must be written in 31-bit
address mode. XEXECIO uses 24-bit residency mode because of
BSAM file processing. XEXECIO is written as re-entrant code.
MACRO
DCX &P
.* macro for the definition of INSTBLK entries
GBLC &CSECT
AIF ('&CSECT' NE '').A1
&CSECT SETC '&SYSECT'
.A1 ANOP
&CSECT CSECT
STMT&SYSNDX DC C&P
$INSTBLK CSECT
DC A(STMT&SYSNDX,L'STMT&SYSNDX)
MEND
TITLE 'Extended EXECIO'
* Register usage:
* R5 A(DCB)
* R6 A(SHVBLK)
* R7 A(common area)
* R8 A(External Entry Points Vector)
* R9 A(ENVBLOCK)
* R10 option table (branch address)
* R12 base register
XEXECIO CSECT
XEXECIO AMODE 31 REXX addressing mode
XEXECIO RMODE 24 I/O residency (addressing) mode
BAKR R14,0 save registers and return address
BASR R12,0 base register
USING *,R12
* R0: A(Environment Block)
* R1: A(Host Command Environment Routine parameter list)
LR R9,R0 A(ENVBLOCK)
LM R2,R5,4(R1)
* initialization
STORAGE OBTAIN,LENGTH=$XEXECIO_L,SP=1
LR R7,R1
USING $XEXECIO,R7
LA R13,SA set program save area
ST R5,ACMDRC A(command ReturnCode)
LA R5,DCBIN set default DCB (input)
USING IHADCB,R5
USING ENVBLOCK,R9
* set ESPIE (Addressing+Data)
ESPIE SET,EXCP0CX,(5,7)
B CONTINUE
EXCP0CX DS 0H
BALR R15,0
USING *,R15
MVC RC,=H'16' RC: ESPIE-exit taken
B EXIT
DROP R15
CONTINUE DS 0H
* initialize work area
MVI FLAG,0 processing flag
MVC LELEME(8),=2F'-1'
MVI VNINDEXX,C' '
ZAP INDEX,=P'0'
LA R1,ARGLIST
ST R1,AARGLIST
LA R1,EVALBLK
ST R1,AEVALBLK
MVC EVSIZE,=A((EVDATAE-EVALBLK)/8)
MVC EVLEN,=XL4'80000000'
MVC MAXRC,=H'-1'
OI FLAG,#NOREC preset no-records-processed flag
LA R1,IOA
ST R1,AREC
LA R1,INSTBLK
ST R1,AINSTBLK A(INSTBLK)
MVC INSTBLK_ACRONYM,=CL8'IRXINSTB'
MVC INSTBLK_HDRLEN,=F'128' L(INSTBLK header)
L R1,=A($INSTBLK)
ST R1,INSTBLK_ADDRESS INSTBLK entries
MVC INSTBLK_USEDLEN,=A(USEDLEN)
MVC INSTBLK_MEMBER,=CL8' '
MVC INSTBLK_DDNAME,=CL8' '
MVC INSTBLK_SUBCOM,=CL8'MVS'
MVC INSTBLK_DSNLEN,=F'0'
MVC DCBIN(DCBINL),DCBIN#
MVC DCBOUT(DCBOUTL),DCBOUT#
MVC OPEN(OPENL),OPEN#
MVC CLOSE(CLOSEL),CLOSE#
L R2,0(R2) A(parm)
L R3,0(R3) L(parm)
STM R2,R3,AELEM
L R8,ENVBLOCK_IRXEXTE
USING IRXEXTE,R8
* process
MVC RC,=H'20' RC: parsing error
L R15,IRXEXEC A(IRXEXEC)
CALL (15), X
(P0,AARGLIST,FLAGS,AINSTBLK,P0,AEVALBLK,P0,P0),VL, X
MF=(E,CALL8)
SR R15,R15
IC R15,EVDATA
N R15,=F'7' clear high-order
LTR R15,R15
BNZ EXIT parsing error
* retrieve passed parameters (from stack)
L R15,IRXSTK A(IRXSTK)
CALL (15),(PULL,AELEM,LELEM,FRC),VL,MF=(E,CALL4)
* save stack entry
MVC RC,=H'28' RC: internal error (overflow)
LM R0,R1,AELEM
LA R2,BUF A(buffer)
ST R2,AELEM set pointer
LR R3,R1 L(entry)
C R3,=A(L'BUF-1)
BH EXIT overflow error
MVCL R2,R0 save stack entry
MVI 0(R2),C' ' set blank at end of buffer
* parse out variables - stack entries have form: /varname vardata
* get /DD (DD name)
LA R1,#DD
BAL R14,GETSVAR get formatted stack variable
* R2: A(DD name), R3: LC(DD name)
LTR R3,R3
BM EXIT DD missing
MVC DDNAME,=CL8' ' clear DDname
MVC DDNAME(0),0(R2) set DDname
EX R3,*-6
* get /NREC
LA R1,#NREC
BAL R14,GETSVAR get formatted stack variable
LTR R3,R3
BM EXIT NREC missing
ZAP NREC,=P'999999999' set high-value (default)
CLI 0(R2),C'*'
BE *+14
PACK NREC,0(0,R2)
EX R3,*-6
* get /VARNAME
LA R1,#VARNAME
BAL R14,GETSVAR
LTR R3,R3
BM NOVARNAM VARNAME missing
MVC VARNAME,BLANK BLANK(VARNAME)
MVC VARNAME(0),0(R2)
EX R3,*-6
NOVARNAM LA R1,1(R3) L(VARNAME)
ST R1,VARNAMEL
LA R1,#IOOP
BAL R14,GETSVAR get formatted stack variable
* R2: A(vardata), R3: LC(vardata)
LTR R3,R3
BM EXIT IOOP missing
MVC RC,=H'12' RC: open error
CLC =C'READ',0(R2)
BNE A010 not READ
MVC DCBDDNAM,DDNAME
OPEN ((5),(INPUT)),MF=(E,OPEN)
LTR R15,R15
BNZ EXIT open error
LH R0,DCBBLKSI
ST R0,RECLEN
B A2000 READ processing
A010 DS 0H WRITE processing
LA R5,DCBOUT
MVC DCBDDNAM,DDNAME
OPEN ((5),(OUTPUT)),MF=(E,OPEN)
LTR R15,R15
BNZ EXIT open error
LH R0,DCBBLKSI
ST R0,RECLEN
B A1000 WRITE processing
EOP MVC RC,=H'0' end of processing
TM FLAG,#NOREC test flag
BZ EXIT records processed
MVC RC,=H'4' else warning
EXIT TM DCBOFLGS,DCBOFOPN test whether OPEN performed
BZ NOOPEN :no OPEN
CLOSE ((5)),MF=(E,CLOSE)
NOOPEN LH R15,RC
LH R0,MAXRC
LTR R0,R0
BM *+6
LR R15,R0
L R1,ACMDRC
ST R15,0(R1) set command return code
* release allocated main-storage
STORAGE RELEASE,LENGTH=$XEXECIO_L,ADDR=(7),SP=1
SR R15,R15 zeroize program return code
PR , program return
TITLE 'Write processing'
A1000 DS 0H write record (processing)
MVC RC,=H'0' reset RC
AP INDEX,=P'1'
CP INDEX,NREC
BH EOP last record written
ICM R3,B'1111',VARNAMEL test whether no VARNAME (=stack)
BZ A1100 :stack processing
* get next variable
MVC VNINDEX,=X'4020202020202120'
LA R1,VNINDEX+7
EDMK VNINDEX,INDEX
MVC VNINDEX,0(R1) set into <VNINDEX>
* get record content
MVC VN,VARNAME
LA R1,VN(R3) R3: L(varname)
MVC 0(8,R1),VNINDEX
L R3,AREC
L R4,RECLEN
BAL R14,GETVAR
* R4: L(record)
A1040 LTR R4,R4
BZ EXIT null variable (=job end)
* R3: A(variable data)
* R4: L(variable data)
USING IHADCB,R5
CH R4,DCBBLKSI
BNH *+14
MVC MAXRC,=H'8' RC: record truncated
LH R4,DCBBLKSI set maximum length
WRITE DECB2,SF,(5),(3),(4),MF=E
CHECK DECB2
NI FLAG,X'FF'-#NOREC reset flag
A1030 B A1000 return to processing loop
A1100 DS 0H get next stack variable
L R15,IRXSTK A(IRXSTK)
CALL (15),(PULL,AELEM,LELEM,FRC),VL,MF=(E,CALL4)
CH R15,=H'4'
BH EXIT
BE EOP end of stack
* else stack element retrieved, move to buffer
LM R0,R1,AELEM
LR R15,R1 length
LR R4,R1 L(variable)
L R14,AREC A(target)
LR R3,R14 A(variable)
MVCL R14,R0 move record
B A1040 process record
TITLE 'Read processing'
A2000 MVC RC,=H'0' reset RC
* get /OPTKYWD
LA R1,#OPTKYWD
BAL R14,GETSVAR
CLC =C'LIFO',0(R2)
BNE *+10
MVC STACKOP,=CL8'PUSH'
CLC =C'FIFO',0(R2)
BNE *+10
MVC STACKOP,=CL8'QUEUE'
A2100 BAL R14,READREC
AP INDEX,=P'1' increment record count
CP INDEX,NREC
BH EOP last record read
NI FLAG,X'FF'-#NOREC reset flag
ICM R1,B'1111',VARNAMEL L(VARNAME)
BZ A2200 :0, use stack
* convert INDEX to character format (.n)
MVC VNINDEX,=X'4020202020202120'
LA R1,VNINDEX+7
EDMK VNINDEX,INDEX
MVC VNINDEX,0(R1) set into <VNINDEX>
* store record <varname>i)
* <VN>: variable name
* R3: A(variable data)
* R4: L(variable data)
L R3,AREC A(record)
L R4,RECLEN L(record)
MVC VN,VARNAME variable name
L R1,VARNAMEL L(VARNAME)
LA R1,VN(R1)
MVC 0(8,R1),VNINDEX
BAL R14,SETVAR pass to REXX
B A2100 return to read-loop
A2200 DS 0H store variable in stack
L R15,IRXSTK A(IRXSTK)
CALL (15),(STACKOP,AREC,RECLEN,FRC),VL,MF=(E,CALL4)
B A2100 read loop
EOF DS 0H end of file
* output number of records processed
ICM R1,B'1111',VARNAMEL L(VARNAME)
BZ EOP :0 (stack processing)
ZAP D,INDEX
MVC VN,VARNAME VARNAME (STEM)
LA R1,VN(R1) +L(VARNAME)
MVC 0(2,R1),=C'0 ' 0-variable
OI D+7,X'0F' remove sign from count
UNPK WK,D set into display form
LA R3,WK A(record count)
LA R4,L'WK L(record count)
* set data into REXX variable
BAL R14,SETVAR
B EOP end of processing
TITLE 'Subroutines'
GETSVAR ST R14,RA_GETSVAR set return address
* Function: Get variable from formatted stack
* input:
* R1: A(comparand)
* output:
* R2: A(entry); R3: LC(entry)
* R15: 20 (comparand not found)
LA R15,BUF
GETSVAR2 CLC =C'//',0(R15)
BE GETSVAR3 last entry
CLC 0(10,R1),0(R15)
PACK D,10(5,R15) LENGTH(variable)
CVB R3,D
BE GETSVAR1 varname found
LA R15,17(R3,R15) bump buffer address
CLC =C'//',0(R15)
B GETSVAR2 get next entry
* end of buffer, entry not found
GETSVAR3 LA R15,20
B EXIT exit
GETSVAR1 DS 0H varname found, get vardata
LA R2,16(R15) A(data)
BCTR R3,0 LC(vardata)
L R14,RA_GETSVAR
BR R14 return
GETVAR ST R14,RA_GETVAR
* Function: Get REXX variable
* input:
* <VN>: variable name
* output:
* R3: A(variable)
* R4: L(variable)
BAL R14,GETVNL get L(VN)
LA R6,IRX_SHVBLOCK
USING SHVBLOCK,R6
ST R0,SHVNAML L(name), normalized
LA R1,VN A(name)
ST R1,SHVNAMA
MVI SHVCODE,SHVFETCH Fetch
ST R3,SHVVALA A(buffer)
ST R4,SHVBUFL L(buffer)
L R15,IRXEXCOM A(IRXEXCOM)
CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL,MF=(E,CALL4)
L R4,SHVVALL L(data)
L R14,RA_GETVAR load return address
TM SHVRET,SHVNEWV new variable?
BZR R14 :no, return
SR R4,R4 else zeroize length
BR R14 return
GETVNL DS 0H
* Function: Determine actual (normalized) length of name
* input: <VN> - name
* output: R0: L(name), normalised
LA R1,L'VN
SR R0,R0 counter
LA R15,VN
GETVNL1 CLI 0(R15),C' '
BER R14 end found
AH R0,=H'1' increment counter
LA R15,1(R15) bump address
BCT R1,GETVNL1
BR R14
SETVAR ST R14,RA_SETVAR
* Function: Set REXX variable
* input:
* <VN>: variable name
* R3: A(variable data)
* R4: L(variable data)
BAL R14,GETVNL get L(VN) -> R0
LA R6,IRX_SHVBLOCK
USING SHVBLOCK,R6
ST R0,SHVNAML L(name), normalized
LA R1,VN A(name)
ST R1,SHVNAMA
MVI SHVCODE,SHVSTORE set store-flag
ST R3,SHVVALA A(data)
ST R4,SHVVALL L(data)
L R15,IRXEXCOM A(IRXEXCOM)
CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL,MF=(E,CALL4)
L R14,RA_SETVAR
BR R14 return
READREC ST R14,RA_READREC
LH R4,DCBBLKSI
READ DECB1,SF,(5),IOA,(4),MF=E
CHECK DECB1
LH R4,DCBLRECL
LA R3,IOA
* R3: A(variable data)
* R4: L(variable data)
STM R3,R4,AREC A(record), L(record)
L R14,RA_READREC
BR R14
TITLE 'Constants'
#IOOP DC C'/IOOP_____' READ, WRITE
#L EQU *-#IOOP entry length
#NREC DC C'/NREC_____' * or number
#DD DC C'/DD_______' DD-name
#VARNAME DC C'/VARNAME__' varname or blank
#OPTKYWD DC C'/OPTKYWD__' STEM, FIFO or LIFO
PULL DC CL8'PULL'
BLANK DC CL16' '
P0 DC A(0)
FLAGS DC X'80000000' invoke as command
IRX_IRXEXCOM DC CL8'IRXEXCOM'
OPEN# OPEN (0),MF=L
OPENL EQU *-OPEN#
CLOSE# CLOSE (0),MF=L
CLOSEL EQU *-CLOSE#
DCBIN# DCB DDNAME=DUMMY,DSORG=PS,MACRF=R,DEVD=DA,EODAD=EOP, x
RECFM=U
DCBINL EQU *-DCBIN#
DCBOUT# DCB DDNAME=DUMMY,DSORG=PS,MACRF=W,DEVD=DA
DCBOUTL EQU *-DCBOUT#
LTORG
TITLE 'Variables and data areas'
$XEXECIO DSECT
SA DS 18F save area
ACMDRC DS A A(command return code)
DCBIN DS (DCBINL)X
DCBOUT DS (DCBOUTL)X
OPEN DS (OPENL)X
CLOSE DS (CLOSEL)X
READ DECB1,SF,0,0,'S',MF=L
WRITE DECB2,SF,0,0,'S',MF=L
CALL4 CALL ,(0,0,0,0),MF=L
CALL8 CALL ,(0,0,0,0,0,0,0,0),MF=L
REGSA DS F register save areas
RA_READREC DS A
RA_GETSVAR DS A
RA_GETVAR DS A
RA_SETVAR DS A
RC DS H
MAXRC DC H'-1'
CONDCODE DS X condition code (for branch)
INDEX DS PL4 record number counter
VNINDEX DS CL8' '
VNINDEXX DS C' '
FLAG DS X processing flag
#NOREC EQU X'01' no records processed
SRA DS A save return address
D DS 0D,PL8 double-word work area
WK DS CL6 work field
* the next two fields are contiguous
AREC DS A ) A(record)
RECLEN DS A ) L(record (block) )
NREC DS PL8 record counter
VARNAMEL DS F L(<VARNAME>)
VARNAME DS CL16 <VARNAME>
VN DS 2CL16 'stem'-variable (<VARNAME>n, n = 1, 2, ...
DDNAME DS CL8 <DDNAME>
STACKOP DS CL8 stack operation (PUSH, QUEUE)
FRC DS F function return code
BUF DS CL512 stack buffer
AARGLIST DS A(ARGLIST)
ARGLIST DS 0A Argument List (also used for stack processing)
AELEM DS 2A
ORG AELEM+4
LELEM DS F
LELEME DS 2F'-1'
AEVALBLK DS A(EVALBLK)
EVALBLK DS 0F align
DS F reserved
EVSIZE DS A((EVDATAE-EVALBLK)/8)
EVLEN DS XL4'80000000' L(data)
DS F reserved
EVDATA DS CL64 data
EVDATAE EQU *
DS 0F align
AINSTBLK DS A(INSTBLK)
INSTBLK DS 0H
INSTBLK_ACRONYM DS CL8'IRXINSTB'
INSTBLK_HDRLEN DS F'128' L(INSTBLK header)
DS F reserved
INSTBLK_ADDRESS DS A($INSTBLK) INSTBLK entries
INSTBLK_USEDLEN DS A(USEDLEN)
INSTBLK_MEMBER DS CL8' ' member name (unused)
INSTBLK_DDNAME DS CL8' ' DD name (unused)
INSTBLK_SUBCOM DS CL8'MVS' subcom
DS F reserved
INSTBLK_DSNLEN DS F L(DSN)
DS CL54' ' DSN, unused
ORG INSTBLK+128
IRX_SHVBLOCK DS (SHVBLEN)X'0'
IOA DS CL(X'8000')
$XEXECIO_L EQU *-$XEXECIO
TITLE 'DSECTs'
DCBD DEVD=DA,DSORG=PS
IRXENVB
IRXEXTE
IRXSHVB
TITLE 'INSTBLK entries'
XEXECIO CSECT
DCX '/* REXX - process parameter list */'
DCX 'PARSE ARG kywd nrec ioop dd option;'
DCX 'PARSE UPPER VAR ioop ioop;'
DCX 'PARSE UPPER VAR dd dd;'
DCX 'option = STRIP(option,"T",")");'
DCX 'SELECT;'
DCX ' WHEN ioop = "WRITE" THEN DO;'
DCX ' PARSE UPPER VAR option "(" "STEM" varname wtop .;'
DCX ' IF wtop <> "" THEN CALL ErrorExit(4);'
DCX ' END;'
DCX ' WHEN ioop = "READ" THEN DO;'
DCX ' PARSE VAR option "(" optkywd varname;'
DCX ' PARSE UPPER VAR varname varname;'
DCX ' SELECT'
DCX ' WHEN optkywd = "STEM" THEN NOP;'
DCX ' WHEN optkywd = "LIFO" THEN NOP;'
DCX ' WHEN optkywd = "FIFO" THEN NOP;'
DCX ' WHEN optkywd = "" THEN optkywd = "FIFO";'
DCX ' OTHERWISE;'
DCX ' CALL ErrorExit(2);'
DCX ' END;'
DCX ' END;'
DCX ' OTHERWISE;'
DCX ' CALL ErrorExit(3);'
DCX 'END;'
DCX '/* set stack entry */'
DCX 'PUSH "/NREC_____"RIGHT(LENGTH(nrec),5,0) nrec,'
DCX ' "/DD_______"RIGHT(LENGTH(dd),5,0) dd,'
DCX ' "/IOOP_____"RIGHT(LENGTH(ioop),5,0) ioop,'
DCX ' "/VARNAME__"RIGHT(LENGTH(varname),5,0) varname,'
DCX ' "/OPTKYWD__"RIGHT(LENGTH(optkywd),5,0) optkywd,'
DCX ' "//";/* end of list */'
DCX 'EXIT 0;'
DCX 'ErrorExit:'
DCX ' SAY "Parsing error" ARG(1)'
DCX ' EXIT ARG(1);'
$INSTBLK CSECT
USEDLEN EQU *-$INSTBLK
END
Anthony Rudd
Technical Consultant (Germany) c A S Rudd 1994
|
|
|
.jpg)
