zOs/REXX.O08/WAR
/* rexx ****************************************************************
synopsis: WAR cf <warFile> ( -C<home> ! <ds> )*
WAR xf <warFile> ( -C<home> ! <pref> )*
creates a warFile from a list of datasets and or members of a PDS
or extracts datasets and or members from a warFile
arguments:
cf create warfile (lowercase)
xf extract members/datasets from warfile (lowercase)
<warfile> DSN of the warfile
<home> the prefix of added or extracted datasets, default userid
<ds> if <home><ds> is a PDS all members are added,
if a seqential dataset or a member of a PDS it is added
<pref> extract all pds-members or datasets with this prefix,
to a DSN <pref> replaced by <home>
which must already be catalogued
***********************************************************************/
parse arg args
call errReset 'hi'
call warIni
if pos('?', args) > 0 then
return help()
else if args <> '' then
nop
else if 1 then
args = 'cf ~zzz.backup(d'right(date(s), 6)') -C~WK',
'CLIST JCL MSGS PANELS PLI REXX REXX.OLD SKELS SQL' ,
'TESTCASE TESTDATA TESTCRES TEXV'
else if 0 then
args = 'cf ~zzz.backup(tst20) -C~WK',
'CLIST JCL MSGS PANELS PLI REXX REXX.OLD SKELS SQL TESTCASE'
else if 0 then
args = 'cf ~zzz.backup(tst10) -C~WK MSGS PANELS'
else if 0 then
args = 'xf ~zzz.backup(d'right(date(s), 6)') -::F' ,
'-C~tmpUlW2 ~WK'
else
return errHelp('no args')
call warRun war(), args
exit
warIni: procedure expose m.
if m.war.ini == 1 then
return
m.war.ini = 1
m.war.0 = 0
call catIni
return
endProcedure warIni
war: procedure expose m.
parse arg r, w
m = 'WAR.'mInc('WAR.0')
call warReset m, r, w
return m
endProcedure war
warReset: procedure expose m.
parse arg m, w, i
call warClose m
if w == '' then
w = catDsn()
if i == '' then
i = catDsn()
m.m.war = w
m.m.item = i
m.m.home = warPref('~.')
m.m.allocCreate = ''
m.mark = ']'
m.beg = 'beg '
m.end = 'end '
return
endProcedure warReset
warClose: procedure expose m.
parse arg m, r, w
if symbol('m.m.war') == 'VAR' then
call jClose m.m.war
m.m.cItem = 0
m.m.cSkip = 0
m.m.cRecs = 0
m.m.cBytes = 0
return
endProcedure warClose
warRun: procedure expose m.
parse arg m, args
if pos('?', args) > 0 then
exit help()
fun = word(args, 1)
if ^ (fun == 'xf' | fun == 'cf') then
call err 'warRun first arg must be cf or xf not:' args
fun = left(fun, 1)
m.m.warDs = word(args, 2)
call jReset m.m.war, m.m.warDs
started = 0
do wx=3 to words(args)
if jOpt(word(args, wx), '', 'C:') then do
if m.j.oOpt == 'C' then
m.m.home = warPref(m.j.oVal)
else if m.j.oOpt == ':' then
m.m.allocCreate = ':'m.j.oVal
end
else if fun = 'c' then do
it = m.j.oVal
if ^started then
call jOpen m.m.war, 'w'
started = 1
call warAdd m, it
end
else do
started = 1
call warExtract m, m.j.oVal
end
end
if fun = 'x' then do
if ^ started then
call warExtract m
call jOut 'skipped' m.m.cSkip 'and' ,
'extracted' m.m.cItem 'datasets/members with',
m.m.cRecs 'records and' m.m.cBytes 'bytes' ,
'from' dsn2jcl(m.m.warDs)
end
else do
call jOut 'skipped' m.m.cSkip 'and' ,
'added' m.m.cItem 'datasets/members with',
m.m.cRecs 'records and' m.m.cBytes 'bytes' ,
'to' dsn2jcl(m.m.warDs)
end
call warClose m
return
warRun
warPref: procedure
parse arg dsn
return translate(strip(dsn2Jcl(dsn), 't', '.')'.')
endProcedure warPref
warAdd: procedure expose m.
parse arg m, pDsn
dsn = dsn2Jcl(m.m.home || pDsn)
if pos('(', dsn) > 0 then do
sd = sysDsn("'"dsn"'")
if sd == 'OK' then do
call warAddOne m, dsn
end
else do
m.m.cSkip = m.m.cSkip + 1
call jOut dsn sd
end
end
else do
sd = sysDsn("'"dsnSetMbr(dsn, abc)"'")
if sd == 'OK' | sd = 'MEMBER NOT FOUND' then do
call warAddPds m, dsn
end
else if right(sd, 15) == 'NOT PARTITIONED' then do
call warAddOne m, dsn
end
else do
m.m.cSkip = m.m.cSkip + 1
call jOut dsn sd
end
end
return
endProcedure warAdd
warAddPds: procedure expose m.
parse arg m, dsn
oRecs = m.m.cRecs
oBytes =m.m.cBytes
lmm = lmmBegin(dsn)
cnt = 0
do forever
mbr = lmmNext(lmm)
if mbr = '' then
leave
call warAddOne m, dsnSetMbr(dsn, mbr)
cnt = cnt + 1
end
call lmmEnd lmm
call jOut right(cnt, 6) 'mbrs,' right(m.m.cRecs-oRecs,10) 'recs,',
right(m.m.cBytes -oBytes, 10) 'B from' dsn
return
endProcedure warAddPds
warAddOne: procedure expose m.
parse arg m, dsn
upper dsn
it = m.m.item
call jReset it, dsn
call jOpen it, 'r'
w = m.m.war
call jWrite w, m.mark || m.beg || dsn
lx = 0
bx = 0
do while jRead(it, li)
lx = lx + 1
bx = bx + length(m.li)
if abbrev(m.li, m.mark) then
m.li = m.mark || m.li
call jWrite w, m.li
end
call jClose it
call jWrite w, m.mark || m.end || dsn
m.m.cItem = m.m.cItem + 1
m.m.cRecs = m.m.cRecs + lx
m.m.cBytes = m.m.cBytes + bx
return
endProcedure warAddOne
warExtract: procedure expose m.
parse arg m, filt
filt = warPref(filt)
it = m.m.item
w = m.m.war
call jOpen w, 'r'
sta = 0
wMa = m.mark
wMM = wMa || wMa
wBe = wMa || m.beg
wEn = wMa || m.end
do while jRead(w, li)
if abbrev(m.li, wMa) then do
if abbrev(m.li, wMM) then do
m.li = substr(m.li, 1+length(wMa))
end
else if abbrev(m.li, wBe) then do
if sta ^== 0 then
call err 'item begin but sta ' sta ':' m.li
dsn = translate(strip(substr(m.li, 1 + length(wBe))))
if ^ abbrev(dsn, filt) then do
sta = 2
end
else do
sta = 1
toDs = m.m.home || substr(dsn, length(filt) + 1)
call jReset it, toDs m.m.allocCreate
call jOpen it, 'w'
end
iterate
end
else if abbrev(m.li, wEn) then do
if sta = 1 then do
m.m.cItem = m.m.cItem + 1
call jClose it
end
else if sta = 2 then do
m.m.cSkip = m.m.cSkip + 1
end
else do
call err 'item end but sta ' sta ':' m.li
end
cc = translate(strip(substr(m.li, 1 + length(wEn))))
if dsn ^== cc then
call err 'mismatch end' cc 'after begin' dsn
sta = 0
if (m.m.cSkip+m.m.cItem) // 100 = 0 then
call jOut 'skipped' m.m.cSkip 'and' ,
'extracted' m.m.cItem 'datasets/members with',
m.m.cRecs 'records and' m.m.cBytes 'bytes',
'last to' toDs
iterate
end
else do
call err 'bad line (sta' sta'):' m.li
end
end
if sta = 1 then do
call jWrite it, m.li
m.m.cRecs = m.m.cRecs + 1
m.m.cBytes = m.m.cBytes + length(m.li)
end
else if sta ^== 2 then do
call err 'data in bad sta' sta':' m.li
end
end
if sta ^== 0 then
call err 'bad sta' sta 'at end of extract'
call jClose w
return
endProcedure warAddOne
/* copy cat begin ****************************************************
***********************************************************************/
catOpt: procedure
parse arg opt, keep
if abbrev(opt, '<') then
o = 'r'substr(opt, 2)
else if abbrev(opt, '>>') then
o = 'a'substr(opt, 3)
else if abbrev(opt, '>') then
o = 'w'substr(opt, 2)
else if pos(left(opt, 1), 'rwa') > 0 then
o = opt
else
o = '?'opt
if keep ^== 1 then
o = translate(o, ' ', '£#')
return space(o, 0)
endProcedure catOpt
/*--- create and possibly open a reader or writer --------------------*/
catMake: procedure expose m.
parse arg opt, spec
o = catOpt(opt, 1)
if pos('£', o) > 0 then
return spec
else if pos('#', o) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, '£', '#'), envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', o) > 0 then
return catDsn('&'spec)
else
return catDsn(spec)
call err 'catMake implement' opt
if defDsn == '' then do
o = left(o, length(o)-1)
end
else if defDsn == '' then do
rw = catDsn(spec)
end
else do
rw = jReset(defDsn, spec)
end
if pos('-', o) < 1 then
call jOpen rw, o
return rw
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat')
m.m.catIx = -9
call catReset m
do ax=1 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catToClose = ''
m.m.catIx = -9
call oSetTypePara m
do ax=2 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
end
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx = mInc(m'.RWS.0')
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
if m.m.catIx >= 0 then do
if m.m.catRd ^== '' then do
ix = m.m.catIx
if pos('-', m.m.opts.ix) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
do wx = 1 to words(m.m.catToClose)
cl = word(m.m.catToClose, wx)
if cl ^== m then
call jClose cl
end
m.m.catToClose = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
call jClose m
if oo = 'r' then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if oo == 'w' | oo == 'a' then do
if oo == 'w' then
m.m.RWs.0 = 0
m.m.catIx = -7
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 & pos('-', m.m.opts.cx) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
oo = overlay('r', m.m.opts.cx)
if pos('-', oo) < 1 then
call jOpen m.m.RWs.cx, oo
return m.m.RWs.cx
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd ^== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then do
m.m.catWr = jOpen(jBuf(), 'w')
call oSetTypePara m.m.catWr, oGetTypePara(m)
end
call jWrite m.m.catWr, line
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)',' arg(3)') but opened,',
'catIx='m.m.catIx
bx = m.m.RWs.0
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx=bx+1
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
do ax=2 by 2 to arg()
bx=bx+1
m.m.opts.bx = catOpt(arg(ax))
m.m.RWs.bx = catMake(arg(ax), arg(ax+1))
call oSetTypePara m, oGetTypePara(m.m.RWs.bx)
end
m.m.RWs.0 = bx
return
endProcedure catWriteAll
/*--- store the list toClose to close them when closing cat ----------*/
catLazyClose: procedure expose m.
parse arg m, toClose
if m.m.catIx <> -7 then
call err 'catLazyClose with catIx' m.m.catIx
if m.m.RWs.0 = 0 then
return 0
if m.m.catToClose ^== '' then
call err 'catLazyClose with catToClose' m.m.catToClose
if m.m.catIx <> -7 | m.m.catToClose ^== '' then
m.m.catToClose = toClose
return 1
endProcedure catLazyClose
catSetTypePara: procedure expose m.
parse arg m, type
do ix=1 to m.m.RWs.0
call oSetTypePara m.m.RWs.ix, type
end
return
endProcedure catSetTypePara
/*--- create a reader/writer for a dsn -------------------------------*/
catDsn: procedure expose m.
parse arg spec
m = oNew('CatDsn')
m.m.readIx = 'c'
ix = mInc('CAT.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'CAT.BUF'ix
call catDsnReset m, spec
return m
endProcedure catDsn
catDsnReset: procedure expose m.
parse arg m, sp
if symbol('m.m.defDD') ^== 'VAR' then
m.m.defDD = 'CDD' mInc('CAT.DEFDD')
m.m.spec = sp
return m
endProcedure catDsnReset
catDsnOpen: procedure expose m.
parse arg m, opt
call jClose m
buf = m.m.buf
if opt == 'r' then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == 'w' then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else
call err 'catDsnOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure catDsnOpen
catDsnClose:
parse arg m
buf = m.m.buf
if m.m.readIx ^== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure catDsnClose
catDsnRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if ^ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
return 1
endProcedure catDsnRead
catDsnWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure catDsnWrite
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
m.cat.buf = 0
call jIni
call oDecMethods oNewClass("Cat", "JRW"),
, "jOpen return catOpen(m, arg)",
, "jReset return catReset(m, '', arg)",
, "jClose call catClose m",
, "jWriteAll call err 'jWriteAll not opened w",
, "oSetTypePara call catSetTypePara m, type",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteAll call catWriteAll m, opt, rdr; return"
call oDecMethods oNewClass("CatDsn", "JRW"),
, "jOpen return catDsnOpen(m, arg)",
, "jReset return catDsnReset(m, arg)",
, "jClose call catDsnClose m",
, "jRead return catDsnRead(m, var)",
, "jWrite call catDsnWrite m, line"
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
if m.m.jReading then
interpret oObjMethod(m, 'jRead')
else
call err 'jRead('m',' var') but not opened r'
else
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
if m.m.jWriting then
interpret oObjMethod(m, 'jWrite')
else
call err 'jWrite('m',' line') but not opened w'
return
endProcedure jWrite
jWriteAll: procedure expose m.
parse arg m, opt, rdr
interpret oObjMethod(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteAllImpl: procedure expose m.
parse arg m, opt, rdr
if pos('-', opt) < 1 then
call jOpen rdr, catOpt(opt)
do while jRead(rdr, line)
call jWrite m, m.line
end
if pos('-', opt) < 1 then
call jClose rdr
return
endProcedure jWriteAll
jReset: procedure expose m.
parse arg m, arg
call jClose m
interpret oObjMethod(m, 'jReset')
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret oObjMethod(m, 'jOpen')
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
if m.m.jReading = 1 | m.m.jWriting = 1 then
interpret oObjMethod(m, 'jClose')
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
call oIni
call oDecMethods oNewClass("JRW"),
, "jRead call err 'jRead('m',' var') but not opened r'",
, "jWrite call err 'jWrite('m',' line') but not opened w'",
, "jWriteAll call jWriteAllImpl m, opt, rdr",
, "jRead drop m.arg; return 0",
, "jWrite say 'jOut:' line",
, "jReset ;",
, "jOpen ;",
, "jClose ;"
x = oNew("JRW")
m.j.jIn = x
m.x.jReading = 1
m.x.jWriting = 0
x = oNew("JRW")
m.j.jOut = x
m.x.jReading = 0
m.x.jWriting = 1
call oDecMethods oNewClass("Jbuf", "JRW"),
, "jOpen return jBufOpen(m, arg)",
, "jReset return jBufReset(m, arg)",
, "oSetTypePara call jBufSetTypePara m, type",
, "jRead return jBufRead(m, var)",
, "jWrite call jBufWrite m, line"
return
endProcedure jInit
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('Jbuf')
call jBufReset m
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
m.m.buf.0 = 0
call oSetTypePara m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
m.m.buf.0 = ax
end
return m
endProcedure jBufReset
jBufSetTypePara: procedure expose m.
parse arg m, type
if m.m.buf.0 <> 0 then
call err 'jBufSetTypePara but not empty'
return
endProcedure jBufSetTypePara
jBufOpen: procedure expose m.
parse arg m, opt
call jClose m
if opt == 'r' then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == 'w' then
m.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.var = m.m.buf.nx
else
call oTyCopy ty, var, m'.BUF.'nx
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
nx = mInc(m'.BUF.0')
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.m.buf.nx = line
else
call oTyCopy ty, m'.BUF.'nx, line
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy oFld begin *****************************************************
defines classes with field names
is the base for the oo layer in copy o
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
oFldIni: procedure expose m.
if m.oFld.ini = 1 then
return
m.oFld.ini = 1
call mapIni
m.o.fldOnly = mapNew() /* map fields -> class */
m.o.cla.0 = 0 /* the stem for classes */
call oFldNew 'Class', '=', , , /* MetaClass definieren */
'INST = MET .<>= FLD .<>=Class STEM =Class'
return
endProcedure oFldIni
/*--- create a new class
name: name of new class, a star will be replaced by a number
va: type of value
st: type of stem
flds: pairs of field names and types
dup: duplicate resolver -----------------------------------*/
oFldNew: procedure expose m.
parse arg name, va, st, flds, dup
if pos('*', name) > 0 then
name = oPut('O.CLA', name, , '*')
else
call oPut 'O.CLA', name, , 'n'
m.o.cla.name.inst = 0
m.o.cla.name.val = va
m.o.cla.name.stem = st
m.o.cla.name.FLD.0 = 0
m.o.cla.name.MET.0 = 0
return oFldAdd(name, flds, dup)
endProcedure oFldNew
/*--- create or find a class with only simple fields fs --------------*/
oFldOnly: procedure expose m.
parse arg fs, dup
kk = space(fs '?'dup, 1)
if mapHasKey(m.o.fldOnly, kk) then
return mapGet(m.o.fldOnly, kk)
if dup ^== 'e' then do
ll = space(fs, 1)
end
else do
ll = ''
do wx=1 to words(fs)
w = word(fs, wx)
v = w
do x=2 while wordPos(v, ff) > 0
v = w || x
end
ll = space(ll v, 1)
end
end
if mapHasKey(m.o.fldOnly, ll) then do
nn = mapGet(m.o.fldOnly, ll)
end
else do
nn = oFldNew('FldType*')
st = 'O.CLA.'nn'.FLD'
do lx=1 to words(ll)
call oPut st, word(ll, lx), '=', dup
end
call mapPut m.o.fldOnly, ll, nn
end
call mapPut m.o.fldOnly, kk, nn
return nn
endProcedure oFldOnly
/*--- return the stem of flds of class type --------------------------*/
oFlds: procedure expose m.
parse arg type
return 'O.CLA.'type'.FLD'
/*--- return the concatenation of the fields of type ty in stem st
formated by fmt -------------------------------------------*/
oFldCat: procedure expose m.
parse arg ty, st, fmt
flds = oFlds(ty)
res = ''
do ix=1 to m.flds.0
f = m.flds.ix
if fmt == '' then
res = res m.st.f
else
res = res fmt(m.st.f, m.fmt.ix)
end
return substr(res, 2)
endProcedure oFldCat
/*--- add fields to class cl given as name type pairs in fs ----------*/
oFldAdd: procedure expose m.
parse arg cla, fs, dup
st = 'O.CLA.'cla'.FLD'
do ix=1 by 2 to words(fs)
call oPut st, word(fs, ix), word(fs, ix+1), dup
end
return cla
endProcedure oFldAdd
/*--- add/put key k with value v to stem st
duplicate handling dup:
* replace * in k by a number until it is new
e add a number in it is not new
o replace old value at existing key
= add a new key, fail if key exists and value is different
------------------------------------------------------------*/
oPut: procedure expose m.
parse arg st, k, v, dup
if dup = '*' then do
cx = pos('*', k)
if cx < 1 then
call err 'no * in key' k
k = oPutDupResolve(st, left(k, cx-1), 1)
end
else if symbol('m.st.k') = 'VAR' then do
if dup = '' | dup = 'o' then do
m.st.k = v
return k
end
if dup = '=' then do
if v <> m.st.k | ^ (v = '' & datatype(m.st.k, 'n')) then
call err 'not =: m.'st'.'k '=>' m.st.k '<>' v
return k
end
if dup = 'e' then
k = oPutDupResolve(st, k, 2)
else
call err 'key' k 'exists in' st 'but dup' dup
end
else if dup = 'o' then
call err 'old key' k 'does not exist in' st
if datatype(k, 'n') | words(k) <> 1 | pos('.', k) > 0 then
call err 'illegal name' k
x = m.st.0 + 1
m.st.0 = x
m.st.x = k
if v == '' then
m.st.k = x
else
m.st.k = v
return k
endProcedure oPut
oPutDupResolve: procedure expose m.
parse arg st, k, b
do ix=b
a = k || ix
if symbol('m.st.a') <> 'VAR' then
return a
end
endProcedure oPutDupResolve
/*--- parameterized types --------------------------------------------*/
oGetTypePara: procedure expose m.
parse arg m
if symbol('m.o.tyPa.m') == 'VAR' then
return m.o.tyPa.m
else
return '='
endProcedure oGetTypePara
oSetTypePara: procedure expose m.
parse arg m, type, noCall
if type = '' then
type = '='
if oGetTypePara(m) == type then
return
if noCall ^== 'noCall' then
interpret oObjMethod(m, 'oSetTypePara')
m.o.tyPa.m = type
return
endProcedure oSetTypePara
/* copy oFld end ***************************************************/
/* copy o begin ********************************************************
object layer has three freatures
* an object may have a class which has methods
* an object may have a parmeterized type
* a class may contain field descriptions
***********************************************************************/
oClaMethod: procedure expose m.
parse arg cl, me
if symbol('m.o.cla.cl.met.me') = 'VAR' then
return m.o.cla.cl.met.me
else
call err 'no method' me 'in class' cl
endProcedure oClaMethod
oHasMethod: procedure expose m.
parse arg obj, me
cla = oGetClass(obj)
return symbol('m.o.cla.cl.met.me') = 'VAR'
endProcedure oHasMethod
oGetClass: procedure expose m.
parse arg Obj
if symbol('m.o.obj2cla.Obj') = 'VAR' then
return m.o.obj2cla.Obj
call err 'no class found for object' obj
endProcedure oGetClass
oObjMethod: procedure expose m.
parse arg obj, me
if symbol('m.o.obj2cla.obj') = 'VAR' then
return oClaMethod(m.o.obj2cla.obj, me)
if abbrev(obj, 'oCast:') then do
cx = pos(':', obj, 7)
return 'M="'substr(obj, cx+1)'";' ,
oClaMethod(substr(obj, 7,cx-7), me)
end
call err 'no class found for object' obj
endProcedure oObjMethod
oCast: procedure
parse arg obj, cl
if abbrev(obj, 'oCast:') then
obj = substr(obj, 1 + pos(':', obj, 7))
return 'oCast:'cl':'obj
endProcedure oCast
oNewClass: procedure expose m.
parse arg name, super
/* call oIni */
name = oFldNew(name)
neMe = 'O.CLA.'name'.MET'
neFi = 'O.CLA.'name'.FLD'
do sx=1 to words(super)
sup = word(super, sx)
if symbol('m.o.cla.sup') ^== 'VAR' then
call err 'superclass' sup 'is not defined'
if m.o.cla.sup.val ^== '' then
m.o.cla.name.val = m.o.cla.sup.val
if m.o.cla.sup.stem ^== '' then
m.o.cla.name.stem = m.o.cla.sup.stem
st = 'O.CLA.'sup'.MET'
do x=1 to m.st.0
olMe = m.st.x
call oPut neMe, olMe, m.st.olMe
end
st = 'O.CLA.'sup'.FLD'
do x=1 to m.st.0
olFi = m.st.x
call oPut neFi, olFi, m.st.olFi
end
end
call oMutate 'O.CLA.'name, 'Class'
return name
endProcedure oNewClass
oValStemFldsWKOLD: procedure expose m.
parse arg cl, m.o.cla.cl.val, m.o.cla.cl.stem, flds
st = 'O.CLA.'cl'.FLD'
do wx=1 by 2 to words(flds)
call oPut st, word(flds, wx), word(flds, wx+1)
end
return cl
endProcedure oValStemFlds
oNewTypeWKOLD: procedure expose m.
parse arg cl, va, st, flds
return oValStemFlds(oNewClass(cl), va, st, flds)
/*--- a field type has only fields of type '='
finds or creates a field Type with the fields of types tps
and the field list aFl.
if dup = 'e' duplicate field names are resolved ------------*/
oFiTypeWKOLD: procedure expose m.
parse arg tps, aFl, dup
if symbol('m.o.cla.fiType.tps.aFl.dup') = 'VAR' then
return m.o.cla.fiType.tps.aFl.dup
fs = ''
do wx=1 to words(tps)
t1 = oFlds(word(tps, wx))
do fx=1 to m.t1.0
fs = fs m.t1.fx
end
end
fs = fs aFl
fd = ''
do wx=1 to words(fs)
f1 = word(fs, wx)
if wordPos(f1, fd) < 1 then do
fd = fd f1
end
else if dup == 'e' then do
do dx=2 by 1 while wordPos(f1 || dx, fn fs) > 0
end
fd = fd f1 || dx
end
end
fd = space(fd aFl)
if symbol('m.o.cla.fiType.fd') = 'VAR' then do
res = m.o.cla.fiType.fd
end
else do
res = oNewClass("FiType*")
m.o.cla.fiType.fd = res
st = 'O.CLA.'res'.FLD'
do wx=1 to words(fd)
call oPut st, word(fd, wx), '='
end
end
m.o.cla.fiType.tps.aFl = res
return res
endProcedure oFiType
oDecMethods: procedure expose m.
parse arg cla
st = 'O.CLA.'cla'.MET'
do ax=2 to arg()
call oPut st, word(arg(ax), 1), subWord(arg(ax), 2)
end
return
endProcedure oDecMethods
oNew: procedure expose m.
parse arg cla
st = 'O.CLA.'cla
if symbol('M.st') ^== 'VAR' then
call err 'class' cla 'is not initialized'
nn = m.st.inst + 1
m.st.inst = nn
nn = 'O.C' || m.st || 'I' || nn
if symbol('m.o.obj2cla.nn') == 'VAR' then
call err 'oNew already defined:' nn
m.o.obj2cla.nn = cla
return nn
endProcedure oNew
oMutate: procedure expose m.
parse arg obj, class
if obj == 'O.C13I12' then do
end
if symbol('M.O.CLA.class') ^== 'VAR' then
call err 'class' class 'is not initialized'
m.o.obj2cla.obj = class
return obj
endProcedure oMutate
oSay: procedure expose m.
parse arg type, a, aPr, mPr
ty = 'O.CLA.'type
msg = mPr || substr(a, length(aPr)+1)
redir = 0
do forever
if type == '=' then do
say msg '=' m.a
return
end
else if abbrev(type, '=') then do
a = m.a
msg = msg '==>' a
redir = 1
type = substr(type, 2)
end
else if left(type, 2) = '<>' then do
k = m.a
a = left(a, lastPos('.', a))k
msg = msg '=<>' k
redir = 1
type = substr(type, 3)
end
else if left(type, 1) = '.' then do
if ^ datatype(m.a.0, 'n') then
call err 'type' type 'not stem but m.'a'.0 is' m.a.0
type = substr(type, 2)
if redir then do
say msg 'stem 1..'m.a.0':' type
end
else do
do y=1 to m.a.0
call oSay type, a'.'y, a'.', mPr' '
end
end
return
end
else if redir then do
say msg':' type
return
end
else do
leave
end
end
if m.ty.val = '=' then
say msg '=' m.a
else
say msg '=' m.a':' m.ty.val
/* call oSay m.ty.val, a,==>' m.a '(to' m.ty.val')' */
do y=1 to m.ty.fld.0
f = m.ty.fld.y
call oSay m.ty.fld.f , a'.'f, a'.', mPr' '
end
if m.ty.stem ^== '' then
call oSay '.'m.ty.stem, a, a, mPr
return
endProcedure oSay
oClear: procedure expose m.
parse arg type, a, val
if abbrev(type, '.') then do
m.a.0 = 0
end
else if abbrev(type, '<>') then do
m.a = val
call oClear substr(type, 3), left(a, lastPos('.', a))val, val
end
else if abbrev(type, '=') then do
m.a = ''
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.a = val
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oClear m.ty.fld.k, a'.'k, val
end
if m.ty.stem ^== '' then
call m.a.0 = 0
end
return a
endProcedure oClear
oCopy: procedure expose m.
parse arg t, f
if symbol('m.o.obj2cla.f') ^== 'VAR' then
call err f 'has no class'
cl = m.o.obj2cla.f
m.o.obj2cla.t = m.o.obj2cla.f
return oTyCopy(cl, t, f)
endProcedure oCopy
oTyCopy: procedure expose m.
parse arg type, t, f
if abbrev(type, '.') then do
do y=1 to m.f.0
call oTyCopy substr(type, 2), t'.'y, f'.'y
end
m.t.0 = m.f.0
end
else if abbrev(type, '<>') then do
k = m.f
m.t = k
call oTyCopy substr(type, 3), left(t, lastPos('.', t))k,
, left(f, lastPos('.', f))k
end
else if abbrev(type, '=') then do
m.t = m.f
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.t = m.f
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oTyCopy m.ty.fld.k, t'.'k, f'.'k
end
if m.ty.stem ^== '' then
call oTyCopy '.'m.ty.stem, t, f
end
return t
endProcedure oTyCopy
/*--- Run ------------------------------------------------------------*/
oRunner: procedure expose m.
parse arg code
return oRunnerReset(oNew('ORunner'), code)
oRunnerReset: procedure expose m.
parse arg m, pCode
m.m.code = pCode
return m
endProcedure oRunnerReset
oRun: procedure expose m.
parse arg m
interpret m.m.code
return
endProcedure oRun
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call oFldIni
call mapIni
m.o.paTy.0 = 0
call oFldNew '=', '='
call oDecMethods oNewClass('ORunner'), 'oRun call oRun m'
return
endProcedure oIni
/* copy o end *********************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = ''
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
if abbrev(a, 'MAP.') then do
do kx=1 to m.map.loKy.a.0
drop m.map.loKy.a.kx m.map.loVa.a.kx
end
m.map.loKy.a.0 = 0
end
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
if mapValAdr(a, ky) ^== '' then
call err 'duplicate key in mAdd('a',' ky',' val')'
if length(ky) < 200 then do
m.a.ky = val
end
else do
kx = mInc('MAP.LOKY.'a'.0')
m.map.loKy.a.kx = ky
m.map.loVa.a.kx = val
end
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky)
if vv ^== '' then
m.vv = val
else
call mapAdd a, ky, val
return val
endProcedure mapPut
/*--- return the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg a, ky
if length(ky) < 200 then do
if symbol('m.a.ky') == 'VAR' then
return a'.'ky
end
else if ^ abbrev(a, 'MAP.') then do
call err 'key too long mapValAdr('a',' ky')'
end
else do
do kx=1 to m.map.loKy.a.0
if m.map.loKy.a.kx == ky then
return 'MAP.LOVA.'a'.'kx
end
end
return ''
endProcedure mapValAdr
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if abbrev(vv, 'MAP.LOVA.') then
call err 'not implemented mapRemove('a',' ky')'
drop m.a.ky
return val
endProcedure mapRemove
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a,
fail if it does not exist ----------------------------------*/
mapGet: procedure expose m.
parse arg a, ky, noKey
vv = mapValAdr(a, ky)
if vv == '' then
call err 'missing key in mapGet('a',' ky')'
return m.vv
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
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
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
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')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
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))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use -"dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(s005y000) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
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
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/