zOs/REXX.O13/EXRS
call rsTest
exit
err:
parse arg ggMsg
call errA ggMsg
exit 12
/* copy rs begin ****************************************************/
/**********************************************************************
RS = Rexx Shell
RsRun 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 four types,
depending on the first nonspace character:
'*' or '' comment is ignored
';' Rexx line (a trailing comma works as continuation marker)
'>' an output line
'|' a RexxOuput line
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 substituions 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 all 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 put $ in strings (except for ${'$'} etc.),
the results are unpredictable |
example: write a table of the squares and cubes from 1 to 10:
* 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
**********************************************************************/
rsTest: 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 rsRun 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 rsRun c, 'b' t, '*'
say 'end rsTest cube'
return
endProcedure rsTest
/*----------------------------------------------------------------------
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
todo: convert to a pipe
input: iTyp and iOpt as specified by scanBegin
output: d ddName or '*' (for say)
----------------------------------------------------------------------*/
rsRun: procedure expose m.
parse arg m, iTyp iOpt, oTyp oDD
s = 'm'Rs
call inBegin s, iTyp, iOpt
m.m.out = oTyp
m.m.out.0 = 0
m.m.out.total = 0
m.m.out.dd = oDD
if oTyp == 'd' then
call writeDDBegin m.m.out.dd
call scanBegin s, s, 'n'
rx = 0
oldSt = ';'
rxLi = ''
do while scanNextLine(s)
if ^scanChar(s, 1) | m.s.tok == '*' then
iterate /* empty or comment line */
c1 = m.s.tok
if c1 == ';' then do
rxLi = rxLi strip(rsRexxCompile(m, s, rxLi == ''), t)
if right(rxLi, 1) == ',' then do
c1 = ','
rxLi = strip(left(rxLi, length(rxLi) - 1), 't')
end
else do
rx = rx + 1
m.m.rexx.rx = strip(rxLi, 't')
rxLi = ''
end
oldSt = c1
end
else if oldSt ^== ';' then
call scanErr s, 'continuation expected'
else if c1 == '|' then do
rx = rx + 1
m.m.rexx.rx = rsOutCompile(m, s)
end
else if c1 == '>' then do
if rx > 0 then do
m.m.rexx.0 = rx
call rsRexxRun m'.'rexx
rx = 0
end
call rsOutInter m, s
end
else
call scanErr s, 'badLine'
end
if rx > 0 then do
m.m.rexx.0 = rx
call rsRexxRun m'.'rexx
rx = 0
end
call inEnd s
if oTyp == 'd' then do
call writeNext m.m.out.dd, 'm.m.out.'
m.m.out.total = m.m.out.total + m.m.out.0
call writeDDend m.m.out.dd
end
say m.m.out.total 'lines written to' m.m.out m.m.out.dd
return
endProcedure rsRun
/*----------------------------------------------------------------------
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 rsOut' quote(m) ',' quote(m.rs.before)
else
rx = 'call rsOut' quote(m) ',' ,
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 rsOut m, msg || m.rs.before
return
endProcedure rsOutInter
/*----------------------------------------------------------------------
output one line
----------------------------------------------------------------------*/
rsOut: procedure expose m.
parse arg m, msg
if m.m.out == '*' then do
say 'rsOut:' msg
m.m.out.total = m.m.out.total + 1
end
else if m.m.out == 'd' then do
x = m.m.out.0 + 1
m.m.out.x = msg
if x >= 100 then do
call write m.m.out.dd, 'm.m.out.'
m.m.out.total = m.m.out.total + m.m.out.0
m.m.out.0 = 0
end
end
else
call err 'rsOut bad m.'m'.out' m.m.out
return
endProcedure rsOut
/*----------------------------------------------------------------------
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
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, pTyp, pOpt, out
call inBegin m, pTyp, pOpt
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 = m
inf = ''
if pTyp == 's' then do
m.in.m.string.0 = 1
m.in.m.string.1 = pOpt
m.in.m.block = 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 in
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'.'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
return 'record' (lx + m.in.m.bNo) ,
'(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
end
else if m.in.m.type == 'f' then do
call readDDEnd m.in.m.dd
call adrTso 'free dd('m.in.m.dd')'
end
return
endProcedure inEnd
/* 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 ****************************************************/