zOs/REXX.O08/WR
/* copy wr begin *****************************************************
out interface
define a current output destination (a writerDescriptor)
manage them in a stack
convenience function to write to current output
***********************************************************************/
/*--- write stem stem to current output ------------------------------*/
out: procedure expose m.
parse arg stem
call write m.wr.out, stem
return
endProcedure
/*--- write up to 3 strings to current output ------------------------*/
outLn: procedure expose m.
m = m.wr.out
ox=m.wr.wrBuf.m.0
do ax=1 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure
/*--- write to current output from datasetSpec dss -------------------*/
outDS: procedure expose m.
parse arg dss
call wrFromDS m.wr.out, dss
return
endProcedure outDS
/*--- write reader rx to out -----------------------------------------*/
outReader: procedure expose m.
parse arg rx
call wrReader m.wr.out, rx
return
endProcedure outReader
/*--- redirect current output ----------------------------------------*/
outPush: procedure expose m.
parse arg o, p
x = m.wr.out.0 + 1
m.wr.out.0 = x
m.wr.out.x = m.wr.out
m.wr.prc.x = m.wr.prc
if o ^== '' then
m.wr.out = o
if p ^== '' then
m.wr.prc = p
return
endProcedure outPush
/*--- redirect current output to previous ----------------------------*/
outPop: procedure expose m.
parse arg o
x = m.wr.out.0
m.wr.out.0 = x - 1
m.wr.out = m.wr.out.x
m.wr.prc = m.wr.prc.x
return
endProcedure outPop
/**********************************************************************
writer interface
a writerDescriptor wx is allocated with wrNew
we can define the write and wrClose functionality arbitrarily
***********************************************************************/
/*--- create a new writeDescriptore ----------------------------------*/
wrNew: procedure expose m.
parse arg typ, reuseOK
if m.wr.free.0 < 1 | reuseOK == 0 then do
nn = m.wr.new + 1
m.wr.new = nn
end
else do
fx = m.wr.free.0
m.wr.free.0 = fx - 1
nn = m.wr.free.fx
end
m.wr.prcTyp.nn = typ
m.wr.prcSta.nn = ''
m.wr.wrBuf.nn.0 = 0
return nn
endProcedure wrNew
/*--- free the writeDescriptors arg(1)... ----------------------------*/
wrFree: procedure expose m.
fx = m.wr.free.0
do i = 1 to arg()
fx = fx + 1
m.wr.free.fx = arg(i)
end
m.wr.free.0 = fx
return
endProcedure wrFree
/*--- for writeDescriptor m define write and close -------------------*/
wrDefine: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, wr2, wr3
if wr2 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end;',
'do ggLX=1 to m.stem.0;',
'line = stem"."ggLx;' wr2,
'; end; do;' wr3'; end'
else if wr3 ^== '' then
m.wr.write.m = 'do;' m.wr.write.m'; end; do;' wr3'; end'
return m
endProcedure wrDefine
/*--- write stem m.stem. to writeDescriptor m ------------------------*/
write: procedure expose m.
parse arg m, stem
if m.wr.write.m == 'b' then do
if stem ^== '' then
call wrStem 'WR.WRBUF.'m, , stem
return
end
if m.wr.wrBuf.m.0 ^== 0 then do
ggOrigStem = stem
stem = 'WR.WRBUF.'m
interpret m.wr.write.m
m.wr.wrBuf.m.0 = 0
stem = ggOrigStem
end
if stem ^== '' then
interpret m.wr.write.m
return
endProcedure write
/*--- write up to 3 strings to writeDescriptor m ---------------------*/
writeLn: procedure expose m.
parse arg m
ox=m.wr.wrBuf.m.0
do ax=2 to arg()
ox = ox + 1
m.wr.wrBuf.m.ox = arg(ax)
end
m.wr.wrBuf.m.0 = ox
if ox > 100 then
call write m
return
endProcedure writeLn
/*--- close writeDescriptor m ----------------------------------------*/
wrClose: procedure expose m.
parse arg m
if m.wr.wrBuf.m.0 ^== 0 then
call write m
m.wr.wrbuf.pp.0 = 0 /* in case it was buffering */
interpret m.wr.close.m
return
endProcedure wrClose
/*--- initialisation writer and output -------------------------------*/
wrIni: procedure expose m.
parse arg tr
m.wr.trace = tr = 1
m.wr.new = 0
m.wr.free.0 = 0
m.wr.out = wrNew()
m.wr.sysout = m.wr.out
m.wr.prc = wrNew()
m.wr.rootPrc = m.wr.prc
if m.wr.trace then
m.wr.sysOut = wrDefine(m.wr.out,,,'say "sysout:" quote(m.line)')
else
m.wr.sysOut = wrDefine(m.wr.out,,, 'say strip(m.line, "T")')
m.wr.out.0 = 0
return
endProcedure wrIni
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
wrStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure wrStem
/*--- strip trailing spaces from stem dst ----------------------------*/
wrStrip: procedure expose m.
parse arg dst
do ix=1 to m.dst.0
m.dst.ix = strip(m.dst.ix, 't')
end
return dst
endProcedure wrStrip
/*--- fill stem dst from index dx with arguments ---------------------*/
wrArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure wrArgs
/***********************************************************************
reader interface
define, read and close
***********************************************************************/
/*--- define read function -------------------------------------------*/
reDefine: procedure expose m.
parse arg m, m.wr.read.m, m.wr.readCLose.m, m.wr.readInfo.m
m.wr.readLX.m = ''
m.wr.readSX.m = 0
m.wr.readEOF.m = 0
return m
endProcedure reDefine
/*--- read from readDescriptor into stem stem
return true if data read, false at eof --------------------*/
read: procedure expose m.
parse arg m, stem
if m.wr.readEOF.m then
return 0
do forever
interpret m.wr.read.m
if ^ res then
return reClose(m)
if m.stem.0 > 0 then do
m.wr.readSX.m = m.wr.readSX.m + m.stem.0
return 1
end
end
endProcedure write
/*--- close readDescriptor m, if not already done --------------------*/
reClose: procedure expose m.
parse arg m
if ^ m.wr.readEOF.m then do
m.wr.readEOF.m = 1
interpret m.wr.readClose.m
end
return 0
endProcedure reClose
/*--- put next line into m.line, return false at eof -----------------*/
readLn: procedure expose m.
parse arg m, line
if m.wr.readLx.m == '' | m.wr.readLx.m >= m.wr.readStem.m.0 then do
if ^ read(m, 'WR.READSTEM.'m) then
return 0
lx = 1
end
else do
lx = 1 + m.wr.readLx.m
end
m.wr.readLx.m = lx
m.line = m.wr.readStem.m.lx
return 1
endProcedure readLn
/*--- return readInfo for line lx ------------------------------------*/
readInfo: procedure expose m.
parse arg m, lx
if m.wr.readEof.m then
txt = 'eof after line' m.wr.readSx.m
else if lx == '' then
txt = 'last line of stem' m.wr.readSx.m
else if lx == '*' then
txt = 'line' (m.wr.readSx.m - m.wr.readStem.m.0 + m.wr.readLX.m)
else
txt = 'line' (m.wr.readSx.m + lx)
return txt 'from dss' m.wr.readInfo.m
endProcedure readInfo
/***********************************************************************
Input-Ouput
transfer data betweeen stems and datasets
these are specified using a DataSetSpec DSS see wrAlloc:
***********************************************************************/
/*--- define writeDescriptor m to write to the datasetSpec dss */
wr2DS: procedure expose m.
parse arg m, dss
ty = wrAlloc(m, 'o', dss)
stmt = ''
if m.wr.allocStrip.m then
stmt = 'call wrStrip stem;'
if ty == 's' then do
call wrDefine m,
, stmt 'call wrStem' quote(m.wr.allocStem.m) ', , stem',
, m.wr.allocFree.m
end
else if ty == 'd' then do
dd = m.wr.allocDD.m
call writeDDBegin dd
call wrDefine m,
, stmt 'call writeDD' quote(dd) ', "M."'stem'"."',
, 'call writeDDEnd' quote(dd)';' m.wr.allocFree.m
end
else
call err 'wr2Ds bad allocType' ty 'from' dss
return m
endProcedure
/*--- define m as reader to read from datasetSpec dss ---------------*/
readDS: procedure expose m.
parse arg m, dss
if dss = '' then
call err 'wrFromDS empty datasetSpecification'
iTyp = wrAlloc(m, 'i', dss)
strp = ''
if m.wr.allocStrip.m then
strp = 'if res then call wrStrip stem;'
if iTyp == 's' then do
m.wr.readDone.m = 0
call reDefine m,
, 'if m.wr.readSX.m ^== 0 then res = 0;else do;' ,
'call wrStem stem, 0,' quote(m.wr.allocStem.m)';' ,
'res = m.stem.0 > 0;' strp 'end', , dss
end
else if iTyp = 'd' then do
dd = quote(m.wr.allocDD.m)
call reDefine m, 'res = readDD('dd', "m."stem".");' strp,
, 'call readDDEnd' dd';' m.wr.AllocFree.m, dss
end
else
call err 'readDS: bad allocTyp' iTyp 'from' dss
return m
endProcedure readDS
/*--- write to writeDescriptor m from readDescriptor r ---------------*/
wrReader: procedure expose m.
parse arg m, r
st = 'WR.FROMREAD.'m
do while read(r, st)
call write m, st
end
return
endProcedure wrReader
/*--- write to writeDescriptor m from datasetSpec dss ----------------*/
wrFromDS: procedure expose m.
parse arg m, dss
rx = wrNew('wrFromDS')
call wrReader m, readDS(rx, dss)
call wrFree rx
return
endProcedure wrFromDS
/*--- write to datasetSpec toSp from datasetSpec arg(2)... -----------*/
wrDSFromDS: procedure expose m.
parse arg toSP
m = wrNew('wrDSFromDS')
call wr2DS m, toSp
do ax=2 to arg()
frSp = arg(ax)
if ax ^= '' then
call wrFromDs m, frSp
end
call wrClose m
call wrFree m
return
endProcedure wrFromDS
/*----------------------------------------------------------------------
wrAlloc: allocate a file or stem withe default ioa
from datasetSpecification dss
dss in key=value syntax, either tso alloc attributes or
disp=...,
dsj= DatasetName in Jcl format (dsn= for tso format)
stem=xyz to allocate a stem m.xyz.*
strip=1 to strip trailing blanks before writing
ioa= i, o or a (input, output or append)
----------------------------------------------------------------------*/
wrAlloc: procedure expose m.
parse arg m, ioa, dss
s = 'WR.ALLOC'
m.wr.allocDD.m = ''
stem = ''
at = ''
disp = ''
m.wr.allocStrip.m = 0
m.wr.allocFree.m = ''
call scanBegin s, dss
do while scanKeyValue(s, 1, 0)
k = m.s.key
if k == 'DD' then m.wr.allocDD.m = m.s.val
else if k == 'DSJ' then at = at "dsn('"m.s.val"')"
else if k == 'STEM' then stem = m.s.val
else if k == 'DISP' then disp = m.s.val
else if k == 'STRIP' then m.wr.allocStrip.m = m.s.val
else if k == 'IOA' then ioa = m.s.val
else if left(m.s.val, 1) = '(' then
at = at m.s.key || m.s.val
else at = at m.s.key"("m.s.val")"
end
if ^scanAtEOL(s) then
call scanErr s, 'wrAlloc bad clause'
upper ioa
if stem ^= '' then do
m.wr.allocStem.m = stem
if ioa == 'O' then /* overrite existing lines */
m.stem.0 = 0
m.wr.allocType.m = 's'
end
else if at = '' then do
if m.wr.allocDD.m = '' then
call err 'dd or attribute must be specified:' dss
m.wr.allocType.m = 'd'
end
else do
m.wr.allocType.m = 'd'
if m.wr.allocDD.m = '' then
m.wr.allocDD.m = 'ALL'm
if disp ^= '' then nop
else if ioa == 'A' then disp = 'mod'
else if ioa == 'O' then disp = 'old'
else disp = 'shr'
if m.wr.allocApp.m = 1 then do
d3 = translate(strip(left(disp, 3)))
if d3 == 'OLD' | d3 == 'SHR' then
disp = 'mod' || substr(strip(disp), 4)
end
call adrTso "alloc dd("m.wr.allocDD.m")" disp at
m.wr.allocFree.m = 'call adrTso' ,
quote('free dd('m.wr.allocDD.m')')
end
return m.wr.allocType.m
endProcedure wrAlloc
/* copy wr end ****************************************************/