zOs/REXX/NAK
/* rexx ****************************************************************
nak what fun list
fun
a allocate libraries
u create unloadLimit0 and info alt neu
i create rebind and free
l create unload load
c copy alt und transform neu lctl, listdef etc.
k copy alt lctl, listdef etc.
r check packages and create remaining rebinds
.2 list: s = show flags, = = ignore packages as bad as befo
d check unload Datasets
drop
***********************************************************************/
parse upper arg what fun list
/* fix for partial db: select ts and tb */
m.wb = 1
m.wbTs = "'A142A'," ,
"'A163A'," ,
"'A165A'," ,
"'A166A'," ,
"'A169A'," ,
"'A170A'," ,
"'A172A'," ,
"'A173A'," ,
"'A703A'," ,
"'A704A'," ,
"'A705A'," ,
"'A706A'," ,
"'A707A'," ,
"'A708A'," ,
"'A992A'," ,
"'A999A'"
m.wbTb = "'TWB142A1',",
"'TWB163A1',",
"'TWB165A1',",
"'TWB166A1',",
"'TWB169A1',",
"'TWB170A1',",
"'TWB172A1',",
"'TWB173A1',",
"'TWB703A1',",
"'TWB704A1',",
"'TWB705A1',",
"'TWB706A1',",
"'TWB707A1',",
"'TWB708A1',",
"'TWB992',",
"'TWB999A1'"
if what = '' then
parse upper value 'tst u' with what fun
call mIni
m.warn.0 = 0
if userid() = 'A540769' then
m.skels = 'A540769.wk.skels'
else
m.skels = 'ORG.U0009.B0106.KIUT23.SKELS'
m.limit = 1E11
if fun = 'DROP' then do
if substr(what, 5, 1) ^== '.' then
call err "what = 'dbSu.pref' expected not" what 'for drop'
m.dbSys = left(what, 4)
what = substr(what, 6)
m.dPre = 'DSN.DROP.'m.dbSys
call envPut 'MGMTCLAS', 'A008Y000'
m.tas3 = left(what, 2)right(what, 1)
end
else do
m.tas3 = left(what, 2)right(what, 1)
m.task = 'NAK'what
if sysvar('SYSNODE') = 'RZ1' then do
m.dbSys = 'DBAF'
newCreator = 'TSTNAKNE'
call envPut 'MGMTCLAS', 'D008Y000'
m.dPre = 'A540769.TMPNAK.'m.task
m.dPre = 'DSN.'m.task
end
else if 1 then do /* rz2 proc */
m.dbSys = 'DBOF'
newCreator = 'OA1P'
call envPut 'MGMTCLAS', 'A008Y005'
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
end
nGen = m.dPre'.JCL'
if fun = 'A' then do
if list = '' then
list = '*'
cx = pos('*', list)
if cx > 0 then
list = left(list, cx-1) 'JCL LIST CALT.LCTL CNEU.LCTL' ,
'CALT.LISTDEF CNEU.LISTDEF' substr(list, cx+1)
call allocList m.dPre, list
exit
end
call adrSqlConnect m.dbSys
if fun = 'R' then do
call restartRebind list, nGen"(info)", nGen"(rebinRst)"
exit
end
if fun = 'D' then do
call checkUnloadDS nGen"(info)", m.dPre'.UNL'
exit
end
if fun = 'DROP' then do
call infoDb nGen'('what'DB)'
call infoAlt 'STDKR'
call createJb
call showAlt nGen'('what'info)'
call showSyscopy nGen'('what'SyCo)'
call alias nGen'('what'al)'
call rebind nGen'('what'rebi)', 'REBIND', 'T'
call rebind nGen'('what'free)', 'FREE', ''
call dropAlt nGen'('what'Drop)', 1
call utilList 'PDR', nGen'('what'UPDR)', 1
exit
end
if fun = 'TT' then do
call infoDb nGen'(DB)'
call transformTest
exit
end
else if fun = 'TE' then do
call testExp
exit
end
else if fun = '' | verify(fun, 'IULCKQS') > 0 then
call err 'bad fun "'fun'"'
m.igno.0 = 0
call infoDb nGen'(DB)'
if 0 then
call mShow mGetType('StemDB'), db
aOpt = 'ST'
if verify(fun, 'IU', 'm') > 0 then
aOpt = aOpt'DKR'
else if verify(fun, 'LC', 'm') > 0 then
aOpt = aOpt'D'
call infoAlt aOpt
if verify(fun, 'CUL', 'm') > 0 then do
call infoNeu nGen'(ddlNeu)'
if 0 then
call mShow mGetType('StemNN'), nn
call mapAltNeu newCreator, (verify(fun, 'U', 'm') > 0)
if 0 then
call mShow mGetType('StemTB'), tb
if 0 then
call mShow mGetType('StemNN'), nn
if 0 then
call mShow mGetType('StemJob'), jb
if 1 then
call mShow mGetType('Stem'), igno
end
else do
call createJb
if 0 then
call mShow mGetType('StemJob'), jb
end
if verify(fun, 'IU', 'm') > 0 then do
call showAlt nGen'(info)'
call showSyscopy nGen'(infoSyCo)'
call alias nGen'(alia)'
call utilList 'PDR', nGen'(utilPDR)', 1
call utilList 'COP', nGen'(copyAlt)', 1
call dropAlt nGen'(dbDropAl)'
call count nGen'(CNALT)', 1, m.limit
end
if pos('I', fun) > 0 then do
call rebind nGen'(rebind)', 'REBIND', 'T'
call rebind nGen'(freePkg)', 'FREE', ''
end
if pos('U', fun) > 0 then do
call showNeu nGen'(infoMap)'
call unload 'ULI', nGen'(unloLim0)'
call check 'CHK', nGen'(check)'
call rebind nGen'(rebind)', 'REBIND', 'TOQ'
call utilList 'COP', nGen'(copyNeu)', 0
call count nGen'(cnNeu)', 0, m.limit
end
if pos('L', fun) > 0 then do
call unload 'UNL', nGen'(unload)'
call unload 'UNL', nGen'(unloaSAV)', 'SAV'
call loadLines m.dPre'.ULI'
call load 'LOA', nGen'(load)'
end
sMbrs = 'LCTL LISTDEF PCL DBSP BOLIAL BOLIBS BOLICI',
'BOLICR BOLIPH BOLIPI BOLIRZ BOLIUE BOLIVI BOLIW7 BOLIW8'
if pos('Q', fun) > 0 then do
call ctlTransQQ
end
else if pos('C', fun) > 0 then do
call ctlSearch 'C', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('K', fun) > 0 then do
call ctlSearch 'K', nGen'(infoCTL)', m.dPre'.LIST', sMbrs, m.dPre
end
if pos('S', fun) > 0 then do
call count nGen'(CNALT)', 1, m.limit
end
call adrSqlDisConnect m.dbSys
call warnWrite m.dPre'.JCL'
exit
infoAlt: procedure expose m.
parse arg opt
if pos('S', opt) > 0 then do
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
end
if pos('T', opt) > 0 then do
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
end
if pos('D', opt) > 0 then do
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
end
if 0 then
call mShow mGetType('Stem'), igno
if pos('K', opt) > 0 then do
call infoPackage
if 0 then
call mShow mGetType('StemPK'), pk
end
if pos('R', opt) > 0 then do
call infoRI
if 0 then
call mShow mGetType('StemRI'), ri
end
return
endProcedure infoAlt
infoDB: procedure expose m.
parse arg inp
call mapReset ii, 'K'
call readDsn inp, c.
dbII = 'in ('
dbNN = 'in ('
con = ''
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)
if left(dbAlt, 1) <> '-' then do
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
dbII = dbII || con || "'"dbAlt"'"
dbNN = dbNN || con || "'"dbNeu"'"
con = ', '
end
else do
call mapAdd ii, translate(dbNeu), dbNeu
end
end
m.dbIn = dbII')'
m.dbInNeu = dbNN')'
say m.db.0 'alte DB' m.dbIn', neue' m.dbInNeu
call mShow mGetType('Stem'), mapKeys(ii)
return
endProcedure infoDB
isIgnored: procedure expose m.
parse upper arg ty, qu, na
if pos(ty, 'VTA') > 0 then do
if mapHasKey(ii, 'C.'qu) then
return 1
end
if mapHasKey(ii, ty'.'qu'.'na) then
return 1
return 0
endProcedure isIgnored
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 'TBSQ')
call mapReset root
end
sqlFlds = sqlFields(flds)
if m.wb then
pp = "and name in ("m.wbTs")"
else
pp = ""
sql = "select dbName, name, nTables, partitions," ,
"bPool, float(nActive)*pgSize*1024" ,
"from sysibm.systablespace",
"where dbname" m.dbIn pp ,
"order by 1, 2 "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
tbSQ = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars flds
if isIgnored('S', db, ts) then do
call mAdd igno, 'alt S' db'.'ts
iterate
end
used = format(used,2,3,2,0)
nd = mPutVars(mAdd(root, db'.'ts), flds 'TBSQ')
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'"
if m.wb then
sql = sql "and name in ("m.wbTb")"
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 isIgnored('T', cr, tb) then do
call mAdd igno, 'alt T' cr'.'tb 'in' db'.'ts
iterate
end
tsNd = mapGet('TS', db'.'ts)
nd = mPutVars(mAdd(root, cr'.'tb), flds xFlds)
m.tsNd.tbSq = m.tsNd.tbSq nd
if mapHasKey(root, tb) then
call err '??? 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 = ''
if m.wb then
call envPut 'DBIN', m.dbin "and name in ("m.wbTb")"
else
call envPut 'DBIN', m.dbin
sql = skel2sql('nakDep')
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 isIgnored(ty, cr, na) then do
call mAdd igno, 'alt dep' ty cr'.'na 'from' bTy bCr'.'bNa
end
else 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'| ty == 'Y') ,
& ^ (bTy == m.oo.qBty & bCr == m.oo.qBcr ,
& bNa == m.oo.qBNa) then
call err 'dep with duplicate different al/sy' 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 infoDep
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 scanReader scanSqlIni(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
linePos = scanLinePos(s)
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' linePos
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.s.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
end
else if isIgnored(ty, na1, na2) then do
call mAdd igno, 'neu ' ty na 'for' for
end
else 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.
flds = cr tb db ts bCr 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"
sql = sql "and td.dbname" m.dbIn ,
'union' sql "and tr.dbname" m.dbIn
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
infoPackage: procedure expose m.
flds = timeStamp pcTimestamp type,
validate isolation valid operative owner qualifier
fldStr = collid Name version flds
flds = collid Name version conToken flds
if mDefIfNot(pk.0, 0) then do
call mTypeNew 'StemPK', mTypeNew('PK', '', flds 'ACT')
call mapReset pkMap
end
call envPut 'DBIN', m.dbIn
sql = skel2sql('nakPckg')
sqlFlds = sqlFields(flds)
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cVa = 0
cOp = 0
act = ''
do c=1 by 1
call adrSql 'fetch c1 into' sqlFlds
if sqlCode = 100 then
leave
call stripVars fldStr
nd = mPutVars(mAdd('PK', collid'.'name), flds 'ACT')
call mapAdd pkMap, collid'.'name'.'conToken, nd
if valid = 'Y' then
cVa = cVa + 1
if operative = 'Y' then
cOp = cOp + 1
end
call adrSql 'close c1'
say (c-1) 'packages,' cVa 'valid,' cOp 'operative'
return
endProcedure infoPackage
showSyscopy: procedure expose m.
parse arg out
m.o.0 = 0
call envPut 'DBIN', m.dbIn
sql = skel2Sql('nakSysCo')
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 :job, :ty, :cnt, :tst'
if sqlCode = 100 then
leave
call mAdd o, left(job, 8) left(ty, 1) right(cnt, 9) tst
end
call adrSql 'close c1'
call writeDsn out, m.o., , 1
return
endProcedure showSyscopy
skel2Sql: procedure expose m.
parse arg skel
call readDsn m.skels'('skel')', m.skel2Sql.i.
call leftSt skel2Sql.i, 72
m.skel2Sql.o.0 = 0
call envExpAll skel2Sql.o, skel2Sql.i
return catStripSt(skel2Sql.o)
endProcedure skel2Sql
catStripSt: procedure expose m.
parse arg m
r = ''
mid = ''
do x=1 to m.m.0
r = r || mid || strip(m.m.x)
mid = ' '
end
return r
endProcedure catStripSt
leftSt: procedure expose m.
parse arg m, le
do x=1 to m.m.0
m.m.x = left(m.m.x, 72)
end
return m
endProcedure leftSt
mapAltNeu: procedure expose m.
parse arg newCr, doQ
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 wkTst????
*/ say 'new table' m.dd 'in wrong db' nTs
m.cc.newNd = dd
m.dd.oldNd = cc
end
qDep = ''
do dx=1 to m.dep.0
dd = dep'.'dx
a = m.dd.ty
if ^ mapHasKey(nn, newCr'.'m.dd.na) then do
if a <> 'A' & a <> 'Y' then
call err 'old dep' a m.dd 'has no corr. new'
m.dd.act = 'q'
qDep = qDep "or (bQualifier = '"m.dd.cr"'" ,
"and bName = '"m.dd.na"')"
iterate
end
ww = mapGet(nn, newCr'.'m.dd.na)
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' | a == 'Y') 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
call warn 'no old alias for new obj' m.ww.ty m.ww
end
end
do otX=1 to m.tb.0
ot = 'TB.'otX
os = m.ot.tsNd
osNa = m.os
nt = m.ot.newNd
ns = m.nt.for
if symbol('os.os') ^== 'VAR' then do
os.os = ns
m.oldTs.osNa = ns
end
else if wordPos(ns, os.os) < 1 then do
os.os = os.os ns
m.oldTs.osNa = os.os
end
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 tx=1 to m.ts.0
tt = ts'.'tx
newSq = ''
do nsX=1 to words(os.tt)
ns = word(os.tt, nsX)
do ntx=1 to words(nt.ns)
nt = word(nt.ns, ntX)
newSq = newSq m.nt.oldNd
end
end
/* say 'ts' m.tt 'seq' m.tt.tbSq '-->' newSq */
m.tt.tbSq = newSq
end
call createJb
if doQ & qDep <> '' then do
m.o.0 = 0
call mAdd o, 'select * from RZ2.TACCT_PKGUSED where'
pre = ' '
sql = "select dCollid, dName, dConToken" ,
"from sysibm.syspackdep",
"where (not bType in ('P', 'R')) and" ,
"(" substr(qDep, 5) ")"
flds = co na ct
sqlFlds = sqlFields(flds)
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 'CO NA'
if ^ mapHasKey(pkMap, co'.'na'.'ct) then
call err 'q package' co'.'na'.'ct 'not in dep'
dd = mapGet(pkMap, co'.'na'.'ct)
if m.dd.act ^== 'q' then do
m.dd.act = 'q'
call mAdd o, pre "(PCK_ID = '"na"' AND" ,
"PCK_CONSIST_TOKEN = '"c2x(ct)"')"
pre = ' or'
end
end
call adrSql 'close c1'
call writeDsn m.dPre'.JCL(QPKGSQL)', m.o., , 1
end
return
endProcedure mapAltNeu
createJb: procedure expose m.
m.jb.0 = 0
call mTypeNew 'StemJob', mTypeNew('Job', '', 'JOB TBND')
if m.task = 'NAKCD01' then
bLim = 4E+9
else
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
if m.tt.nTb < 1 then do
call warn 'skipping ts' m.tt 'without tables' m.tt.nTb
iterate
end
bys = bys + m.tt.used
tbs = tbs + m.tt.nTb
do nsX=1 to words(m.tt.tbSq)
ot = word(m.tt.tbSq, nsX)
if symbol('m.ot') ^== 'VAR' then
call err 'oldTable' ot 'undefined in TS' m.tt tt
call mPut mAdd(jb, m.ot), 'JOB TBND', jobNo, ot
end
end
return
endProcedure createJb
showAlt: 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) m.ss.used,
right(m.ss.ntb, 4) || right(m.ss.parts, 4) m.ss.bp
call mAdd o, l
end
do dx=1 to m.dep.0
dd = dep'.'dx
ww = m.dd.newNd
tp = m.dd.ty
if tp == 'V' then do
l = 'mV' left(m.dd, 20)left(m.ww, 20)
end
else if tp == 'A' | tp == 'Y' then do
l = m.dd.act
if l = '' then
l = 'd'
else if length(l) <> 1 | l = 'd' then
call err 'bad dep act' l 'for' m.dd
l = l || tp left(m.dd, 30)left(m.dd.bCr'.'m.dd.bNa, 30)
end
else do
call err 'bad ty in dep' m.dd.ty m.dd
end
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
call err 'implement external ri' m.rr ,
'->' m.rr.bCr'.'m.rr.bTb
/* 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
do px=1 to m.pk.0
p = 'PK.'px
if m.p.act = '' then
aa = 'pk'
else if (length(m.p.act) <> 1 | m.p.act = 'k') then
call err 'bad pk act' m.p.act
else
aa = m.p.act'k'
call mAdd o, aa left(m.p.collid'.'m.p.name, 17) ,
left(c2x(m.p.conToken), 16) substr(m.p.pcTimeStamp, 3,8),
left(m.p.validate, 1)left(m.p.isolation, 1),
|| left(m.p.valid, 1)left(m.p.operative, 1),
left(m.p.qualifier,8) left(m.p.owner, 8)
end
call writeDsn out, m.o., ,1
return
endProcedure showAlt
showNeu: procedure expose m.
parse arg out
m.o.0 = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
tt = m.jj.tbNd
ww = m.tt.newNd
l = 'mt'right(m.jj.job, 4) left(m.tt, 20)left(m.ww, 20),
|| left(m.tt.ts, 8) m.ww.for
call mAdd o, l
end
call writeDsn out, m.o., ,1
return
endProcedure showNeu
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
mb = dsnGetMbr(out)
call writeDsn dsnSetMbr(out, left(mb'CREATE', 8)), m.cr., ,1
call writeDsn dsnSetMbr(out, left(mb'DROPPP', 8)), 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, suFu
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
if suFu = '' then
call envPut 'DSNPRE', m.dPre'.'fun
else
call envPut 'DSNPRE',
, overlay(suFu, m.dPre, pos('NAK', m.dPre))'.'suFu
jOld = 0
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
if suFu = '' then
call envPutJOBNAME fun, oldJob
else
call envPutJOBNAME suFu, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
if oldOs <> os then do
oldOs = os
call envPut 'TS', m.os
if m.os.parts = 0 then do
call envPut 'PARTONE', ''
call envPut 'PAUN', 'UN'
end
else do
call envPut 'PARTONE', 'PART 1'
call envPut 'PAUN', 'PA'
end
call envExpAll o, skTS
end
call envPut 'TB', m.ot
call envExpAll o, skTb
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
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.db'.'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
if word(p.p, 2) ^== 'TABLE' then
call err 'TABLE expected in line' p 'in' pun':' p.p
w3 = word(p.p, 3)
if w3 = '' then do
p = p+1
w3 = word(p.p, 1)
end
if right(w3, 1) == '.' then do
p = p+1
w3 = w3 || word(p.p, 1)
end
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
if m.ss.parts == 0 then
wh = 'i'
else
wh = 'p'
end
else if w1 = 'PART' then do
if wh = 'p' then
wh = 'i'
else
call err 'PART in unpartitioned TS' m.tt.ts,
'for punchLine' p 'in' pun':' p.p
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'OS)', m.skOs.
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 jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
say 'job' fun oldJob':' (jx-jOld) 'tables'
jOld = jx
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skSt
end
ot = m.jj.tbNd
os = m.ot.tsNd
nt = m.ot.newNd
ns = m.nt.for
if oldOS ^== os then do
oldOS = os
tRec = 'TREC' || jx
call envPut 'TREC', tRec
call envPut 'OLDDB', m.os.db
call envPut 'OLDTS', m.os.ts
if m.os.parts = 0 then do
call envPut 'PAVAR',''
call envPut 'UNPARTDDN', 'INDDN' tRec
end
else do
call envPut 'PAVAR','P&PA..'
call envPut 'UNPARTDDN', ''
end
call envExpAll o, skOS
end
if oldNS ^== ns then do
oldNS = ns
call envPut 'TS', ns
call envExpAll o, skTs
end
call envPut 'TB', m.nt
if m.os.parts = 0 then do
call envPut 'PARTDDN', ''
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
else do
do px=1 to m.os.parts
call envPut 'PARTDDN', 'PART' px 'INDDN' tRec
call envExpAll o, skTb
call mAddSt o, ot'.LO'
end
end
end
say 'job' fun oldJob':' (jx-jOld) 'tables'
call writeDsn out, m.o., ,1
return
endProcedure load
check: procedure expose m.
parse arg fun, out
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nak'fun'Ut)', m.skut.
call readDsn m.skels'(nak'fun'Ts)', m.skts.
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
call envPutJOBNAME 'CHCK'
m.o.0 = 0
call envExpAll o, jc
call envExpAll o, skUt
do rx=1 to m.ri.0
rr = 'RI.'rx
cn = m.rr.cr'.'m.rr.tb
if mapHasKey(crNa, cn) then do
ot = mapGet(crNa, cn)
nt = m.ot.newNd
dbTs = m.nt.for
end
else do
call err 'implement check on foreign table'
end
if R.dbTs == 1 then
iterate
R.dbTs = 1
call envPut 'TS', dbTs
call envExpAll o, skTs
end
call writeDsn out, m.o., ,1
return
endProcedure check
utilList: procedure expose m.
parse arg fun, out, useOld
call readDsn m.skels'(nakJobCa)', m.jc.
call readDsn m.skels'(nakLstUt)', m.skUt.
call readDsn m.skels'(nakLstTs)', m.skTS.
call readDsn m.skels'(nak'fun')', m.skFu.
m.o.0 = 0
jj = ''
call envPut 'STEP', 'S01'
call envPut 'DBSYS', m.dbSys
do jx=1 to m.jb.0
jj = 'JB.'jx
if oldJob <> m.jj.job then do
if jx > 1 then
call envExpAll o, skFu
oldJob = m.jj.job
call envPutJOBNAME fun, oldJob
call envExpAll o, jc
call envExpAll o, skUt
end
ot = m.jj.tbNd
if useOld then do
os = m.ot.tsNd
ts = m.os
end
else do
nt = m.ot.newNd
ts = m.nt.for
end
if ts.ts = 1 then
iterate
ts.ts = 1
call envPut 'TS', ts
call envExpAll o, skTS
end
if jx > 1 then
call envExpAll o, skFu
call writeDsn out, m.o., ,1
return
endProcedure utilList
envPutJobname: procedure expose m.
parse arg fun, jobNo
jobChars = '0123456789ABCDEF'
if jobNo = '' then
n = 'Y' || m.tas3 || left(fun, 4, 'Z')
else
n = 'Y' || m.tas3 || left(fun, 3, 'Z') ,
|| substr(jobChars, 1 + (jobNo // length(jobChars)), 1)
call envPut 'JOBNAME', n
return
endProcedure envPutJobname
dropAlt: procedure expose m.
parse upper arg out, dropOnly
m.o.0 = 0
call mAdd o, "bist Du wirklich sicher ?"
call mAdd o, "set current sqlId = 'q100447';"
do ddx=1 to m.db.0
dd = 'DB.'ddx
call mAdd o, 'xrop database' m.dd.alt';'
call mAdd o, 'commit;'
end
call writeDsn out, m.o., ,1
if dropOnly == 1 then
return
call readDsn m.skels'(nakJobCa)', m.jc.
m.o.0 = 0
call envPutJOBNAME 'DBDROP'
call envExpAll o, jc
call dsnTep2 o, 'SDROP', out, '*'
call writeDsn m.dPre'.JCL(DBDROPAJ)', m.o., ,1
m.o.0 = 0
call envPutJobname 'DDLNEU'
call envExpAll o, jc
call dsnTep2 o, 'SCREA', m.dPre'.JCL(DDLNEU)', '*'
call writeDsn m.dPre'.JCL(DDLNEUJ)',m.o., ,1
m.o.0 = 0
call envPutJobname 'REBIND'
call envExpAll o, jc
call db2Dsn o, 'SCREA', m.dPre'.JCL(REBIND)', '*'
call writeDsn m.dPre'.JCL(REBINDJ)',m.o., ,1
return
endProcedure dropAlt
count: procedure expose m.
parse upper arg out, useOld, lim
outMb = dsnGetMbr(out)
if useOld then
call envPut 'DBIN', m.dbIn
else
call envPut 'DBIN', m.dbInNeu
if symbol('m.cnWit.0') ^== 'VAR' then do
call readDsn m.skels'(nakCnWit)', m.cnWit.
call readDsn m.skels'(nakCnRun)', m.cnRun.
call readDsn m.skels'(nakCnRts)', m.cnRts.
call readDsn m.skels'(nakCnSQL)', m.cnSQL.
call readDsn m.skels'(nakCnSQ2)', m.cnSQ2.
call readDsn m.skels'(nakJobCa)', m.cnJC.
end
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRun
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RUN'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnRts
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'RTS'), m.o2., ,1
m.o.0 = 0
call envExpAll o, cnWit
call envExpAll o, cnSQL
pre = ' '
if lim = '' then
lim = 9E99
ovLim = ''
do tx = 1 to m.tb.0
s = m.tb.tx.tsNd
if m.s.used > lim then do
ovLim = ovLim m.tb.tx.tb
end
else do
if useOld then do
call mAdd o, pre "select '"m.tb.tx.cr"', '"m.tb.tx.tb"'," ,
'count(*) from' m.tb.tx
end
else do
nt = m.tb.tx.newNd
call mAdd o, pre "select '"m.nt.cr"', '"m.nt.na"'," ,
'count(*) from' m.nt
end
pre = 'union'
end
end
call warn words(ovLim) 'tables over limit' lim 'of' m.tb.0':' ovLim
call envExpAll o, cnSQ2
m.o2.0 = 0
call splitSql o2, o
call writeDsn dsnSetMbr(out, outMb'SQL'), m.o2., ,1
call envPut 'DBSYS', m.dbSys
call envPutJobname outMb
m.o.0 = 0
call envExpAll o, cnJC
call dsnTep2 o, 'SRUN', m.dPre'.JCL('outMb'RUN)',
, m.dPre'.LIST('outMb'RUJ)'
call dsnTep2 o, 'SRTS', m.dPre'.JCL('outMb'RTS)',
, m.dPre'.LIST('outMb'RTJ)'
call dsnTep2 o, 'SSQL', m.dPre'.JCL('outMb'SQL)',
, m.dPre'.LIST('outMb'SQJ)'
/* call envPut 'STEP', 'SRUN'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RUN)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RUJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SRTS'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'RTS)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'RTJ)'
call envExpAll o, cnTep2
call envPut 'STEP', 'SSQL'
call envPut 'DSNIN', 'DISP=SHR,DSN='m.dPre'.JCL('outMb'SQL)'
call envPut 'DSNOUT', 'DISP=SHR,DSN='m.dPre'.LIST('outMb'SQJ)'
call envExpAll o, cnTep2
*/ call writeDsn dsnSetMbr(out, outMb'J'), m.o., ,1
return
endProcedure count
dsnTep2: procedure expose m.
parse arg o, st, in ,out
if symbol('m.dsnTep2.0') ^== 'VAR' then
call readDsn m.skels'(nakTep2)' , m.dsnTep2.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, dsnTep2
return
endProcedure dsnTep2
db2Dsn: procedure expose m.
parse arg o, st, in ,out
if symbol('m.db2Dsn.0') ^== 'VAR' then
call readDsn m.skels'(nakDsn)' , m.db2Dsn.
call envPut 'STEP', st
call envPut 'DSNIN', 'DISP=SHR,DSN='in
if out == '*' then
call envPut 'DSNOUT', 'SYSOUT=*'
else
call envPut 'DSNOUT', 'DISP=SHR,DSN='out
call envExpAll o, db2Dsn
return
endProcedure db2Dsn
splitSql: procedure expose m.
parse arg d, s
do sx=1 to m.s.0
l = strip(m.s.sx, 't')
do while length(l) > 71
cx = lastPos(", ", left(l, 72))
if cx < 20 then
call err 'cannot split line' l
call mAdd d, left(l, cx+1)
l = ' ' substr(l, cx+2)
end
call mAdd d, l
end
return
endProcedure splitSql
rebind: procedure expose m.
parse arg out, cmd, opt
m.o.0 = 0
spec = 0
triCmd = cmd
if pos('T', opt) > 0 then
triCmd = cmd 'TRIGGER'
do px=1 to m.pk.0
p = 'PK.'px
spec = spec+rebindOut(o, cmd, opt,
, m.p.collid, m.p.name, m.p.version,
, m.p.type, m.p.qualifier, m.p.owner)
end
if spec > 0 then do
call warn spec 'special rebinds (qualifier or owner)'
end
call writeDsn out, m.o., ,1
return
endProcedure rebind
rebindOut: procedure expose m.
parse arg o, cmd, opt, co, pk, ve, ty, qu, ow
if ty == 'T' then
t = cmd 'PACKAGE('co'.'pk')'
else
t = cmd 'PACKAGE('co'.'pk'.('strip(ve)'))'
q = ''
if pos('Q', opt) > 0 then
if qu ^= 'OA1P' then
q = 'QUAL(OA1P)'
if pos('O', opt) > 0 then
if wordPos(ow, 'S100447 CMNBATCH S100006') < 1 then
q = q 'OWNER(S100447)'
if q == '' then do
call mAdd o, t';'
return 0
end
if length(t q) <= 70 then do
call mAdd o, t q';'
end
else do
call mAdd o, t '-'
call mAdd o, ' ' q';'
end
return 1
endProcedure rebindOut
restartRebind: procedure expose m.
parse arg opt, in, out
sql = "select version,type, valid, operative",
"from sysibm.sysPackage",
"where location = '' and collid=? and name=? and conToken = ? "
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call readDsn in, i.
m.o.0 = 0
cPk = 0
cRs = 0
do i=1 to i.0
if ^ (left(i.i, 3) == 'pk ' | left(i.i, 3) == 'qk ') then
iterate
parse var i.i 4 co '.' pk ct dt fl qu ow .
ctsq = "'" || x2c(ct) || "'"
call adrSql 'open c1 using :CO, :PK , :ctsq'
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
rst = 0
msg = ''
if sqlCode = 100 then do
say '*** pkg not in catalog' fl co'.'pk ct
rst = 1
end
call adrSql 'fetch c1 into :fVe, :fTy, :fVd, :fOp'
if sqlCode ^= 100 then
call err 'duplicate fetch for package' co'.'pk ct
if rst then
nop
else if fVd = 'Y' & fOp = 'Y' then
nop /* say fVe fTy fVd '|| fOp 'validOp' */
else if (fVd = 'Y' | substr(fl, 3, 1) = 'N') then
msg = 'inval bef'
else if pos('=', opt) > 0 & (fVd = substr(fl, 3, 1)) then
msg = 'as before'
else
rst = 1
if pos('S', opt) > 0 then do
if rst then
msg = 'retrying '
if msg ^== '' then
say msg fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
end
cPk = cPk + 1
cRs = cRs + rst
if rst then do
/* say 'retrying ' fTy fl '-->' fVd || fOp co'.'pk'('fVe')'
*/ call rebindOut o, 'REBIND', 'QO', co, pk, fVe, fTy, qu, ow
end
call adrSql 'close c1'
end
say 'retrying' cRs 'rebinds of' cPk
if m.o.0 > 0 then
call writeDsn out, m'.'o'.', , 1
return
endProcedure restartRebind
checkUnloadDS: procedure expose m.
parse arg in, pref
call readDsn in, i.
cTb = 0
cTs = 0
cDS = 0
cEr = 0
call mapReset 'TS', 'K'
do i=1 to i.0
if left(i.i, 3) ^== 'oT ' then
iterate
parse var i.i 4 cr '.' tb db '.' ts sz nTb parts bp .
call stripVars 'cr tb db ts'
if 0 then
say cr'.'tb 'in' db'.'ts 'sz' sz 'nTb' nTb 'parts' parts
dbTs = db'.'ts
cTb = cTb + 1
if mapHasKey('TS', dbTs) then do
ts.dbTs = ts.dbTs cr'.'tb
end
else do
cTs = cTs + 1
call mapAdd 'TS', dbTs, nTb
ts.dbTs = cr'.'tb
if parts = 0 then do
cEr = cEr + check1Ds(pref'.'db'.'ts'.UNL')
cDs = cDs + 1
end
else do
do px=1 to parts
cEr = cEr + check1Ds( ,
pref'.'db'.'ts'.P'right(px, 5, 0)'.UNL')
cDs = cDs + 1
end
end
end
end
say cTb 'tables,' cTs 'TS, ' cDs 'Datasets with' cEr 'errors'
k = mapKeys('TS')
do x=1 to m.k.0
dbts = m.k.x
if mapGet('TS', dbTs) ^= words(ts.dbTs) then
call err 'ts' dbTs 'should have' mapGet('TS', dbTs) ,
'tables but found' words(ts.dbTs)':' ts.dbTs
end
return
endProcedure checkUnloadDS
check1Ds: procedure expose m.
parse arg dsn
res = sysDsn("'"dsn"'")
if res ^== 'OK' then do
say dsn res
return 1
end
res = adrTso("alloc dd(ch) dsn('"dsn"')", '*')
if res <> 0 then do
say 'could not allocate' dsn
call adrTso "free dd(ch)", '*'
return 1
end
call readDDbegin ch
call readDD ch, ch., 100
if ch.0 < 100 then
say 'read' dsn ch.0
call readDDend ch
call adrTso "free dd(ch)", '*'
return 0
endProcedure check1DS
ctlSearch: procedure expose m.
parse arg fun, out, pds, mbrs, sPre
m.o.0 = 0
do mx=1 to words(mbrs)
seMb = word(mbrs, mx)
dsn = pds'('seMb')'
call readDsn dsn, l.
do l=1 to l.0 while pos('SRCH DSN:', l.l) < 1
end
cx = pos('SRCH DSN:', l.l)
if cx < 1 then
call err 'no SRCH DSN: found in' dsn
sLib = word(substr(l.l, cx+9), 1)
cnt = 0
drop f.
do l=l to l.0
cx = pos('--- STRING(S) FOUND ---', l.l)
if cx < 1 then
iterate
else if cx < 20 then
call err 'bad ...FOUND... line' l in dsn':' l.l
cMb = word(l.l, 1)
if f.cMb = 1 then do
call warn 'duplicate' cMb 'in' seMb sLib
iterate
end
f.cMb = 1
call mAdd o, 'cc' left(cMb, 9) left(seMb,9) sLib
cnt = cnt + 1
call readDsn sLib'('cMb')', m.cc.
m.ctlMbr = seMb'('cMb')'
call writeDsn sPre'.CALT.'seMb'('cMb') ::F', m.cc., , 1
if fun = 'C' then do
call transformCtl cc
call writeDsn sPre'.CNeu.'seMb'('cMb') ::F', m.cc., , 1
end
end
say cnt 'members found in' seMb sLib
end
call writeDsn out, m.o., ,1
return
endProcedure ctlSearch
ctlTransQQ: procedure expose m.
call ctlTransMM 'DSN.NAKWB.CALT.LISTNEU', 'DSN.NAKWB.CNEU.LISTNEU',
, QR055031 ,
QR055081 ,
QR055151 ,
QR058041 ,
QR058051 ,
QR058071 ,
QS055031 ,
QS055081 ,
QS055151 ,
QS058031 ,
QS058041 ,
QS058051
return
endProcedure ctlTransQQ
ctlTransMM: procedure expose m.
parse arg src, trg, mbrs
say '??mm' mbrs
do mx=1 to words(mbrs)
mb = word(mbrs,mx)
say '??' mb
call readDsn src'('mb')', m.cc.
call transformCtl cc
call writeDsn trg'('mb') ::F', m.cc., , 1
end
return
endProcedure ctlTransMM
transformTest: procedure expose m.
m.h.1 = 'wie gehts walti'
m.h.2 = 'wie ODV.walti mit imf.ersatz oder IMFDNF01DNF02ODV'
m.oldTs.TSTNAKAL.S004A = TSTNAKNE.A00004A345A
m.oldTs.TSTNAKAL.S003 = TSTNAKNE.A3A
m.h.3 = 'wie TSTNAKAL . S003 TSTNAKAL.S004A DTSTNAKAL . M014A V'
m.h.4 = 'TSTNAKAL,.| TSTNAKAL ? SP(S003 , S004A , M014A* V'
m.h.0 = 4
call mAddSt mCut(i, 0), h
call transformCtl i
do x=0 to m.h.0
say 'i' m.h.x
say 'o' m.i.x
end
exit
endProcedure transformTest
transformCtl: procedure expose m.
parse arg i
if symbol('m.tcl.0') ^== 'VAR' then do
say m.scan.tcl.name1
call scanSqlIni tcl
say m.scan.tcl.name1
say m.scan.tcl.name
if symbol('m.scan.tcl.name') ^== 'VAR' then
call err 'ini scanSql failed'
m.tcl.f.1 = 'ODV'
m.tcl.t.1 = 'OA1P'
m.tcl.f.2 = 'IMF'
m.tcl.t.2 = 'OA1P'
y = 2
do d=1 to m.db.0
y = y + 1
m.tcl.f.y = m.db.d.alt
m.tcl.t.y = m.db.d.neu
end
m.tcl.0 = y
end
do j=1 to m.i.0
lNo = substr(m.i.j, 73)
m.i.j = strip(left(m.i.j, 72), 't')
if left(m.i.j, 2) = '//' & word(m.i.j, 2) = 'JOB' then
iterate
do y=1 to m.tcl.0
cx = 1
do forever
cx = replOne(i'.'j, cx, m.tcl.f.y, m.tcl.t.y)
if cx < 1 then
leave
if y <= 2 then
iterate
call scanLine tcl, m.i.j " ' ' ' ' ' ' ' ' "
m.scan.tcl.pos = cx
call scanSql scanSkip(tcl)
if m.sqlType == '.' then do
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
cx = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
end
end
else do
fnd = 0
do q=1 to 3 while m.scan.tcl.pos <= 73
if m.sqlType == 'i' & wordPos(m.val,
, 'SP SPACE SPACENAM') > 0 then do
fnd = 1
leave
end
call scanSql scanSkip(tcl)
end
if ^fnd then
iterate
do while m.scan.tcl.pos <= 73
if scanSqlDeID(scanSkip(tcl)) ^== '' then do
px = replTS(i'.'j,
, m.scan.tcl.pos,
, length(m.tok),
, m.tcl.f.y'.'m.val)
call scanLine tcl, m.i.j
m.scan.tcl.pos = px
end
else if scanSql(scanSkip(tcl)) == '' ,
| m.sqlType == ')' then
leave
end
end
end
end
m.i.j = strip(m.i.j, 't')
if length(m.i.j) > 72 then do
call warn 'line overFlow' length(m.i.j)m.i.j
m.i.j = left(m.i.j, 80)
end
m.i.j = left(m.i.j, 72)lNo
end
return
endProcedure transformCtl
replOne: procedure expose m.
parse arg l, x, o, n
y = pos(o, translate(m.l), x)
if y < 1 then
return 0
m.l = left(m.l, y-1) || n || substr(m.l, y + length(o))
return y + length(n)
endProcedure replOne
replTS: procedure expose m.
parse arg li, x, len, os
if symbol('m.oldTs.os') ^== 'VAR' then do
call warn 'old TS not found:' os 'in' m.ctlMbr 'line' m.li
return x
end
na = strip(m.oldTs.os)
if words(m.oldTs.os) > 1 then do
call warn 'old TS has multiple new:' os '->' nn,
'in' m.ctlMbr 'line' m.li
return x
end
na2 = strip(substr(na, pos('.', na)+1))
m.li = left(m.li, x-1-len) || na2 || substr(m.li, x)
return x - len + length(na2)
endProcedure replTS
allocList: procedure expose m.
parse upper arg nPre, list
s.1 = 'dummy member zzzzzzzz'
s.0 = 1
do wx=1 to words(list)
w = word(list, wx)
if w = 'LIST' then
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F133', s., 1, 1
else
call writeDsn nPre'.'w'(ZZZZZZZZ) ::F', s., 1, 1
end
return
endProcedure allocList
err:
say '*** error:' arg(1)
call warnWrite m.dPre'.JCL'
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
warn: procedure expose m.
parse arg msg
msg = strip(msg)
say '***warn:' msg
call mAdd warn, left(msg, 72)
do x=73 by 68 to length(msg)
call mAdd warn, ' 'substr(msg,x, 68)
end
return
endProcedure warn
warnWrite: procedure expose m.
parse arg lib
if 0 then do
x = 'abcdefghijklmnopqrstuvwxyz'
x = '0123456789' || x || translate(x)
call warn 'test mit langer warnung' x x x x x x x x x x x'|'
end
if m.warn.0 = 0 then do
say 'keine Warnungen'
return
end
say m.warn.0 'Warnungen'
do i=1 to 20
dsn = lib'(warn'right(i, 3, 0)')'
sd = sysDsn("'"dsn"'")
if sd = 'MEMBER NOT FOUND' then
leave
end
if sd = 'MEMBER NOT FOUND' then do
call writeDsn dsn, m.warn., , 1
end
else do
say 'error cannot write warnings' dsn ':' sd
do x=1 to m.warn.0
say m.warn.x
end
end
return
endProcedure warnWrite
/* copy scanSql begin *************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlIni: procedure expose m.
parse arg m
call scanOptions m, , '0123456789_' , '--'
m.scan.m.sqlBrackets = 0
return m
endProcedure scanSqlIni
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 scanReader 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 scanStringML(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
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 = ''
if symbol('m.scan.m.name') ^== 'VAR' then do
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 = ''
end
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
call scanInit m
m.scan.m.comment = comm
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 string with quote char qu -------------------------------*/
scanStringML: 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
lCnt = 0
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then do
m.val = m.val || substr(m.scan.m.src, qx)
if lCnt == 9 | ^ scanNl(m, 1) then
call scanErr m, 'ending Apostroph('qu') missing multi'
qx = 1
bx = 1
end
else do
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
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
scanLinePos: procedure expose m.
parse arg m
interpret 'return' m.scan.m.scanLinePos
endProcedure scanLinePos
/*--- 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
say scanLinePos(m)
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)'
end
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
mapKeys: procedure expose m.
parse arg a
return a'.'mapKey
endProcedure mapKeys
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 *****************************************************/