zOs/REXX/NAKJOB
/* rexx ****************************************************************
nak what fun
***********************************************************************/
parse upper arg what fun
if what = '' then
parse upper value 'tst 1' with what fun
call mIni
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
nPre = 'DSN.'m.task
m.skels = 'A540769.wk.skels'
nLctl = nPre'.LCTL'
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'A540769.TMPNAK.'m.task
end
else if 0 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D035Y000'
m.dPre = 'DSN.'m.task
end
else do /* transfer rz2 --> rz1 */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'SHR21.DIV.P021.'m.task
end
if fun = 9 then do
call testExp
exit
end
m.job.0 = 0
m.jobFlds = 'JOB CR TB DB TS NCR NTB NDB NTS'
call mTypeNew 'StemJob', mTypeNew('Job', '', m.jobFlds)
call adrSqlConnect m.dbSys
if fun = 1 then do
call function1 newCreator, nPre, nLctl
end
else if fun = 2 then do
call unload 'UNL', nLctl'(unload)'
call loadLines m.dPre'.ULI'
call load 'LOA', nLctl'(load)'
end
else
call err 'bad fun' fun
call adrSqlDisConnect m.dbSys
exit
function1: procedure expose m.
parse arg newCreator, nPre, nLctl
call infoDb nLctl'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
call infoTS
if 0 then
call mShow mGetType('StemTS'), ts
if 0 then
do x=1 to m.ts.0
say m.ts.x.db'.'m.ts.x.ts m.ts.x.bp m.ts.x.used
end
call mapReset crNa
call infoTB
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
do x=1 to m.tb.0
n = m.tb.x.tsNd
say m.tb.x.cr'.'m.tb.x.tb m.tb.x.db'.'m.tb.x.ts n '->' m.n
end
call infoDep
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
do x=1 to m.dep.0
say m.dep.x.ty m.dep.x.cr'.'m.dep.x.na,
m.dep.x.bTy m.dep.x.bCr'.'m.dep.x.bNa
end
call infoNeu nLctl'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemDep'), dep
if 0 then
call mShow mGetType('StemNN'), nn
if 1 then
call mShow mGetType('StemJob'), job
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
call showAltNeu nLctl'(info)'
call showJob nLctl'(job)'
if 1 then
call mShow mGetType('StemJob'), job
call alias nLctl'(alia)'
call unload 'ULI', nLctl'(unloLim0)'
call err 'check not yet'
call check 'CHK', nLctl'(check)'
return
endProcedure function0
infoDB: procedure expose m.
parse arg inp
call readDsn inp, c.
dbII = 'in ('
call mapReset(db.a2n)
call mapReset(db.n2a)
call mTypeNew 'StemDB', mTypeNew(db, '', 'ALT NEU')
m.db.0 = 0
do c=1 to c.0
dbAlt = word(c.c, 1)
dbNeu = word(c.c, 2)
dd = mAdd(db, dbAlt'->'dbNeu)
m.dd.alt = dbAlt
m.dd.neu = dbNeu
call mapPut db.a2n, dbAlt, dbNeu
call mapPut db.n2a, dbNeu, dbAlt
if c>1 then
dbII = dbII', '
dbII = dbII"'"dbAlt"'"
end
m.dbIn = dbII')'
say m.db.0 'db' m.dbIn
return
endProcedure infoDB
infoTS: procedure expose m.
root = 'TS'
flds = DB TS NTB PARTS BP USED
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTS', mTypeNew(ts, '', flds)
call mapReset root
end
sqlFlds = sqlFields(flds)
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds)
call mapAdd root, db'.'ts, nd
end
call adrSql 'close c1'
say m.root.0 'tablespaces'
return
endProcedure infoTS
infoTB: procedure expose m.
root = tb
flds = cr tb db ts
xFlds = tsNd newNd
if mDefIfNot(root'.'0, 0) then do
call mTypeNew 'StemTB', mTypeNew(tb, '', flds xflds)
call mapReset root
end
newNd = ''
sqlFlds = sqlFields(flds)
sql = "select creator, name, dbName, tsName",
"from sysibm.systables",
"where dbname" m.dbIn "and type = 'T'"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
ts = strip(ts)
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
if mapHasKey(root, tb) then
say '??? duplicate table' cr'.'tb
else
call mapAdd root, tb, nd
call mapAdd crNa, cr'.'tb, nd
end
call adrSql 'close c1'
say m.root.0 'tables'
return
endProcedure infoTb
stripVars:
parse arg ggList
do ggX=1 to words(ggList)
ggW = word(ggList, ggX)
x=value(ggW, strip(value(ggW)))
end
return
endSubroutine stripVars
infoDep: procedure expose m.
flds = ty cr na bTy bCr bNa
if mDefIfNot(dep'.'0, 0) then
call mTypeNew 'StemDep', mTypeNew('Dep', '', flds 'NEWND ACT')
sqlFlds = sqlFields(flds)
newNd = ''
act = ''
sql = ,
"with o (lev, dType, dCreator, dName, bType, bCreator, bName) as",
"( select 0, t.type, creator, name, '.', '', t.dbName",
"from sysibm.sysTables t",
"where t.dbname" m.dbIn,
"union all select o.lev+1, d.dType, d.dCreator, d.dName,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.sysviewdep d",
"where d.bcreator = o.dCreator and d.bName = o.dName",
"and o.lev < 999999",
"union all select o.lev+1, a.Type, a.creator, a.name,",
"o.dType, o.dCreator, o.dName",
"from o, sysibm.systables a",
"where a.tbCreator = o.dCreator and a.tbName = o.dName",
"and a.type = 'A' and o.lev < 999999",
") select dType, dCreator, dName, bType, bCreator, bName",
"from o"
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if mapHasKey(crNa, cr'.'na) then do
qTy = 'TY'
qBTy = 'BTY'
qbCr = 'BCR'
qbNa = 'BNA'
oo = mapGet(crNa, cr'.'na)
if left(oo, 3) = 'TB.' then do
if ty = 'T' & bTy = '.' & bNa = m.oo.db then
nop /* say 'old table in dep' cr'.'na */
else
call err 'dep with name of old table' ty cr'.'na
end
else if ty ^== m.oo.qTy then
call err 'new dep' m.oo.qTy cr'.'na 'mismatches old' ,
m.oo.qTy m.oo
else if ty == 'A' & ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different alias' cr'.'na ,
'b' bTy bCr'.'bNa ,
'oo' m.oo.qBty m.oo.qBcr'.'m.oo.qBNa
else if 0 then
say 'skipping duplicate' cr'.'na
end
else do
nd = mPutVars(mAdd(dep, cr'.'na), flds 'NEWND' 'ACT')
call mapAdd crNa, cr'.'na, nd
end
end
call adrSql 'close c1'
say m.dep.0 'dependencies'
return
endProcedure oldInfo
infoNeu: procedure expose m.
parse arg ddlNeu
flds = cr na ty for oldNd oldAl
if mDefIfNot(nn.0, 0) then do
call mapReset(nn)
call mTypeNew 'StemNN', mTypeNew('NN', '', flds)
end
oldNd = ''
oldAl = ''
r = jDsn(ddlNeu)
call jOpen r, 'r'
call scanSqlReader s, r
lastX = 0
do forever
if lastX = m.scan.s.lineX then
if ^ scanNl(s, 1) then
leave
lastX = m.scan.s.lineX
if pos('CREATE', translate(m.scan.s.src)) < 1 then
iterate
fnd = 0
do while lastX = m.scan.s.lineX & ^fnd
if scanSql(scanSkip(s)) = '' then
leave
fnd = m.sqlType = 'i' & m.val == 'CREATE'
end
if ^ fnd then do
say 'no create, ignoring line' lastx strip(m.scan.s.src)
iterate
end
if scanSqlId(scanSkip(s)) == '' then do
say 'no sqlId, ignoring line' lastx strip(m.scan.s.src)
iterate
end
subTy = ''
if wordPos(m.val, 'UNIQUE LARGE LOB') > 0 then do
subTy = m.val
plus = ''
if subTy = 'UNIQUE' then
plus = 'WHERE NOT NULL'
do wx=1 by 1
if scanSqlId(scanSkip(s)) == '' then
call scanErr s, 'no sqlId after create' subTy
else if m.val = word(plus, wx) then
subTy = subTy m.val
else if wx=1 | wx > words(plus) then
leave
else
call scanErr s, 'stopped in middle of' plus
end
end
ty = m.val
m.scan.m.sqlBrackets = 0
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'no qualId after create' subTy ty
na = m.val
na1 = m.val.1
na2 = m.val.2
for = '-'
if ty = 'ALIAS' then do
if scanSqlId(scanSkip(s)) ^== 'FOR' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'A'
end
else if ty = 'INDEX' then do
if scanSqlId(scanSkip(s)) ^== 'ON' then
call scanErr s, 'IN expected after create' ty
if scanSqlQuId(scanSkip(s)) == '' then
call scanErr s, 'table name expected after create' ty na
for = m.val
ty = 'X'
end
else if ty = 'TABLE' then do
do while ^ (m.scan.s.sqlBrackets = 0 & m.sqlType = 'i' ,
& m.val == 'IN')
if scanSql(scanSkip(s)) = '' | m.tok == ';' then
call scanErr s, 'in database expected'
end
if scanSqlQuId(scanSkip(s)) == '' | m.val = 'DATABASE' then
call scanErr s, 'ts name expected after create' ty na
for = m.val
ty = 'T'
end
else if ty = 'TABLESPACE' then do
if scanSqlId(scanSkip(s)) ^== 'IN' then
call scanErr s, 'IN expected after create' ty
if scanSqlDeId(scanSkip(s)) == '' then
call scanErr s, 'db name expected after create' ty
na = m.val'.'na
ty = 'S'
end
else if ty = 'VIEW' then do
ty = 'V'
for = ''
end
if 0 then
say 'create' subTy ty 'name' na 'for' for
if for ^== '-' then do
nd = mPut(mAdd(nn, na), flds, na1, na2, ty, for)
call mapAdd nn, na, nd
end
end
call jClose r
return
endProcedure infoNeu
infoRI: procedure expose m.
parse arg ddlNeu
flds = cr tb db bCr bTS bTb bDb bTS rNa
if mDefIfNot(ri.0, 0) then
call mTypeNew 'StemRI', mTypeNew('RI', '', flds)
sql = "select r.creator, r.tbName, td.dbName, td.tsName" ,
", refTbcreator, refTbName, tr.dbName, tr.tsName, relName",
"from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr",
"where r.creator = td.creator and r.tbName = td.name",
"and r.refTbcreator = tr.creator and r.reftbName = tr.name",
"and (td.dbname" m.dbIn "or tr.dbname" m.dbIn")"
/*
select char(td.dbName, 8),
char(strip(r.creator) ||'.'|| strip(r.tbName), 20) "dep",
char(case when td.dbName = tr.dbName then '=' else tr.dbName end
, 8),
char(strip(refTbcreator) ||'.'|| strip(refTbName), 20) "ref par",
char(relName, 30)
from sysibm.sysrels r, sysibm.sysTables td, sysibm.sysTables tr
where r.creator = td.creator and r.tbName = td.name
and r.refTbcreator = tr.creator and r.reftbName = tr.name
and (td.dbname like 'BJAA_0001'
or td.dbname = 'DBJ01' or td.dbname like 'DNF%'
or tr.dbname like 'BJAA_0001'
or tr.dbname = 'DBJ01' or tr.dbname like 'DNF%')
*/
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
do forever
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
nd = mPutVars(mAdd(ri, cr'.'tb'.'rNa), flds)
end
call adrSql 'close c1'
say m.ri.0 'references'
return
endProcedure infoRI
mapAltNeu: procedure expose m.
parse arg newCr
do tx=1 to m.tb.0
cc = tb'.'tx
if ^ mapHasKey(nn, newCr'.'m.cc.tb) then
call err 'old table' m.cc 'has no corr. new'
dd = mapGet(nn, newCr'.'m.cc.tb)
if ^mapHasKey(db.a2n, m.cc.db) then
call err 'old table' m.cc 'ts in bad db' m.cc.db'.'m.cc.ts
if m.dd.oldNd ^== '' then
call err 'old table' m.cc 'maps to new' m.dd ,
'which already maps to' m.dd.oldNd
nTs = m.dd.for
if mapGet(db.a2n, m.cc.db) <> left(nTs, pos('.', nTs)-1) then
call err 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
do dx=1 to m.dep.0
dd = dep'.'dx
if ^ mapHasKey(nn, newCr'.'m.dd.na) then
call err 'old dep' m.dd.ty m.dd 'has no corr. new'
ww = mapGet(nn, newCr'.'m.dd.na)
a = m.dd.ty
if a == 'V' then do
if m.ww.ty ^== 'V' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww
if m.ww.oldNd ^== '' then
call err 'old view' m.dd 'maps to' m.ww.ty m.ww ,
'which is already mapped to' m.ww.oldNd
m.ww.oldNd = dd
m.dd.newNd = ww
end
else if a == 'A' then do
if m.dd.na ^== m.dd.bNa then
call err 'bad old alias' m.dd ,
'for' m.dd.bCr'.'m.dd.bNa
m.ww.oldAl = m.ww.oldAl m.dd
end
else do
call err 'bad dep type' m.dd.ty m.dd
end
end
do nx=1 to m.nn.0
ww = nn'.'nx
if m.ww.ty = 'T' | m.ww.ty = 'V' then do
oo = m.ww.oldNd
if oo == '' then
call err 'no old for new' m.ww.ty m.ww
else if m.oo.cr ^== newCr & m.ww.oldAl = '' then
say '*warn: no old alias for new obj' m.ww.ty m.ww
end
end
bLim = 1E+9
tLim = 30
tbs = 0
bys = 0
jobNo = 1
do tx=1 to m.ts.0
tt = ts'.'tx
if tbs > 0 & (bys + m.tt.used > bLim ,
| tbs + m.tt.nTb > tLim) then do
jobNo = jobNo + 1
bys = 0
tbs = 0
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
m.tt.job = jobNo
end
do ox=1 to m.tb.0
ot = tb'.'ox
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then
os.os = ns
else if wordPos(ns, os.os) < 1 then
os.os = os.os ns
if symbol('ns.ns') ^== 'VAR' then do
ns.ns = os
nt.ns = nt
end
else do
if ns.ns ^== os then
call err 'new TS maps to old' ns.ns 'and' os
if wordPos(nt, nt.ns) < 1 then
nt.ns = nt.ns nt
end
end
do ox=1 to m.ts.0
os = ts'.'ox
do nx=1 to words(os.os)
ns = word(os.os, nx)
do ny=1 to words(nt.ns)
nt = word(nt.ns, ny)
ot = m.nt.oldNd
say 'old' m.ot.cr m.ot.tb m.os.db m.os.ts ,
'new' m.nt.cr m.nt.na ns
nq = pos('.', ns)
call mPut mAdd(job, m.ot), m.jobFlds, m.os.job,
, m.ot.cr, m.ot.tb, m.os.db, m.os.ts,
, m.nt.cr, m.nt.na, left(ns,nq-1), substr(ns,nq+1)
end
end
end
return
endProcedure mapAltNeu
showAltNeu: procedure expose m.
parse arg out
m.o.0 = 0
do dx=1 to m.db.0
dd = db'.'dx
call mAdd o, 'mD' left(m.dd.alt, 20)left(m.dd.neu, 20)
end
do tx=1 to m.tb.0
tt = tb'.'tx
ss = m.tt.tsNd
l = 'oT' left(m.tt, 20)left(m.ss, 20) ,
|| right(m.ss.job, 4) m.ss.used,
|| right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do tx=1 to m.tb.0
tt = tb'.'tx
ww = m.tt.newNd
l = 'mt' left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
if m.dd.ty == 'V' then
l = 'mV' left(m.dd, 20)left(m.ww, 20)
else if m.dd.ty == 'A' then
l = 'dA' left(m.dd, 20)left(m.dd.bCr'.'m.dd.bNa, 20)
else
call err 'bad ty in dep' m.dd.ty m.dd
call mAdd o, l
end
do rx=1 to m.ri.0
rr = ri'.'rx
if ^mapHasKey(db.a2n, m.rr.db) ,
| ^mapHasKey(db.a2n, m.rr.bDb) then
q = '|f'
else if m.rr.db <> m.rr.bDb then
q = '|d'
else
q = '= '
call mAdd o, 'mR' left(m.rr.cr'.'m.rr.tb, 20) ,
|| left(m.rr.bCr'.'m.rr.bTb, 20) q m.rr.rNa
end
call writeDsn out, m.o., ,1
return
endProcedure showAltNeu
showJob: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.job.0
jj = 'JOB.'jx
call mAdd o, right(m.jj.job, 4) ,
left(m.jj, 20) left(m.jj.db'.'m.jj.ts, 17) ,
left(m.jj.nCr, 10) left(m.jj.nDb'.'m.jj.nTs, 17)
end
call writeDsn out, m.o., ,1
call loadJob out
return
endProcedure showAltNeu
loadJob: procedure expose m.
parse arg inp
call readDsn inp, i.
do i=1 to i.0
parse var i.i job cr '.' tb db '.' ts nCr nDb '.' nTs .
call stripVars 'CR DB NDB'
nTb = tb
say job cr'.'tb db'.'ts 'old' nCr'.'tb nDb'.'nTs
call mPutVars mAdd('JOB', cr'.'db), m.jobFlds
end
return
endProcedure loadJob
alias: procedure expose m.
parse arg out
m.dr.0 = 0
m.cr.0 = 0
c = 0
call sqlId cr, dr
do dx=1 to m.dep.0
dd = dep'.'dx
if m.dd.ty ^== 'A' then
iterate
c = c + 1;
if c // 50 = 0 then
call commit cr, dr
call mAdd dr, 'DROP ALIAS' m.dd';'
call mAdd cr, 'CREATE ALIAS' m.dd 'FOR' m.dd.bCr'.'m.dd.bNa';'
end
call commit cr, dr
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'CREA'), m.cr., ,1
call writeDsn dsnSetMbr(out, dsnGetMbr(out) || 'DROP'), m.dr., ,1
return
endProcedure alias
commit: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), 'COMMIT;'
end
return
endProcedure commit
sqlId: procedure expose m.
do ax=1 to arg()
call mAdd arg(ax), "SET CURRENT SQLID = 'S100447';"
end
return
endProcedure sqlId
unload: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.'fun
do sx=1 to m.ts.0
ss = ts'.'sx
if jj <> m.ss.job then do
jj = m.ss.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TS', m.ss
if m.ss.parts = 0 then
call envPut 'PARTONE', ''
else
call envPut 'PARTONE', 'PART 1'
call envExpAll o, skTS
do tx=1 to m.tb.0
tt = tb'.'tx
if m.tt.tsNd ^== ss then
iterate
call envPut 'TB', m.tt.cr'.'m.tt.tb
call envExpAll o, skTb
say 'job' jj 'ts' m.ss 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure unload
loadLines: procedure expose m.
parse arg punPre
do sx=1 to m.ts.0
ss = ts'.'sx
pun = punPre'.'m.ss.ts'.PUN'
call readDsn pun, p.
wh = ''
tbCnt = 0
do p=1 to p.0
w1 = word(p.p, 1)
if w1 = 'LOAD' then do
wh = 'l'
end
else if w1 = 'INTO' then do
wh = 'i'
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
dx = pos('.', w3)
if dx < 1 then
call err '. expected in w3 line' p 'in' pun':' p.p
crTb = strip(left(w3, dx-1), 'b', '"')'.',
||strip(substr(w3, dx+1), 'b', '"')
if ^ mapHasKey(crNa, crTb) then
call err 'old table' crTb 'not found' ,
'for punchLine' p 'in' pun':' p.p
tt = mapGet(crNa, crTb)
if m.tt.tsNd ^== ss then
call err 'old table' crTb ,
'wrong ts' m.tt.db'.'m.tt.ts,
'for punchLine' p 'in' pun':' p.p
if ^mDefIfNot(tt'.LO.0', 0) then
call err 'already loaded table' crTb ,
'for punchLine' p 'in' pun':' p.p
tbCnt = tbCnt + 1
end
else if w1 = ')' then do
if strip(p.p) <> ')' then
call err 'bad ) line' p 'in' pun':' p.p
if wh <> 'i' then
call err ') in state' wh 'line' p 'in' pun':' p.p
call mAdd tt'.LO', p.p
wh = ''
end
else if wh == 'i' then do
call mAdd tt'.LO', p.p
end
else if wh == 'l' then do
if w1 ^== 'EBCDIC' then
call err 'bad line after load' ,
'in punchLine' p 'in' pun':' p.p
end
end
if wh ^== '' then
call err 'punch' pun 'ends in state' wh
if tbCnt <> m.ss.nTb then
call err tbCnt 'tables not' m.ss.nTb 'loaded for' m.ss
say 'loadCards for' tbCnt 'tables for' m.ss
end
return
endProcedure loadLines
load: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skSt.
call readDsn m.skels'(nak'fun'TS)', m.skTs.
call readDsn m.skels'(nak'fun'Tb)', m.skTb.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'DSNPRE', m.dPre'.UNL'
do nx=1 to m.newTs.0
ns = newTs'.'nx
if jj <> m.ns.job then do
jj = m.ns.job
call envPut 'JOBNAME', 'Y' || m.tas3 || fun || jj
call envExpAll o, jc
call envExpAll o, skSt
end
call envPut 'TREC', TREC || nx
call envPut 'TS', m.ns
tt = word(m.ns.tbNds, 1)
oo = m.tt.oldNd
call envPut 'OLDTS', m.oo.ts
call envExpAll o, skTS
do tx=1 to words(m.ns.tbNds)
tt = word(m.ns.tbNds, tx)
call envPut 'TB', m.tt
call envExpAll o, skTb
call mAddSt o, m.tt.oldNd'.LO'
say 'job' jj 'ts' m.ns 'tb' m.tt
end
end
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakChKSt)', m.skut.
call readDsn m.skels'(nakChKTb)', m.sktb.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPut 'JOBNAME', 'Y' || m.tas3 || 'CHK' || jj
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skCh
do rx=1 to m.ri.0
rr = 'RI.'rx
dbTs = m.rr.db'.'m.rr.ts
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTb
end
call writeDsn out, m.o., ,1
return
endProcedure check
err:
call errA arg(1), 1
endSubroutine err
envPut: procedure expose m.
parse arg na, va
call mapPut m.vars, na, va
return
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return mapHasKey(m.vars, na)
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(m.vars, na)
endProcedure envGet
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
endProcedure envRemove
envExpand: procedure expose m.
parse arg src
cx = pos('$', src)
if cx < 1 then
return strip(src, 't')
res = left(src, cx-1)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || envGet(substr(src, cx+2, ex-cx-2))
ex = ex + 1
end
else do
ex = verify(src, 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_',
|| 'abcdefghijklmnopqrstuvwxyz', 'n', cx+1)
if ex < 1 then
return strip(res || envGet(substr(src, cx+1)), 't')
res = res || envGet(substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return strip(res || substr(src, ex), 't')
res = res || substr(src, ex, cx-ex)
end
endProcedure envExpand
envExpAll: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx+1
m.dst.dx = envExpand(m.src.sx)
end
m.dst.0 = dx
return
endProcedure envExpAll
testExp: procedure
call mIni
m.xx.0 = 0
call envPut 'v1', eins
call envPut 'v2', zwei
call testExp1 'ohne variabeln'
call testExp1 '$v1 variabeln'
call testExp1 'mit $v1 iabeln'
call testExp1 'mit variab$v1'
call testExp1 '${v2}variabeln'
call testExp1 'mit vari${v1}'
call testExp1 'mit v${v2}eln'
call testExp1 'mit v${v1}eln'
call testExp1 'mit $v1 viel${v2}+$v1-vars${v2}'
call envExpAll mCut(yy, 0), xx
do x=1 to m.yy.0
say 'tesStem exp' m.yy.x'|'
end
return
endProcedure testExp
testExp1: procedure expose m.
parse arg src
call mAdd xx, src
say 'testExp src' src'|'
say 'testExp exp' envExpand(src)'|'
return
endProcedure testExp1
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlReader
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd
call adrEdit "cursor =" lx
do while adrEdit("seek" cmd 'word', 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx
call editReadDefine m, fx
call scanSqlReader m, m
do while m.m.editReadLx <= fx
if scanSql(scanSkip(m)) = '' then
return -1
if m.sqlType = 'i' & m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
ePos: procedure expose m.
parse arg m
return m.m.editReadLx m.scan.m.pos
endProcedure ePos
/*--- scan a sql token put type in m.sqltype:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': quantified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234
"'": string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSql: procedure expose m.
parse arg m
if scanAtEnd(m) then do
m.sqlType = ''
m.val = ''
end
else if scanString(m, "'") then
m.sqlType = "'"
else if scanSqlQuId(m) ^== '' then
nop
else if scanSqlNumUnit(m, 1) ^== '' then
nop
else if scanChar(m, 1) then do
m.sqlType = m.tok
m.val = ''
if m.tok = '(' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets + 1
else if m.tok = ')' then
m.scan.m.sqlBrackets = m.scan.m.sqlBrackets - 1
end
else
call scanErr m, 'cannot scan sql'
return m.sqlType
endProcedure scanSql
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ----------------*/
scanSqlId: procedure expose m.
parse arg m
if ^ scanName(m) then
return ''
m.val = translate(m.tok)
m.sqlType = 'i'
return m.val
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier ---------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) == '' then do
if scanString(m, '"') then do
val = strip(val, 't')
m.sqlType = 'd'
end
end
return m.val
endProcedure scansqlDeId
/*--- scan a qualified sql identifier --------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m
if scanSqlDeId(m) == '' then
return ''
res = ''
do qx=1 by 1
m.val.qx = m.val
res = res'.'m.val
if ^ scanLit(scanSkip(m), '.') then do
m.val.0 = qx
if qx > 1 then
m.sqlType = 'q'
m.val = substr(res, 2)
return m.val
end
if scansqlDeId(scanSkip(m)) == '' then
call scanErr m, 'id expected after .'
end
endProcedure scanSqlQuId
/*--- scan a sql number ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd
c3 = left(scanLook(m, 3), 3)
p = left(c3, 1) == '+' | left(c3, 1) == '-'
p = p + (substr(c3, p + 1, 1) == '.')
if pos(substr(c3, p+1, 1), '0123456789') < 1 then
return ''
n = ''
if p > 0 & left(c3, 1) ^== '.' then do
call scanChar m, 1
n = m.tok
end
if scanVerify(m, '0123456789') then
n = n || m.tok
if scanLit(m, '.') then do
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.tok
end
c3 = left(translate(scanLook(m, 3)), 3)
if left(c3, 1) == 'E' then do
p = substr(c3, 2, 1) == '+' | substr(c3, 2, 1) == '-'
if pos(substr(c3, p+2, 1), '0123456789') > 0 then do
call scanChar m, p+1
n = n || m.tok
if scanVerify(m, '0123456789') then
n = n || m.tok
c3 = scanLook(m, 1)
end
end
if checkEnd ^= 0 then
if pos(left(c3, 1), m.scan.m.name) > 0 then
call scanErr m, 'end of number' n 'expected'
m.val = n
return n
endProcedure scanSqlNum
/*--- scan a sql number with unit K M or G ---------------------------*/
scanSqlNumUnit: procedure expose m.
parse arg m, both
nu = scanSqlNum(m, 0)
if nu = '' then
return ''
sp = scanSpaceNl(m)
af = translate(scanSqlId(m))
if wordPos(af, "K M G") > 0 then do
m.sqlType = 'u'
m.val = nu || af
return m.val
end
else if af <> '' & ^ sp then
call scanErr m, 'end of number' nu 'expected'
if both ^== 1 then
call scanErr m, 'unit K M or G expected'
else if af ^== '' then
call scanBack m, m.tok
m.sqlType = 'n'
m.val = nu
return nu
endProcedure scanSqlNumUnit
scanSqlskipBrackets: procedure expose m.
parse arg m, br
call scanSpaceNl m
if br ^== '' then
nop
else if ^ scanLit(m, '(') then
return 0
else
br = 1
do forever
t = scanSql(scanSpaceNl(m))
if t = '' | t = ';' then
call scanErr m, 'closing )'
else if t = '(' then
br = br + 1
else if t ^== ')' then
nop
else if br > 1 then
br = br - 1
else if br = 1 then
return 1
else
call scanErr m, 'skipBrackets bad br' br
end
endProcedure skipBrackets
/* copy scanSql end *************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(m,ln): begin scanning all lines of an opened reader
scanAtEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
returns: true if scanned, false otherwise
m.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
if symbol('m.scan.m.name') ^== 'VAR' then
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, m.scan.m.comment
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanInit m
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
endProcedure scanName
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes -------*/
scanWord: procedure expose m.
parse arg m, stopper
if scanString(m, "'") then return 1
if scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
interpret 'say " "' m.scan.m.scanLinePos
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' & abbrev(substr( ,
m.scan.m.src, m.scan.m.pos), m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
if m.j.jIni ^== 1 then
call jIni
return 'J.'mInc(j)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
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.
parse arg force
if m.j.jIni == 1 & force ^== 1 then
return
m.j.jIni = 1
m.j.0 = 0
m.j.defDD.0 = 0
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jIni
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
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: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mInc('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy adrSql begin *************************************************/
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then do
return 0
end
else if rc < 0 then do
if ggRet == '*' then nop
else if wordPos(sqlCode, ggRet) > 0 then nop
else
call err "sql rc" rc sqlmsg() ggNo
end
else if sqlWarn.0 ^== ' ' then do
say 'warning' sqlMsg() ggNo
end
return sqlCode
endSubroutine adrSql
adrSqlConnect: procedure
parse arg ggSys, ggRetCon
if adrTSO("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" ggSys, ggRetCon ,1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
sqlFields: procedure
parse arg flds
sql = ''
do wx=1 to words(flds)
sql = sql', :'word(flds, wx)
end
if wx > 1 then
sql = substr(sql, 3)
return sql
endProcedure sqlFields
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
ggXX = pos(':', ggSqlStmt)
ggVV = ''
if ggXX > 0 then do
ggVV = word(substr(ggSqlStmt, ggXX + 1), 1)
ggXX = verify(ggVV, ' ,:+-*/&%?|', 'm')
if ggXX > 0 then
ggVV = left(ggVV, ggXX-1)
ggVV = 'with' ggVV '=' value(ggVV)
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x)) ,
'stmt = ' ggSqlStmt ggVV
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 = adrTso('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
/* copy adrSql 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
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
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
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
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
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
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
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
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
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))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
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 ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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
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 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy m begin ********************************************************
stem and type handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a.0 = m.a.0 + 1
return m.a.0
endProcedure mInc
mDefIfNot: procedure expose m.
parse arg a, put
if symbol('m.a') == 'VAR' then
return 0
m.a = put
return 1
endProcedure mDefIfNot
/*--- 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
/*--- put into stem a the fields flds from arguments -----------------*/
mPut: procedure expose m.
parse arg a, flds
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = arg(wx+2)
end
return a
endProcedure mPut
/*--- put into stem a the fields flds from stem b --------------------*/
mPutSt: procedure expose m.
parse arg a, flds, b
do wx = 1 to words(flds)
f = word(flds, wx)
m.a.f = m.b.f
end
return a
endProcedure mPutSt
/*--- put into stem a the fields flds from variable pool -------------*/
mPutVars:
parse arg ggA, ggFlds
do ggWx = 1 to words(ggFlds)
ggF = word(ggFlds, ggWx)
m.ggA.ggF = value(ggF)
end
return ggA
endProcedure mPutVars
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
if m.m.mIni ^== 1 then
call mIni
return mapReset(mAdd(m.map, 'map'))
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.a.mapKey') == 'VAR' then
call mapClear a
m.a.mapKey = translate(opt) = 'K'
if m.a.mapKey then
m.a.mapKey.0 = 0
else
m.a.mapKey.0 = 'noMapKeys'
return a
endProcedure
mapClear: procedure expose m.
parse arg a
do kx=1 to m.a.mapKey.0
k = m.a.mapKey.kx
drop m.a.mapK2V.k m.a.mapKey.kx
end
m.a.mapKey.0 = 0
return a
endProcedure mapClear
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.mapK2V.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.mapK2V.ky = val
if m.a.mapKey then
call mAdd a.mapKey, ky
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg m, ky, val
if m.m.mapKey then
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call mAdd m.mapKey, ky
m.m.mapK2V.ky = val
return
endProcedure mapPut
mapHasKey: procedure expose m.
parse arg m, ky
return symbol('m.m.mapK2V.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg m, ky
if symbol('m.m.mapK2V.ky') ^== 'VAR' then
call err 'missing key in mapGet('m',' ky')'
return m.m.mapK2V.ky
endProcedure mapGet
mapGetOr: procedure expose m.
parse arg m, ky, orDef
if symbol('m.m.mapK2V.ky') == 'VAR' then
return m.m.mapK2V.ky
else
return orDef
endProcedure mapGetOr
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mGetType:
parse arg name
return mapGet(m.type, name)
endProcedure mGetType
mTypeNew: procedure expose m.
parse arg name, stem, flds, types
if m.m.ini ^== 1 then
call mIni
ty = mAdd(m.type, name)
call mapAdd m.type, name, ty
m.ty.ass = '='
m.ty.type = stem
m.ty.0 = words(flds)
m.ty.type.0 = m.ty.0
do y=1 to m.ty.0
m.ty.y = word(flds, y)
if word(types, y) = '' then
m.ty.type.y = m.type.1
else
m.ty.type.y = word(types, y)
end
return ty
endProcedure mTypeNew
mShow: procedure expose m.
parse arg ty, a, lv
if lv='' then
lv = 0
pr = a
if lv > 0 & lastPos('.', pr) > 0 then
pr = substr(pr, lastPos('.', pr))
say left('', lv)pr '=' m.a
do y=1 to m.ty.0
call mShow m.ty.type.y, a'.'m.ty.y, lv+1
end
if m.ty.type ^== '' then do
do y=1 to m.a.0
call mShow m.ty.type, a'.'y, lv+1
end
end
return
endProcedure mShow
mClear: procedure expose m.
parse arg ty, a, val
m.a = val
do y=1 to m.ty.0
call mClear m.ty.type.y, a'.'m.ty.y
end
if m.ty.type ^== '' then
m.a.0 = 0
return
endProcedure mClear
mTypeSay: procedure expose m.
parse arg t
say 'type' t'='m.t 'ass' m.t.ass '#' m.t.0 'tys' m.t.type
return
endProcedure mInit
mTypeCopy: procedure expose m.
parse arg ty, t, f
if m.ty.ass == '=' then
m.t = m.f
else
call err 'type.ass' m.ty.ass 'not supported'
do x = 1 to m.ty.0
fld = m.ty.x
call mTypeCopy m.ty.type.x, t'.'fld, f'.'fld
end
if m.ty.type ^== '' then do
do y = 1 to m.f.0
call mTypeCopy m.ty.type, t'.'y, f'.'y
end
m.t.0 = m.f.0
end
return t
endProcedure mTypeCopy
mIni: procedure expose m.
m.m.ini = 1
m.m.type.0 = 0
m.m.map.0 = 0
call mapReset m.type
call mapReset m.vars
siTy = mTypeNew('Simple')
stTy = mTypeNew('Stem', siTy)
tyTy = mTypeNew('Type', siTy, 'ASS TYS', siTy stTy)
ttTy = mTypeNew('StemType', tyTy)
return
endProcedure mIni
mTest: procedure
call mIni
siTy = mGetType('Simple')
tyTy = mGetType('Type')
ttTy = mGetType('StemType')
say 'siTy' siTy 'tyTy' tyTy 'stTyTy' ttTy
call mTypeSay siTy
call mTypeCopy siTy, nnn, siTy'.'ass
say 'm.nnn nach copy' m.nnn
call mTypeCopy tyTy, mmm, siTy
call mTypeSay mmm
call mTypeCopy tyTy, qqq, tyTy
call mTypeSay qqq
call mShow tyTy, qqq
call mShow ttTy, m.type
return
endProcedure mTest
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
call errA arg(1), 1
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt, ggHist
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
if ggHist ^== 1 then
exit setRc(12)
say 'divide by zero to show stack history'
x = 1 / 0
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggMsg
call help
call err ggMsg
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
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- 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
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
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
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 *****************************************************/