zOs/REXX.O13/PVSRWGRD
/* rexx ***************************************************************
pvsrWgrD: Leistungsverrechnung Detailnachweis WGR
synopsis: pvsrWgrD -OPTION ...
This Rexx writes Leistungsverrechnung Detailnachweis WGR for one month
from the PVS-Job Table vpv013a1a
to 2 output file
The sql select statement to execute is read in from a file
and the variables ($XX odr ${XX}) are substitued by their value
Then the SQL is executed and all rows fetched and written
to the output file CSV
The fetched rows must consist of single string.
Files
The following files must be preallocated:
SQLIN: the sql to execute (after variable substitution)
JESIN: the log file from jesOutput (internal output)
CSV: the output csv file, containing the data for the month
HTMLIN: the input html file, (skeleton for variable expansion)
HTML: the output html file with a link to the csv file
MAILIN: the input mail file, (skeleton for variable expansion)
MAIL: the output mail file with a link to the html file
Options
Each Option has the form
-<char><value> (without intervening spaces)
the following Options are supported (case insensitive) and
stored in the variable name indicated after the option
-D DBSYS Db2Subsystem, must be DBTF (RZ1) or DBOF (RZ2)
-M MONTH format yyyymm, month to evaluate
-O DBOWNER Db2 Owner, must be OA1T (RZ1) or OA1P (RZ2)
-T trace
-? this help
Variable substitution in sqlIn, htmlIn and mailIn see copy rs
Variable Names
DBOWNER, DBSYS, MONTH as specified in options
HTML the DSN allocated to DD HTML (by listDsi)
MAIL the DSN allocated to DD MAIL (by listDsi)
MONTHDISP the MONTH in display format mm.yyyy
RZ the current sysNode
Foreground or Test Modus
if no options are specified and rexx runs in foreground
or option -F is specified then
for the unspecified options reasonable defaults are selected
the DD SQLIN, JESIN, CSV, HTML* and MAIL* are alloc'd and free'd
additional options in Testmode
-F FILEPRE Foreground mode.
FilePrefix default CESA.DETAIL.$RZ.$MONTH
gives the outputfiles $FILEPRE.CSV and $FILEPRE.HTML
-S SQLIN PDS for SQLIN,HTMLIN, MAILIN
Membername will be suffixed by S, H, M respectively
default 'WGR.RZ1.P0.AKT.PARMLIB(PVM7700)'
History
27.07.2005 W. Keller KPCO4 jesLog implemented
12.05.2005 W. Keller KPCO4 created
**********************************************************************/
/*---------------------------------------------------------------------
main: analyse arguments and do the work
---------------------------------------------------------------------*/
parse arg args
m.trace = 0
if 0 then
do; call rsTest ; call rsTestFC; exit; end;
call analyseArgs translate(args), '-D=DBSYS -MnMONTH -O=DBOWNER' ,
'-F*FILEPRE -S=SQLIN'
if rsGet(filePre) = '*' & ^(args = '' & sysvar('SYSENV') = 'FORE') then
call work 'd sqlIn', 'd jesIn', 'd htmlIn', 'd mailIn'
else
call foregroundWork
exit 0
/*---------------------------------------------------------------------
work:
(1) massage and check variables
(2) sql select and write detailnachweis to DD CSV
(3) write HTML page and MAIL message
---------------------------------------------------------------------*/
work: procedure expose m.
parse arg sqlIn, jesIn, htmlIn, mailIn
call checkNotEmpty 'DBSYS DBOWNER MONTH'
say 'db='rsGet(dbSys) 'own='rsGet(dbOwner) 'month='rsGet(month)
/* put fileNames */
lRc = listDsi('HTML FILE')
if lRc <> 0 then
call err 'rc' lRc 'listDsi(HTML FILE)'
call rsPut HTML, sysDsName
lRc = listDsi('CSV FILE')
if lRc <> 0 then
call err 'rc' lRc 'listDsi(CSV FILE)'
call rsPut CSV, sysDsName
call rsPut rz, sysvar('SYSNODE')
call rsPut monthDisp, right(rsGet(month), 2)'.'left(rsGet(month),4)
/* tailor sql and execute it */
call rs m, sqlIn, 's'
call sqlDetail m.out.m.1
/* analyse jesIn */
call jesLog jesIn
/* sort the data from wgrTree */
m.wgrSeq.0 = 0
call treeSeq wgrTree, wgrSeq
/* write data to dd csv */
call outBegin o, 'd CSV'
da = date('s')
call outLine o, 'Detailnachweis WGR;;'rsGet(rz)';',
|| 'erstellt;'time('n')';',
|| right(da, 2)'.'substr(da,5,2)'.'left(da,4)';'
call outLine o, 'Monat;Instradierung; PVS Seiten; PVS Dokumente;' ,
'JES Seiten; JES Stapel;'
do xx=1 to m.wgrSeq.0
yy = m.wgrSeq.xx
call outLine o, m.wgrMon.yy';'m.wgrInst.yy';' ,
|| m.wgrPvsPag.yy';'m.wgrPvsDoc.yy';' ,
|| m.wgrJesPag.yy';'m.wgrJesStap.yy';'
call trc 'xx' xx 'yy' yy 'mon' m.wgrMon.yy 'instr' m.wgrInst.yy,
'pvsPages' m.wgrPvsPag.yy 'pvsDoc' m.wgrPvsDoc.yy,
'jesPages' m.wgrJesPag.yy 'jesStap' m.wgrJesStap.yy
end
/* finish and cleanup */
call outEnd o
say outInfo(o)
call rs m, htmlIn, 'd HTML'
call rs m, mailIn, 'd MAIL'
return
endProcedure work;
/*---------------------------------------------------------------------
(1) set default arguments for foreground tests
(2) allocate datasets
(3) call work
(4) free datasets
---------------------------------------------------------------------*/
foregroundWork: procedure expose m.
rz = sysvar('SYSNODE')
if rsGet(dbsys) <> '' then nop
else if rz= 'RZ1' then call rsPut dbsys, 'DBTF'
else if rz= 'RZ2' then call rsPut dbsys, 'DBOF'
if rsGet(dbOwner) <> '' then nop
else if rz= 'RZ1' then call rsPut dbOwner, 'OA1T'
else if rz= 'RZ2' then call tsPut dbOwner, 'OA1P'
if rsGet(month) = '' then do
mon = left(date('s'), 6)
if substr(mon, 5) > 1 then
call rsPut month, mon - 1
else
call rsPut month, mon - 89
end
filePre = rsGet(filePre)
if filePre = '' | filePre = '*' then
filePre = "CESA."rz".D"rsGet(month)
sqlIn = rsGet(sqlIn)
if sqlIn = '' then
sqlIn = "wk.sql(PVM7700)"
msk = 'f' dsnApp(dsnSetMbr(sqlIn, dsnGetMbr(sqlIn)'?'))
allocNewV = 'new catalog dataclas(VB0256S0) mgmtclas(D035Y000)'
allocNewF = 'new catalog dataclas(FB0080S0) mgmtclas(D035Y000)'
if sysDsn(filePre".csv") = 'OK' then
call adrTso 'alloc dd(csv) old dsn('filePre'.csv)'
else
call adrTso 'alloc dd(csv) dsn('filePre'.csv)' allocNewV
if sysDsn(filePre".html") = 'OK' then
call adrTso 'alloc dd(html) old dsn('filePre'.html)'
else
call adrTso 'alloc dd(html) dsn('filePre'.html)' allocNewV
if sysDsn(filePre".mail") = 'OK' then
call adrTso 'alloc dd(mail) old dsn('filePre'.mail)'
else
call adrTso 'alloc dd(mail) dsn('filePre'.mail)' allocNewF
call work translate(msk, 'S', '?'),
, 'f' dsnApp(filePre '.jesLog'),
, translate(msk, 'H', '?'),
, translate(msk, 'M', '?')
call adrTso 'free dd(csv html mail)'
return
endProcedure foregroundWork
/*---------------------------------------------------------------------
(1) execute sql query
(2) fetch result into stem m.wgr*
---------------------------------------------------------------------*/
sqlDetail: procedure expose m.
parse arg sql
/* read sql source */
call trc 'sqlDetail sql' sql
/* execute sql query */
call adrSqlConnect rsGet(dbSys)
call adrSql "prepare s1 from :sql"
call adrSql "declare c1 cursor for s1"
call adrSql "open c1"
do ox = 1 by 1 /* fetch rows loop */
if adrSqlRc("fetch c1 into" ,
':m.wgrMon.ox,',
':m.wgrInst.ox,',
':m.wgrPvsPag.ox,',
':m.wgrPvsDoc.ox') <> 0 then do
if sqlCode = 100 then
leave
else
call err sqlMsg()
end
call trc 'sql fetch mon' m.wgrMon.ox 'instr' m.wgrInst.ox,
'pages' m.wgrPvsPag.ox 'sendungen' m.wgrPvsDoc.ox
call treeAdd wgrTree, m.wgrInst.ox, ox
m.wgrJesPag.ox = 0
m.wgrJesStap.ox = 0
end
m.wgr.0 = ox-1
if m.trace == 1 then do
call trc 'wgrTree in sqlDetail ********* begin'
m.wgrSeq.0 = 0
call treeSeq wgrTree, wgrSeq
do xx=1 to m.wgrSeq.0
yy = m.wgrSeq.xx
call trc 'xx' xx 'yy' yy ,
'mon' m.wgrMon.yy 'instr' m.wgrInst.yy,
'pvsPag' m.wgrPvsPag.yy 'pvsDoc' m.wgrPvsDoc.yy,
'jesPag' m.wgrJesPag.yy 'jesSta' m.wgrJesStap.yy
end
call trc 'wgrTree in sqlDetail ********* end'
end
call adrSql "close c1" /* cleanup */
call adrSqlDisconnect rsGet(dbSys)
say 'fetched' m.wgr.0 'rows'
return
endProcedure sqlDetail
/*---------------------------------------------------------------------
read jeslog from dd dd
analyse each log entry for current month and add it to m.wgr*
---------------------------------------------------------------------*/
jesLog: procedure expose m.
parse arg jesIn
mon = rsGet(month)
ox = m.wgr.0
say 'jesLog month' mon 'jesIn' jesIn
call inBegin j, jesIn
call scanBegin j, j, 'n'
cLi = 0
cMo = 0
/* analyse each log line */
do while scanNextLine(j)
cLi = cLi + 1
if ^ scanNum(j) then
call scanErrBack j,'jesLog does not start with numeric date'
dat = m.j.tok
if left(dat, 6) ^== mon then
iterate
if ^scanChar(j, 0) | ^scanUntil(j, ' ') then
call scanErrBack j, 'jesLog does have time'
WGR2CSLST = ''
if ^scanKeyValue(j) | m.j.key ^== 'WGR2CSLST' then
iterate
vers = m.j.val
if vers ^== '01' & vers ^== '??' then
call scanErrBack j, 'unsupported version wgr2csLst='vers
cMo = cMo + 1
inst = ''
pag = 0
cop = 1
/* extract values from keys */
do while scanKeyValue(j)
if m.j.key == 'VERRECHNUNG' then
inst = m.j.val
else if m.j.key == 'PAGES' then
pag = m.j.val
else if m.j.key == 'COPIES' then
cop = m.j.val
end
/* compute pages and stapel */
paCo = pag * cop
stap = (paCo + 799) % 800
call trc 'inst' inst 'pag' pag 'cop' cop '==>' paCo stap
if paCo = 0 then
nop /* ignore empty file */
else if symbol('m.wgrTree.inst.v') == 'VAR' then do
/* update existing tree node */
qq = m.wgrTree.inst.v
if m.wgrMon.qq ^== mon then
call err 'month mismatch tree='m.wgrMon.qq 'cur='mon
if m.wgrInst.qq ^== inst then
call err 'inst mismatch'
m.wgrJesPag.qq = m.wgrJesPag.qq + paCo
m.wgrJesStap.qq = m.wgrJesStap.qq + stap
end
else do
/* insert new tree node */
ox = ox + 1
call treeAdd wgrTree, inst, ox
m.wgrMon.ox = mon
m.wgrInst.ox = inst
m.wgrPvsPag.ox = 0
m.wgrPvsDoc.ox = 0
m.wgrJesPag.ox = paCo
m.wgrJesStap.ox = stap
end
end /* analyse each log line */
say 'jesLog selected' cMo 'from' cLi 'lines, added to',
ox 'nodes (' || (ox-m.wgr.0) 'new ones)'
m.wgr.0 = ox
call scanEnd j
call inEnd j
return
endProcedure jesLog
/*---------------------------------------------------------------------
in the tree m.m add or update a node (m.m.key.v = val)
and update the children path (character by character sorted)
---------------------------------------------------------------------*/
treeAdd: procedure expose m.
parse arg m, key, val
m.m.key.v = val
do while key ^== ''
ch = right(key, 1)
key = left(key, length(key) - 1)
if symbol('m.m.key.c') ^== 'VAR' then
m.m.key.c = ''
if pos(ch, m.m.key.c) > 0 then
return
do x=1 to length(m.m.key.c) while ch >> substr(m.m.key.c, x, 1)
end
m.m.key.c = left(m.m.key.c, x-1) || ch || substr(m.m.key.c, x)
end
return
end treeAdd
/*---------------------------------------------------------------------
add he subtree t at key key ordered
to the stem o
---------------------------------------------------------------------*/
treeSeq: procedure expose m.
parse arg t, o, key
if symbol('m.t.key.v') == 'VAR' then do
x = m.o.0 + 1
m.o.0 = x
m.o.x = m.t.key.v
end
if symbol('m.t.key.c') == 'VAR' then do
do x=1 to length(m.t.key.c)
call treeSeq t, o, key || substr(m.t.key.c, x, 1)
end
end
return
endProcedure treeSeq
/*----------------------------------------------------------------------
(1) fill the $ variables with default values
(2) fill the arguments specified in args in the $ variables
the valid arguments and variables are specified in infos,
each word in infos describes one argument as follows:
* substr(1,2) must match substr(1,2) of the word in args
* substr(3,1) type:
'=' initial value ''
'*' initial value '*'
'n' initial value '', value must be a number
* substr(4) variable name
----------------------------------------------------------------------*/
analyseArgs: procedure expose m.
parse arg args, infos
do i=1 to words(infos)
w = word(infos, i)
nam = substr(w, 4)
if substr(w, 3, 1) = '*' then
call rsPut nam, '*'
else
call rsPut nam, ''
end
do i=1 to words(args)
w = word(args, i)
if w = '?' | w = '-?' then do
call help
exit
end
else if w = '-T' then do
m.trace = 1
end
else do
cx = pos(left(w, 2), infos)
if cx < 1 then
call errHelp 'bad Option' op 'in' subWord(args, i)
ty = substr(infos, cx+2, 1)
nam = word(substr(infos, cx+3), 1)
val = substr(w, 3)
if ty = 'n' then
if verify(val, '0123456789') > 0 THEN
call err nam ' not numeric:' w
call rsPut nam, val
end
end
return
endProcedure analyseArgs
/*----------------------------------------------------------------------
for each word w in names assert $w <> ''
issue an error if any the variables is empty
----------------------------------------------------------------------*/
checkNotEmpty: procedure expose m.
parse arg names
do i=1 to words(names)
n = word(names, i)
if rsGet(n) = '' then
call err 'variable' n 'is empty'
end
return
endProcede checkNotEmpty
err:
parse arg ggMsg
call errA ggMsg
exit 12
/* copy rs begin ****************************************************/
/**********************************************************************
RS = Rexx Shell: produce output from input (rexx and Data)
Synopsis rs m, iTyp iOpt, oTyp oOpt
rsFC m, iTyp iOpt, oTyp oOpt
m: the this address (m.m. ...)
iTyp iOpt: input option for scanBegin (see there)
oTyp oOpt: output option 's'=say 'd'= dd oOpt
each input line has one of five types:
'*' comment is ignored
';' Rexx line (a trailing comma works as continuation marker)
'|' a RexxOuput line
'>' an output line
The two functions support two different concrete Syntaxes:
rsFC: first nonblank character marks line type *;|>
rs: stateSwitch lines allow nested blocks of
Rexx and RexxOutput lines
${; and $}; surround Rexx lines
${> and $}> surround RexxOutput lines
$> preceedes a single RexxOutput line
$* preceedes a comment line
the rest are output lines
each rexx and rexxOutput line is compiled (into rexx)
if an output line is encountered (or at EOF),
the previously compiled rexx is interpreted
then, the output line is written after variable substitution
the following substitutions are supported
$name, ${name} ${quotedString}
no space between $ and name or $ and { is allowed
spaces are allowed after the { and before the }
the names are case sensitive
these substituions are expanded in Rexx, RexxOutput and Output lines
and may be assigned in rexxLines
within a called rexx function rsGet and rsPut access these variables
warning: in rexxLines neither use semicolons
nor use $ not even in strings, except for ${'$'} etc.,
the results are unpredictable |
example: write a table of the squares and cubes from 1 to 10:
syntax for rsFC:
* title line
| n n**2 n**3 | titel squares and cubes
; do i=1 to 10
* fill one line into a $- variable
; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)
* output the line
| | $txt |
; end
| n n**2 n**3 | trailer squares and cubes
syntax for rs:
$* title line
| n n**2 n**3 | titel squares and cubes
${; --- start of rexx lines
do i=1 to 10
$* fill one line into $variable
$txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)
$* comment
$>| $txt |
$* comment
; end '
$}; --- end of rexx lines
| n n**2 n**3 | trailer squares and cubes
**********************************************************************/
rsTest: procedure
m.trace = 0
m.s.1 = 'first line m.s.1'
m.s.2 = ' ${; erster rexx block'
m.s.3 = ' $eins = "einsValue1"'
m.s.4 = ' if $eins = ${eins} then'
m.s.5 = ' say wie geht es ,'
m.s.6 = ' dir auch so ?'
m.s.7 = ' $}; ende erster rexx block'
m.s.8 = ' aha soso $eins und ${ ''$'' }eins = ${ eins } '
m.s.9 = ' ${; zweiter rexx block'
m.s.10= ' $x = a'
m.s.11= ' do i=1 to 3'
m.s.12= ' $x = , '
m.s.13= ' $x || "-"i"-" , '
m.s.14= ' || ${ x } '
m.s.15= ' ${> embedded output block begin'
m.s.16= ' jetzt ist x $x'
m.s.17= ' $}> embedded output block end '
m.s.18= ' end'
m.s.19= ' '
m.s.20= ' ${ q } = quote($x)'
m.s.21= ' $}; zweiter rexx block'
m.s.22 = 'und jetzt ${"$x="} $x q=${ q } '
m.s.0 = 22
call rs c, 'b' s, '*'
say 'end rsTest eins'
m.t.1 = '$* title line '
m.t.2 = '| n n**2 n**3 | titel squares and cubes '
m.t.3 = ' ${;'
m.t.4 = ' do i=1 to 10 '
m.t.5 = '$* fill one line into $variable '
m.t.6 = ' $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)'
m.t.7 = '$* comment '
m.t.8 = ' $>| $txt |'
m.t.9 = ' $* comment '
m.t.10= '; end '
m.t.11= '$};'
m.t.12= '| n n**2 n**3 | trailer squares and cubes '
m.t.0 = 12
call rs c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTest
rsTestFC: procedure
m.trace = 0
call rsPut 'eins', 'valueEins'
m.s.1 = '; $eins = "einsValue1"'
m.s.2 = '; if $eins = ${eins} then'
m.s.3 = '; say wie geht es '
m.s.4 = '> aha soso $eins und ${ ''$'' }eins = ${ eins } '
m.s.5 = '; $x = a'
m.s.6 = '; do i=1 to 3'
m.s.7 = '; $x = , '
m.s.8 = '; $x || "-"i"-" , '
m.s.9 = '; || ${ x } '
m.s.10= ' | jetzt ist x $x'
m.s.11= '; end'
m.s.12= ' '
m.s.13= '; ${ q } = quote($x)'
m.s.14 = ' |und jetzt ${"$x="} $x q=${ q } '
m.s.0 = 14
call rsFC c, 'b' s, '*'
say 'end rsTest eins'
m.t.1 = '* title line '
m.t.2 = '| | n n**2 n**3 | titel squares and cubes '
m.t.3 = '; do i=1 to 10 '
m.t.4 = '* fill one line into $variable '
m.t.5 = '; $txt = right(i, 5) right(i*i, 5) right(i*i*i, 5)'
m.t.6 = '* output the variable '
m.t.7 = '| | $txt |'
m.t.8 = '; end '
m.t.9 = '| | n n**2 n**3 | trailer squares and cubes '
m.t.0 = 9
call rsFC c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTestFC
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
rsGet: procedure expose m.
parse arg name, s
if symbol('m.var.name') = 'VAR' then
return m.var.name
else if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure rsGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
rsPut: procedure expose m.
parse arg name, value
m.var.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure rsPut
/*----------------------------------------------------------------------
read input and write output with nested syntax
todo: convert to a pipe
input: inTO as specified by inBegin
output:outTO as specified by outBegin
----------------------------------------------------------------------*/
rs: procedure expose m.
parse arg m, inTO, outTO
s = m
call outBegin s, outTO
call inBegin s, inTO
call scanBegin s, s, 'n'
call rsLine m, s, 'b'
sta = '0'
states = ''
do while scanNextLine(s)
if scanChar(s, 1) & m.s.tok == '$' then do
swi = scanRight(s, 2)
if swi == '{;' | swi == '{>' then do
states = sta || states
sta = right(swi, 1)
iterate
end
if swi == '};' | swi == '}>' then do
if sta ^== right(swi, 1) then
call scanErrBack s, 'blockClose $'swi ,
'but in ${'sta 'block, history' sta||states
sta = left(states, 1)
states = substr(states, 2)
iterate
end
if left(swi, 1) == '>' then do
call scanChar s, 1
call rsLine m, s, translate(sta, '>||', '0;>')
iterate
end
if left(swi, 1) == '*' then
iterate
end
call scanRestartLine m
call rsLine m, s, translate(sta, '>;|', '0;>')
end
if states ^== '' then
call scanErr s, 'input ends in block, history' sta||states
call inEnd s
call outEnd s
say outInfo(s)
return
endProcedure rs
/*----------------------------------------------------------------------
read input and write output with FC syntax, arguments see rs
----------------------------------------------------------------------*/
rsFC: procedure expose m.
parse arg m, inTO, outTO
s = m
call outBegin s, outTO
call inBegin s, inTO
call scanBegin s, s, 'n'
call rsLine m, s, 'b'
do while scanNextLine(s)
if ^scanChar(s, 1) | m.s.tok == '*' then
nop /* empty or comment line */
else if pos(m.s.tok, ';|>') > 0 then
call rsLine m, s, m.s.tok
else
call scanErrBack s, 'bad line, should start with one of ;|>'
end
call rsLine m, s, 'e'
call inEnd s
call outEnd s
say outInfo(s)
return
endProcedure rsFC
/*----------------------------------------------------------------------
compile/interpret/execute one line
arguments: m = this
s = scanner
typ = ';', '|', '>' for lineType or b(egin), e(nd)
----------------------------------------------------------------------*/
rsLine: procedure expose m.
parse arg m, s, typ
if typ == ';' then do
m.rs.m.rx = m.rs.m.rx ,
strip(rsRexxCompile(m, s, m.rs.m.rx == ''), t)
if right(m.rs.m.rx, 1) == ',' then do
typ = ','
m.rs.m.rx = ,
strip(left(m.rs.m.rx, length(m.rs.m.rx) - 1), 't')
end
else do
yy = m.rs.m.rx.0 + 1
m.rs.m.rx.0 = yy
m.rs.m.rx.yy = strip(m.rs.m.rx, 't')
m.rs.m.rx = ''
end
m.rs.m.state = typ
end
else if typ == 'b' then do
m.rs.m.rx.0 = 0
m.rs.m.state = ';'
m.rs.m.rx = ''
end
else if m.rs.m.state ^== ';' then
call scanErr s, 'continuation expected'
else if typ == '|' then do
yy = m.rs.m.rx.0 + 1
m.rs.m.rx.0 = yy
m.rs.m.rx.yy = rsOutCompile(m, s)
end
else if typ == '>' then do
if m.rs.m.rx.0 > 0 then do
call rsRexxRun rs'.'m'.'rx
m.rs.m.rx.0 = 0
end
call rsOutInter m, s
end
else if typ == 'e' then do
if m.rs.m.rx.0 > 0 then do
call rsRexxRun rs'.'m'.'rx
m.rs.m.rx.0 = 0
end
end
else
call scanErr s, 'rsLine bad typ' typ
return
endProcedure rsLine
/*----------------------------------------------------------------------
compile one rexxLine ( ; line):
scan until endOfLine, substitue $ clauses
and return resulting rexxClause
lineBegin=0 says, we are on a continuation line
----------------------------------------------------------------------*/
rsRexxCompile: procedure expose m.
parse arg m, rs, lineBegin
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx || m.rs.before || quote(m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else if lineBegin & rx = '' & m.rs.before = '' then do
rx = rx || m.rs.before || 'call rsPut' quote(m.rs.name) ','
if ^ scanChar(rs, 1) | m.rs.tok ^== '=' then
call scanErr rs, 'assignment operator = expected'
end
else
rx = rx || m.rs.before || 'rsGet('quote(m.rs.name)')'
end
call trc 'rsRexxComp:' rx || m.rs.before
return rx || m.rs.before
endProcedure rsRexxCompile
/*----------------------------------------------------------------------
compile one rexxOutputLine ( | line):
scan until endOfLine, substitue $ variables
and return resulting rexx prefixed by 'call rsOut'
----------------------------------------------------------------------*/
rsOutCompile: procedure expose m.
parse arg m, rs
rx = ''
do while rsScanDollar(rs)
if m.rs.type == 's' then
rx = rx '||' quote(m.rs.before || m.rs.val)
else if m.rs.type ^== 'n' then
call err 'rsOutInter bad m.rs.type' m.rs.type
else
rx = rx '||' quote(m.rs.before) ,
'|| rsGet('quote(m.rs.name)')'
end
if rx == '' then
rx = 'call outLine' quote(rs) ',' quote(m.rs.before)
else
rx = 'call outLine' quote(rs) ',' ,
substr(rx, 5) '||' quote(m.rs.before)
call trc 'rsOutCompile:' rx
return rx
endProcedure rsOutCompile
/*----------------------------------------------------------------------
interpret a compiled rexx
----------------------------------------------------------------------*/
rsRexxRun: procedure expose m.
parse arg ggM
ggSrc = ''
do x=1 to m.ggM.0
ggSrc = ggSrc m.ggM.x ';'
end
call trc 'rsRexxRun interpreting' ggSrc
interpret ggSrc
call trc 'interpreted'
return
endProcedure rsRexxComp
rsOutInter: procedure expose m.
/*----------------------------------------------------------------------
interpret one outputLine ( > line):
scan until endOfLine, substitue $ variables by its current vale
and output resulting string
----------------------------------------------------------------------*/
parse arg m, rs
msg = ''
do while rsScanDollar(rs)
if m.rs.type == 'n' then
msg = msg || m.rs.before || rsGet(m.rs.name)
else if m.rs.type == 's' then
msg = msg || m.rs.before || m.rs.val
else
call err 'rsOutInter bad m.rs.type' m.rs.type
end
call outLine rs, msg || m.rs.before
return
endProcedure rsOutInter
/*----------------------------------------------------------------------
scan a Dollar-clause
scan until next $, put text before into m.rs.before
analyse $-clause set the variables m.rs.type as follows
'n' name of variable is in m.rs.name
's' value of string is in m.rs.val
position scanner at first character after clause
return 1 if clause scanned, 0 if no $ found (until endOfLine)
faile if invalid or incomplete clause
----------------------------------------------------------------------*/
rsScanDollar: procedure expose m.
parse arg rs
call scanUntil rs, '$'
m.rs.before = m.rs.tok
if ^ scanChar(rs, 1) then
return 0
if m.rs.tok ^== '$' then
call scanErr rs 'internal: should be $'
c1 = scanRight(rs, 1)
if c1 = ' ' then
call scanErrBack rs, 'illegal $ clause'
else if c1 == '{' then do
call scanChar rs, 1
if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else if scanString(rs, '''') then
m.rs.type = 's'
else if scanString(rs, '"') then
m.rs.type = 's'
else
call scanErr rs, 'bad ${...} clause'
if ^scanChar(rs, 1) | m.rs.tok ^== '}' then
call scanErr rs, 'ending } missing'
end
else if scanName(rs) then do
m.rs.name = m.rs.tok
m.rs.type = 'n'
end
else
call scanErr rs, 'bad $ clause'
return 1
endProcedure rsScanDollar
/* copy rs end ****************************************************/
/* copy scan begin ****************************************************/
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034,Und hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = {*('ers' || 'tn' || '''s')"
m.q.4 = " drei;+H{>a'}123{>sdf'R}aha} '' end "
m.q.0 = 4
call scanTestDo q, 0
call scanTestDo q, 1
return
endProcedure scanTest
scanTestDo: procedure expose m.
parse arg q, scCo
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
m.s.scanComment = scCo
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTestDo
scanBegin: procedure expose m.
parse arg m, s, pOpt, sc1, sc2
m.m.skipComment = pos('c', pOpt) > 0
m.m.skipNext = pos('n', pOpt) < 1
m.m.scanReader = s
m.m.cx = 999
m.m.curLi = m'.'cx
m.m.eof = 0
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
return
endProcedure scanEnd
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanSkip: procedure expose m.
parse arg m, nxt, cmm
m.m.tok = ''
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then do
m.m.bx = vx
m.m.cx = vx
if ^ cmm then
return 1
else if ^ scanComment(m) then
return 1
m.m.tok = ''
end
else if ^ nxt then
return 0
else if ^ scanNextLine(m) then do
m.m.eof = 1
return 0
end
end
endProcedure scanSkip
scanNextLine: procedure expose m.
parse arg m
s = m.m.scanReader
if inLine(s) then do
m.m.curLi = m.in.s.line
m.m.cx = 1
return 1
end
else do
m.m.eof = 1
return 0
end
endProcedure scanNextLine
scanRestartLine: procedure expose m.
parse arg m, p
if p == '' then
m.m.cx = 1
else
m.m.cx = p
m.m.bx = m.m.cx
return
endProcedure sanRestartLine
scanChar: procedure expose m.
parse arg m, len
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if length(m.l) >= m.m.bx + len then
m.m.tok = substr(m.l, m.m.bx, len)
else
m.m.tok = substr(m.l, m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
m.m.val = ''
if qu = '' then
qu = "'"
l = m.m.curLi
if substr(m.l, m.m.cx, 1) ^== qu then
return 0
qx = m.m.cx + 1
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
if ^ scanSkip(m, m.m.skipNext, m.m.skipComment) then
return 0
l = m.m.curLi
if alpha == '' then do
if pos(substr(m.l, m.m.bx, 1), '012345678') > 0 then
return 0
vx = verify(m.l,
, '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ' ,
, 'n', m.m.bx)
end
else do
vx = verify(m.l, alpha, 'n', m.m.bx)
end
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else if vx <= m.m.bx then
return 0
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
if ^ scanName(m, '0123456789') then
return 0
else if datatype(scanRight(m, 1), 'A') then
call scanErrBack m, 'illegal number end'
return 1
endProcedure scanNum
scanKeyValue: procedure expose m.
parse arg m
if ^scanName(m) then
return 0
m.m.key = translate(m.m.tok)
if ^scanChar(m, 1) | m.m.tok <> '=' then
call scanErr m, 'assignment operator (=) expected'
if scanName(m) then
m.m.val = translate(m.m.tok)
else if scanNum(m) then do
m.m.val = m.m.tok
end
else if scanString(m) then
nop
else
call scanErr m, "value (name or string '...') expected"
return 1
endProcedure scanKeyValue
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx':' substr(m.l, m.m.cx)
say inLineInfo(m.m.scanReader)
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* copy scan end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
inAll: procedure expose m.
parse arg m, inTO, out
call inBegin m, inTO
if out == '' then do
call inBlock m, '*'
if inBlock(m) | m ^== m.in.m.block then
call err 'not eof after inBlock *'
end
else do
rx = 0
do while inBlock(m)
bl = m.in.m.block
do ix=1 to m.bl.0
rx = rx + 1
m.out.rx = m.bl.ix
end
end
m.out.0 = rx
end
call inEnd m
return
endSubroutine inAll
inBegin: procedure expose m.
parse arg m, pTyp pOpt
m.in.m.type = pTyp
m.in.m.rNo = 0
m.in.m.bNo = 0
m.in.m.0 = 0
m.in.m.eof = 0
m.in.m.block = in'.'m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = in'.'m'.'string
m.in.m.type = 'b'
end
else if pTyp == 'b' then do
m.in.m.block = pOpt
end
else if pTyp == 'd' then do
m.in.m.dd = pOpt
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.in.m.type = 'd'
m.in.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.in.m.dd = 'in'm
else
m.in.m.dd = m
inf = 'dd' m.in.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.in.m.dd') shr dsn('pOpt')'
end
else
call err 'inBegin bad type' pTyp
m.in.m.info = pTyp'-'m.in.m.type inf
return
endProcedure inBegin
inLine: procedure expose m.
parse arg m
r = m.in.m.rNo + 1
if r > m.in.m.0 then do
if ^ inBlock(m) then
return 0
r = 1
end
m.in.m.line = m.in.m.block'.'r
m.in.m.rNo = r
return 1
endProcedure inLine
inBlock: procedure expose m.
parse arg m, cnt
if m.in.m.type == 'd' then do
m.in.m.bNo = m.in.m.bNo + m.in.m.0
m.in.m.eof = ^ readNext(m.in.m.dd, 'm.in.'m'.', cnt)
return ^ m.in.m.eof
end
else if m.in.m.type == 'b' then do
if m.in.m.bNo > 0 then do
m.eof = 1
return 0
end
m.in.m.bNo = 1
b = m.in.m.block
m.in.m.0 = m.b.0
return 1
end
else
call err 'inBlock bad m.in.'m'.type' m.in.m.type
endProcedure inBlock
inLineInfo: procedure expose m.
parse arg m, lx
if lx = '' then
lx = m.in.m.rNo
cl = m.in.m.block'.'lx
xx = m.in.m.rNo
if m.in.m.type == 'd' then
xx = xx + m.in.m.bNo
return 'record' xx '(m.'cl 'type' strip(m.in.m.info)'):' m.cl
endProcedure inLineInfo
inEnd: procedure expose m.
parse arg m
if m.in.m.type == 'd' then do
call readDDEnd m.in.m.dd
if left(m.in.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
outBegin: procedure expose m.
parse arg m, pTyp pOpt
m.out.m.type = pTyp
m.out.m.max = 0
m.out.m.bNo = 0
m.out.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.out.m.max = 999999999
end
else if pTyp == 'd' then do
m.out.m.dd = pOpt
m.out.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.out.m.type = 'd'
m.out.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.out.m.dd = 'out'm
else
m.out.m.dd = m
m.out.m.max = 100
inf = 'dd' m.out.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.out.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.out.m.0 = 1
m.out.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.out.m.info = pTyp'-'m.out.m.type inf
return
endProcedure outBegin
outLine: procedure expose m.
parse arg m, data
if m.out.m.0 < m.out.m.max then do
r = m.out.m.0 + 1
m.out.m.0 = r
m.out.m.r = strip(data, 't')
end
else if m.out.m.type = '*' then do
m.out.m.bNo = m.out.m.bNo + 1
say 'out:' data
end
else if m.out.m.type = 's' then do
m.out.m.bNo = m.out.m.bNo + 1
m.out.m.1 = m.out.m.1 strip(data)
end
else do
call outBlock s
m.out.m.0 = 1
m.out.m.1 = data
end
return
endProcedure outLine
outBlock: procedure expose m.
parse arg m, pp
if pp == '' then
oo = out'.'m
else
oo = pp
if m.out.m.type = '*' then do
do r = 1 to m.oo.0
say 'out:' m.oo.r
end
end
else if m.out.m.type = 's' then do
do r = 1 to m.oo.0
m.out.m.1 = m.out.m.1 strip(m.oo.r)
end
end
else if m.out.m.type = 'b' then do
if pp ^== '' then do
q = m.out.m.0
do r = 1 to m.oo.0
q = q + 1
m.out.m.q = m.oo.r
end
m.out.m.0 = q
end
end
else if m.out.m.type == 'd' then do
m.out.m.bNo = m.out.m.bNo + m.oo.0
call writeNext m.out.m.dd, 'M.'oo'.'
if pp == '' then
m.out.m.0 = 0
end
return
return 1
endProcedure outBlock
outEnd: procedure expose m.
parse arg m
if m.out.m.type == 'd' then do
call outBlock m
call writeDDEnd m.out.m.dd
if left(m.out.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure outEnd
outInfo: procedure expose m.
parse arg m
if m.out.m.type = 'b' then
m.out.m.bNo = m.out.m.0
return m.out.m.bNo 'records written to' m 'type' m.out.m.info
endProcedure outInfo
/* copy mem end *****************************************************/
/* copy adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1), 't', "'")
endProcedure dsnGetMbr
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = "'"
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd grp
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDDBegin: procedure
return /* end readDDBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return (value(ggSt'0') > 0)
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg ggTsoCmd
address tso ggTsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg ggTsoCmd
address tso ggTsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
adrIspRc:
parse arg ggIspCmd
address ispexec ggIspCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ggIspCmd
address ispexec ggIspCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ggIspCmd
return /* end adrIsp */
adrEdit:
parse arg ggEditCmd, ret
address isrEdit ggEditCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' ggEditCmd
return /* end adrEdit */
adrEditRc:
parse arg ggEditCmd
address isrEdit ggEditCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
setRc: procedure
parse arg zIspfRc
/**********************************************************************
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible zIspfRc
back as return code
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
parse source . . s3 .
say 'help for rexx' s3
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
return 4
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/