zOs/REXX.O13/II
/* rexx ***************************************************************
**********************************************************************/
say 'ii begin'
call pipeIni
call pipePush 'abc'
l = pipeBegin()
pp = m.pi.pipe
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
call writeLn pp, 'first'
call write pp, a
call piWC l
l = pipeBar()
call wrSay l, "wrSay line", "wrSay block"
trace ?R
l = pipeEnd()
m.pi.pi = pp
call piOutLn 'first after say'
call piOut a
call wrClose pp
say 'ii end'
exit
call wrIni
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
m.pi.pi = wrNew()
l = pipeBegin()
call piOutLn 'first'
call piOut a
call piSet l
call piWC l
call wrSay m.pi.out.l, "wrSay line", "wrSay block"
call piOutLn 'first after say'
call piOut a
call wrClose l
call wrClose m.pi.out.l
say 'ii end'
exit
s = wrNew()
w = wrNew()
call writeLn w, 'first'
m.a.1 = 'a eins'
m.a.2 = 'a zwei'
m.a.0 = 2
call write w, a
/* call wrSay s, "wrSay line", "wrSay block" */
call wrFile s, "-dsnwk.text(testEins)"
call wrWC w, s
call writeLn w, 'first after say'
call write w, a
call wrClose w
call wrClose s
say 'ii end'
exit
/**********************************************************************
pi = pipe interface and simple pipes
***********************************************************************/
pipeIni: procedure expose m.
call wrIni
m.pi.pipe.0 = 0
call pipePush
return
endProcedure pipeIni
piSet: procedure expose m.
parse arg m, m.pi.out.m
if m.pi.out.m == '' then
m.pi.out.m = wrNew()
return m.pi.out.m
endProcedure piSet
piOut: procedure expose m.
parse arg stem
oldP = m.pi.pi
m.pi.pi = m.pi.out.oldP
call write m.pi.pi, stem
m.pi.pi = oldP
return
endProcedure piOut
piOutLn: procedure expose m.
parse arg line
oldP = m.pi.pi
m.pi.pi = m.pi.out.oldP
call writeLn m.pi.pi, line
m.pi.pi = oldP
return
endProcedure piOutLn
piWC: procedure expose m.
parse arg m
m.wr.wc.m.chars = 0
m.wr.wc.m.lines = 0
call wrSet m,
, "do xx=1 to m.stem.0; " ,
" m.wr.wc.m.lines = m.wr.wc.m.lines + 1;",
" m.wr.wc.m.chars = m.wr.wc.m.chars + length(m.stem.xx);" ,
" call piOutLn 'piWC'" m "': ' m.stem.xx;" ,
" end;",
, "call piOutLn 'piWC' m 'counted'",
" m.wr.wc.m.lines 'lines and'",
" m.wr.wc.m.chars 'characters'"
return
endProcedure piWC
pipePush: procedure expose m.
parse arg pp
if pp == "" then
pp = 0
m.pi.pipe = pp
px = m.pi.pipe.0 + 1
m.pi.pipe.0 = px
m.pi.pipe.px = pp
return
endProcedure pipePush
pipePop: procedure expose m.
m.pi.pipe = p
px = m.pi.pipe.0 - 1
m.pi.pipe.0 = px
m.pi.pipe = m.pi.pipe.px
return
endProcedure pipePop
pipeActive: procedure expose m.
parse arg mustBeActive, mustHaveChild
if m.pi.pipe == 0 then do
if mustBeActive then
call err 'pipe not active'
else
return 0
end
else do
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
if cx == 0 then do
if mustHaveChild then
call err 'pipe is empty'
else
return 0
end
if m.pi.pi ^== m.pi.piChild.pp.cx then
call err 'pipe mismatched currentProcess' m.pi.pi
return m.pi.pi
end
endProcedure pipeActive
pipeBegin: procedure expose m.
nn = wrNew()
call pipePush nn
m.pi.piChild.nn.0 = 0
m.pi.piHist.nn.0 = m.pi.pi
return pipeChildBegin()
endProcedure pipeBegin
pipeBar: procedure expose m.
call pipeChildEnd
return pipeChildBegin()
endProcedure pipeBar
pipeChildEnd: procedure expose m.
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
if m.pi.pi ^== m.pi.piChild.pp.cx then
call err 'proc not last child'
m.pi.pi = m.pi.pipe
return
endProcedure pipeChildEnd
pipeChildBegin: procedure expose m.
if m.pi.pi ^== m.pi.pipe then
call err 'proc not current pipe'
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
ch = m.pi.piChild.pp.cx
if cx ^== 0 then
ch = m.pi.out.ch
else
ch = wrNew()
call piSet ch
cx = cx + 1
m.pi.piChild.pp.0 = cx
m.pi.piChild.pp.cx = ch
m.pi.pi = ch
return ch
endProcedure pipeChildBegin
pipeEnd: procedure expose m.
call pipeChildEnd
pp = m.pi.pipe
cx = m.pi.piChild.pp.0
ch = m.pi.piChild.pp.cx
call piSet pp, m.pi.piChild.pp.cx
call pipePop
m.pi.pi = pp
call piWriClo "call pipeWrite m, stem", "call pipeClose m"
m.pi.pi = m.pi.piHist.pp.0
return pp
endProcedure pipeEnd
piWriClo: procedure expose m.
parse arg wri, clo
call wrSet m.pi.pi, wri, clo
if pipeActive(0, 0) == 0 then
call wrClose m.pi.pi
return
endProcedure piWriClo
pipeWrite: procedure expose m.
parse arg m, stem
oldP = m.pi.pi
m.pi.pi = m.pi.piChild.m.1
call write m.pi.pi, stem
m.pi.pi = oldP
return
endProcedure pipeWrite
pipeClose: procedure expose m.
parse arg m
oldP = m.pi.pi
do cx = 1 to m.pi.piChild.m.0
m.pi.pi = m.pi.piChild.m.cx
call wrClose m.pi.pi
end
m.pi.pi = oldP
return
endProcedure pipeClose
/**********************************************************************
proc = process
***********************************************************************/
procIni: procedure expose m.
m.proc.proc = 0
m.proc.proc.0 = 0
m.proc.out = 0
m.proc.ini = 1
return
endProcedure procNew
procNew: procedure expose m.
parse arg nn, oo
if nn == '' then
nn = prNew()
if oo == '' then
oo = prNew()
m.proc.out.nn = oo
return nn
endProcedure procNew
procPush: procedure expose m.
parse arg pp
ix = m.proc.proc.0 + 1
m.proc.proc.0 = ix
m.proc.proc.ix = pp
m.proc.proc = pp
m.proc.out = m.proc.out.pp
return
endProcedure procPush
procPop: procedure expose m.
ix = m.proc.proc.0 -1
m.proc.proc.0 = ix
pp = m.proc.proc.ix
m.proc.proc = pp
m.proc.out = m.proc.out.pp
return
endProcedure procPop
procOut: procedure expose m.
parse arg stem
call write m.proc.out, stem
return
endProcedure procOut
procOutLn: procedure expose m.
parse arg stem
call writeLn m.proc.out, stem
return
endProcedure procOutLn
procInfo: procedure expose m.
parse arg arg, oo
do cx = m.proc.proc.0 by -1 to 1
ch = m.proc.proc.cx
if ch ^== 0 & m.proc.info.ch ^== '' then
call wrInfoInter ch, arg, oo
end
return
endProcedure procInfo
/**********************************************************************
wr = writer interface and simple writers
***********************************************************************/
wrWriClo: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, m.wr.info.m, m.wr.buf.m.max
if m.wr.buf.m.max == '' then
m.wr.buf.m.max = 100
return
endProcedure wrWriClo
wrNew: procedure expose m.
nn = m.wr.new + 1
m.wr.new = nn
m.wr.buf.nn.0 = 0
call wrSet nn, "" , "call err 'wr" nn "close not defined'", 9999
return nn
endProcedure wrNew
wrIni: procedure expose m.
m.wr.new = 0
m.wr.ini = 1
return
endProcedure wrNew
writeLn: procedure expose m.
parse arg m, line
xx = m.wr.buf.m.0 + 1
m.wr.buf.m.0 = xx
m.wr.buf.m.xx = line
if xx >= m.wr.buf.m.max then
call write m
return
endProcedure writeLn
write: procedure expose m.
parse arg m, stem
if m.wr.write.m == '' then do
if stem == 'WR.BUF.'m then
call err 'wrStemWrite overflow m.wr.buf.'m'.0 =' ox
ox = m.wr.buf.m.0
do ix=1 to m.stem.0
ox = ox + 1
m.wr.buf.m.ox = m.stem.ix
end
m.wr.buf.m.0 = ox
return
end
call procPush m
if m.wr.buf.m.0 ^== 0 then do
call writeInter m, 'WR.BUF.'m
m.wr.buf.m.0 = 0
end
if stem ^== '' then
call writeInter m, stem
call procPop
return
endProcedure write
wrClose: procedure expose m.
parse arg m
call write m
call procPush m
interpret m.wr.close.m
call procPop
return
endProcedure wrClose
writeInter: procedure expose m.
parse arg m, stem
interpret m.wr.write.m
return
endProcedure writeInter
wrInfoInter: procedure expose m.
parse arg m, info, out
interpret m.proc.info.ch
return
endProcedure wrInfoInter
wrSay: procedure expose m.
parse arg m, pref, head
call wrSet m, "call w1Say stem," quote(pref)"," quote(head),
, "say 'close'" m quote(head), 1
return
endProcedure wrSay
w1Say: procedure expose m.
parse arg stem, pref, head
if head ^== '' then
say head 'm.'stem'.0='m.stem.0
if pref == '' then do
do xx=1 to m.stem.0
say m.stem.xx
end
end
else do
do xx=1 to m.stem.0
say pref xx':' m.stem.xx
end
end
return
endProcedure w1Say
wrFile: procedure expose m.
parse arg m, args
dsn = ''
disp = 'shr'
do wx=1 to words(args)
w = word(args, wx)
if abbrev(w, '-dd') then do
dd = subword(w, 4)
call writeDDBegin dd
call wrSet m, "call writeNext" dd", m.stem."),
, "call writeDDEnd" dd
return
end
else if abbrev(w, '-disp') then
disp = substr(w, 6)
else if abbrev(w, '-dsn') then
dsn = substr(w, 5)
else if abbrev(w, '-t') then do
if length(t) > 2 then
dsn = dsnTemp(substr(w, 3))
else
dsn = dsnTemp('T'm)
end
else
leave
end
dd = 'wr'm
call adrTso "alloc dd("dd")" disp ,
"dsn("dsn")" subword(args, wx)
call writeDDBegin dd
call wrSet m, "call writeNext" dd", m.stem.",
, "call writeDDEnd" dd "; call adrTso 'free dd("dd")'"
return
endProcedure wrFile
wrWC: procedure expose m.
parse arg m, args
m.wr.wc.m.chars = 0
m.wr.wc.m.lines = 0
call wrSet m,
, "do xx=1 to m.stem.0; " ,
" m.wr.wc.m.lines = m.wr.wc.m.lines + 1;",
" m.wr.wc.m.chars = m.wr.wc.m.chars + length(m.stem.xx);" ,
" call writeLn" args ", 'wrWC'" m "': ' m.stem.xx;" ,
" end;",
, "call writeLn" args ", wrWC m 'counted'",
" m.wr.wc.m.lines 'lines and'",
" m.wr.wc.m.chars 'characters'"
return
endProcedure wrSay
ppWrite: procedure expose m.
parse arg stem
oldProc = m.pp.proc
m.pp.proc = m.pp.out.oldProc
call iiWrite m.pp.proc, stem
m.pp.proc = oldProc
return
endProcedure ppWrite
ppClose: procedure expose m.
parse arg m
oldProc = m.pp.proc
m.pp.proc = m.pp.out.oldProc
call iiClose m.pp.proc
m.pp.proc = oldProc
return
endProcedure ppClose
ppNew: procedure expose m.
nn = iiNew()
m.pp.paP.n =
ppBegin: procedure expose m.
iiWrite: procedure expose m.
parse arg m, stem
interpret m.ii.write.m
return
endProcedure iiWrite
iiClose: procedure expose m.
parse arg m
interpret m.ii.close.m
return
endProcedure iiClose
iiOpenOut: procedure expose m.
parse arg m, typ, opt, opt2
if typ == 'i' then do
m.ii.write.m = opt
m.ii.close.m = opt2
end
else if typ == '*' then do
m.ii.write.m = ,
'do x=1 to m.stem.0; say "'m'.*.out" m.stem.x; end'
m.ii.close.m = 'say "'m'.*.out close"'
end
else
call err 'bad typ' typ 'in iiOpenOut'
return
endProcedure iiOpenOut
iiOpenNew: procedure expose m.
parse arg k, typ, opt, opt2
nn = iiNew()
if k == 'o' then
call iiOpenOut nn, typ, opt, opt2
else
call err 'bad iiOpenNew kind' k
return nn
endProcedure iiOpenNew
iiNew: procedure expose m.
m.ii.0 = m.ii.0 + 1
return m.ii.0
endProcedure iiNew
iiIni: procedure expose m.
parse arg force
if m.ii.ini == 1 & force ^== 1 then
return
m.ii.ini = 1
m.ii.0 = 0
return
endProcedure iiIni
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
memWriteWrite 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 ****************************************************/