zOs/REXX.O13/PROC
/* rexx ***************************************************************
**********************************************************************/
call prTest
exit
err: parse arg ggMsg; call errA ggMsg; exit 12;
/* copy pr begin ****************************************************/
prTest: procedure
m.trace = 0
call prIni
do i=1 to 5
call prPut 'v'i, 'v'i'-from-1'
end
call prInvoke prNew(), 'call prTest1 2'
return
endProcedure prTest
prTest1: procedure expose m.
parse arg n
say n 'begin' prTestVV()
do i=n to 5
call prPut 'v'i, 'v'i'-from-'n
end
say n 'put ' prTestVV()
if n <= 5 then
call prInvoke prNew(), 'call prTest1' (n+1)
say n 'end ' prTestVV()
return
endProcedure prTest1
prTestVV: procedure expose m.
parse arg n
r = ''
do i=1 to 5
r = r 'v'i'='prGet('v'i)
end
return strip(r)
endProcedure prTestVV
prIni: procedure expose m.
parse arg force
if m.pr.ini == 1 & force ^== 1 then
return
call memIni force
m.pr.proc = -1
p0 = prNew()
call outBegin p0, '*'
m.pr.out.p0 = p0
m.pr.proc = p0
m.pr.proc0 = p0
m.pr.hist.0 = 1
m.pr.hist.1 = p0
m.pr.ini = 1
return
endProcedure prIni
/*----------------------------------------------------------------------
return a new child process of the active process
----------------------------------------------------------------------*/
prNew: procedure expose m.
this = memNew()
m.pr.parent.this = m.pr.proc
m.pr.out.this = ''
m.pr.out.0 = 0
m.pr.out.max = 999999
return this
endProcedure prNew
/*----------------------------------------------------------------------
push process p to the history stack and make it the active process
----------------------------------------------------------------------*/
prPush: procedure expose m.
parse arg p
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPush: hist top proc mismatch'
top = m.pr.hist.0 + 1
m.pr.hist.0 = top
m.pr.hist.top = p
m.pr.proc = p
return top
endProcedure prPush
/*----------------------------------------------------------------------
pop the active process from history stack
activate the previous process
if arg tx not empty, ensure it equals the old active process
----------------------------------------------------------------------*/
prPop: procedure expose m.
parse arg tx
top = m.pr.hist.0
if m.pr.hist.top ^== m.pr.proc then
call err 'prPop: hist top proc mismatch'
if tx ^== '' then
if top ^== tx then
call err 'prPop: hist top is' top '<> expected' tx
if top <= 1 then
call err 'prPop: empty history'
top = top - 1
m.pr.hist.0 = top
m.pr.proc = m.pr.hist.top
return
endProcedure prPop
/*----------------------------------------------------------------------
push process ggPR, interpret rexx ggRexx and pop the process
----------------------------------------------------------------------*/
prInvoke: procedure expose m.
parse arg ggPr, ggRexx
ggOldProcTopHistVariable = prPush(ggPr)
interpret ggRexx
call prPop ggOldProcTopHistVariable
return
endProcedure prInvoke
prOut: procedure expose m.
parse arg line
this = m.pr.proc
x = m.pr.out.this.0 + 1
m.pr.out.this.0 = x
m.pr.out.this.x = line
if x > m.pr.out.this.max then do
memWriteBlock m.pr.out.this, pr'.'out'.'this
m.pr.out.this.0 = 0
end
return
endProcedure prOut
/*----------------------------------------------------------------------
get the value of a $-variable, fail if undefined
----------------------------------------------------------------------*/
prGet: procedure expose m.
parse arg name, s
p = m.pr.proc
do while p >= 0
if symbol('m.pr.p.name') = 'VAR' then
return m.pr.p.name
p = m.pr.parent.p
end
if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure prGet
/*----------------------------------------------------------------------
put (store) the value of a $-variable
----------------------------------------------------------------------*/
prPut: procedure expose m.
parse arg name, value
p = m.pr.proc
m.pr.p.name = value
call trc 'assign('p')' name '= <'value'>'
return
endProcedure prPut
prWriteBegin: procedure expose m.
parse arg m, pTyp pOpt
m.pr.write.m.type = pTyp
m.pr.write.m.max = 0
m.pr.write.m.bNo = 0
m.pr.write.m.0 = 0
inf = ''
if pTyp == 'b' then do
m.pr.write.m.max = 999999999
end
else if pTyp == 'd' then do
m.pr.write.m.dd = pOpt
m.pr.write.m.max = 100
inf = 'dd' pOpt
end
else if pTyp == 'f' then do
m.pr.write.m.type = 'd'
m.pr.write.m.dsn = pOpt
if verify(m, '0123456789') = 0 then
m.pr.write.m.dd = 'wri'm
else
m.pr.write.m.dd = m
m.pr.write.m.max = 100
inf = 'dd' m.pr.write.m.dd 'dsn' pOpt
call adrTso 'alloc dd('m.pr.write.m.dd') shr dsn('pOpt')'
end
else if pTyp == 's' then do
m.pr.write.m.0 = 1
m.pr.write.m.1 = ''
end
else if ^ (pTyp == '*' ) then
call err 'outBegin bad type' pTyp
m.pr.write.m.info = pTyp'-'m.pr.write.m.type inf
return
endProcedure outBegin
prWriteLine: procedure expose m.
parse arg m, data
r = m.pr.write.m.0 + 1
m.pr.write.m.0 = r
m.pr.write.m.r = strip(data, 't')
if m.pr.write.m.max <= r then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
return
endProcedure outLine
prWriteBlock: procedure expose m.
parse arg m, data
if m.pr.write.m.0 ^== 0 then do
call outBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if data ^== '' then do
call outBlockOne m, data
return
endProcedure prWriteBlock
prWriteBlockOne: procedure expose m.
parse arg m, data
m.pr.write.m.bNo = m.pr.write.m.bNo + m.data.0
if m.pr.write.m.type == 'd' then do
call writeNext m.pr.write.m.dd, 'M.'data'.'
end
else if m.pr.write.m.type = 'i' then do
interpret m.pr.write.m.rexx
end
else if m.pr.write.m.type == 'b' then do
if data == 'PR.WRITE.'m then
call err 'recursive block write' m
q = m.pr.write.m.0
do r = 1 to m.data.0
q = q + 1
m.pr.write.m.q = m.data.r
end
m.pr.write.m.0 = q
end
else if m.pr.write.m.type == '*' then do
do r = 1 to m.data.0
say 'prWrite:' m.data.r
end
end
else
call err 'blockOne bad m.pr.write.'m'.type' m.pr.write.m.type
return
endProcedure outBlock
prWriteEnd: procedure expose m.
parse arg m
if m.pr.write.m.0 ^== 0 & m.pr.write.m.type ^== 'b' then do
call writeBlockOne m, 'PR.WRITE.'m
m.pr.write.m.0 = 0
end
if m.pr.write.m.type == 'd' then do
call writeDDEnd m.pr.write.m.dd
if left(m.pr.write.m.info, 1) == 'f' then
call adrTso 'free dd('m.in.m.dd')'
end
else if m.pr.write.m.type == 'i' then do
if m.pr.write.rexxClose ^== '' then
interpret m.pr.write.rexxClose
end
return
endProcedure prWriteEnd
outInfo: procedure expose m.
parse arg m
if m.pr.write.m.type = 'b' then
m.pr.write.m.bNo = m.pr.write.m.0
return m.pr.write.m.bNo 'records written to',
m 'type' m.pr.write.m.info
/* copy pr end ****************************************************/
/* copy mem begin ****************************************************/
/**********************************************************************
***********************************************************************/
memIni: procedure expose m.
parse arg force
if m.mem.ini == 1 & force ^== 1 then
return
m.mem.0 = 0
m.mem.ini = 1
return
endProcedure memIni
memNew: procedure expose m.
m.mem.0 = m.mem.0 + 1
return m.mem.0
endProcedure memNew
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 m
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 ****************************************************/