zOs/REXX/PLOADW
/* rexx ****************************************************************
synopsis: pLoad [d] [?] [idNr]
d: mit Debug output
?: diese Hilfe
id: numerischer Teil einer existierenden id
keine id: neue id erstellen
Funktion:
Defaults (global und user) laden
Optionen für id editieren
und dann Job für copy/unload/load erstellen und editieren
logfile schreiben in DSN.pLoad.INFO(LOG)
Konfiguration (global, user (DSN.pLoad.INFO(userId())) und id):
rexx code, der folgende Variabeln setzen soll
m.auftrag Auftraggeber etc
m.punchList = list of punchfiles to analyze (fully qualified)
m.volume = '' input punch and load are catalogued
else reside on this volume
m.resume = '' use resume clause from punch
= 'NO' use log no resume no replace
= 'YES' use log yes resume yes
m.owner = '' deduce owner from db2SubSys and catalog
else use the given owner
m.load = '' use load DSN from punch
else use the given DSN (fully qualified) as loadfile
(with variables &PA. &TS. &DB.)
m.db2SubSys db2 subsystem for load
m.mgmtClas sms class for generated datasets
m.jobcard.* stem for jobcards
m.orderTS = 0 first all copies unloads, afterwards all loads
(usefull with constraints, because of checkPen)
else utility task grouped together for each TS
************************************************************************
08.08.2008 W. Keller: orderTS Option eingefügt
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
load überschreiben ohne inDDN erlauben|
copy nach load resume anfügen
2 Phasen trennen: datasets reinkopieren (kumulieren)
: copy/load durchführe (+restore, +log?|)
==> genpügt: noCopy und noUtil Options
(2. Phase ab 1. benutzen)
scan stirbt bei einer template mit space (..) cyl am schluss
Funktion für unloads im RZ1 bzw. RR2, auf entsprechende Shares
und Vorbereitung einer id
16.05.2008 W. Keller: Warnung bei TS mit mehreren Tables
12.01.2007 W. Keller: support partitions
01.12.2006 W. Keller: fix volume and m.load
22.11.2006 W. Keller: neu erstellt
***********************************************************************/
parse upper arg args
m.testFast = 0 /* args = '' & userId() = 'A540769' */
if m.testFast then
args = 108
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0
idN = '' /* parse arguments */
do wx = 1 to words(args)
w = word(args, wx)
if w = '?' then
call help
else if w = 'D' then
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret main/userOption */
call interDsn m.mainLib'(mainOpt)'
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then
call interDsn userOpt
if idN = '' then /* check/create id options */
idN = log('nextId')
call genId idN
if ^ m.testFast then
call adrIsp "edit dataset('"m.optDsn"')", 4
call interDsn m.optDsn
if m.punchList = '' then
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume)
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')'
m.orderTS = m.orderTS <> 0
do wx=1 to words(m.punchList) /* analyze all punchfiles */
w = word(m.punchList, wx)
call debug 'analyzing punchfile' w vol
call analyzePunch w vol, m.treeLd, m.treePn
end
call checkOverride m.treeLd /* massage the analyzed input */
call createTables m.treeLd, m.treeTb
if m.debug then
call mShow m.treeRoot
/* generate jcl */
call jclGenStart m.treePn, m.treeTb
call jclGenCopyInput m.treePn, m.treeTb
punDsn = genSrcDsn('PUNCH')
call jclGenPunch m.treeTb, punDsn
call jclGenUtil punDsn, m.db2SubSys
jclDsn = genSrcDsn('JCL')
call writeJcl jclDsn
call log 'load' /* write the log */
call adrIsp "edit dataset('"jclDsn"')", 4
call finish
exit
/*---tree structure-----------------------------------------------------
tree
punch
punchfiles*
templates* template in this punchfile
load
load* each load statement in a punchfile
into* each into clause in the load
table
table* each db2 table
----------------------------------------------------------------------*/
/*--- initialisation -------------------------------------------------*/
init: procedure expose m.
call ooIni
m.treeRoot = mRoot("root", "root")
m.treePn = mAddK1(m.treeRoot, 'punch')
m.treeLd = mAddK1(m.treeRoot, 'load')
m.treeTb = mAddK1(m.treeRoot, 'table')
call adrSqlConnect m.db2SubSys
return
endProcedure init
/*--- cleanup at end of program --------------------------------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- debug output if m.debug is set ---------------------------------*/
debug: procedure expose m.
if m.debug then
say 'debug' arg(1)
return
endProcedure debug
/*--- error message an suicide ---------------------------------------*/
err:
parse arg ggMsg
call errA ggMsg, 1
endSubroutine err
/*--- generate an id -------------------------------------------------*/
genId: procedure expose m.
parse arg iNum
m.id = 'N'right(iNum, 4, 0)
/* if punch is present, warn the user
because db2 utility probably was started already */
puDsn = genSrcDsn("PUNCH")
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
if m.testFast then do
say 'weiter wegen m.testFast'
end
else do
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* create the src dataset for this id, if it does not exist */
lib = genSrcDsn()
m.optDsn = genSrcDsn('OPTIONS')
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then
mgCl = 'MGMTCLAS('m.mgmtClas')'
call adrTso 'alloc dd(ddCrea) new catalog dsn('jcl2Dsn(lib)')',
'dsntype(library) dsorg(po) recfm(f b) lrecl(80)' ,
'space(1, 10)' mgCl
call adrTso 'free dd(ddCrea)'
end
else if libSta ^= 'MEMBER NOT FOUND' & libSta ^= 'OK' then do
call err 'not supported sysdsn = ' libSta 'for scrLib' m.optDsn
end
/* create the options mbr for this id if it does not exist */
if libSta ^= 'OK' then
call writeOptions
return
endProcedure genId
/*--- write the options member: contents of variables and help -------*/
writeOptions: procedure expose m.
m.op.0 = 0
m.generated = date('s') time() 'by' userId()
vars = 'generated auftrag punchList volume' ,
'resume owner load db2SubSys orderTS'
wp = words(m.punchList)
do vx=1 to words(vars)
v = word(vars, vx)
if v <> 'punchList' | wp <= 1 then do
call mAdd op, left('m.'v, 14)'=' quote(value('m.'v), "'")
end
else do
li = left('m.punchList', 14)'='
do wx=1 to wp
call stAdd op, left(li, 15) ,
quote(word(m.punchList, wx),"'"), left(',', wx < wp)
li = ''
end
end
end
/* help is the leading commentblock */
call mAdd op
do lx=1 by 1
li = strip(sourceLine(lx), 't')
call mAdd op, li
if pos('*/', li) > 0 then
leave
end
call writeDsn m.optDsn, m.op.
m.srcOpt = 1
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
interDsn: procedure expose m.
parse arg dsn
call debug 'interpreting' dsn
call readDsn dsn, x.
/* concat all the lines */
s = ''
do x=1 to x.0
l = strip(x.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret s
call debug 'interpreted' dsn
return
endProcedure interDsn
/*--- handle the log file --------------------------------------------*/
log: procedure expose m.
parse arg fun
dsn = m.mainLib'(LOG)'
call readDsn dsn, l.
zx = l.0
cId = m.id
if fun = 'nextId' then do /* reserve the next id */
id = strip(left(l.zx, 8))
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
zx = zx + 1
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
end
else if fun = 'load' then do /* log the current id */
/* find the current id in the log */
do ax = 1 by 1 to zx while strip(left(l.ax, 8)) < cId
end
do bx = ax by 1 to zx while strip(left(l.bx, 8)) = cId
end
le = left(cId, 8) date('s') left(time(), 5) left(m.auftrag, 20),
left(sysVar(sysNode) m.db2SubSys, 8)
/* shift the remaining entries */
tbRoot = m.treeTb
tSize = mSize(tbRoot)
sx = tSize-bx+ax
if sx > 0 then do
do qx=zx by -1 to bx /* shift right */
rx = qx+sx
l.rx = l.qx
end
end
else if sx < 0 then do /* shift left */
do qx=bx by 1 to zx
rx = qx+sx
l.rx = l.qx
end
end
zx = zx + sx
/* one log line for each table */
do tx=1 to tSize
tn = mAtSq(tbRoot, tx)
in = word(mVaAtK1(tn, 'intos'), 1)
owTb = mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb')
if length(owTb) < 19 then
owTb = left(owTb, 19)
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if length(dbTs) < 19 then
dbTS = left(dbTS, 19)
rx = ax + tx - 1
l.rx = le ,
left(mFirst('RESUME', '???', in, mPar(in)), 3) ,
owTb dbTs mVaAtK1(tn, 'parts')
end
end
else do
call err 'bad log fun' fun
end
call writeDsn dsn, l., zx
return substr(cId, 2)
endProcedure log
/*--- analyze a punchfile ----------------------------------------------
puDsn: spec for input dsn to analyze
ldRoot: parentNode of node for each load
puRoot: parent node for each punchFile ---------------------*//
analyzePunch: procedure expose m.
parse arg puDsn, ldRoot, puRoot
pu = readDsnOpen(ooNew(), puDsn)
co = treeCopyOpen(ooNew(), pu, '??', 0)
sc = scanUtilReader(ooNew(), co)
tmpl = mAddKy(puRoot, 'punch', puDsn)
do forever
if utilNext == 'TEMPLATE' then do
utilNext = analyzeTemplate(sc, tmpl)
end
else if utilNext == 'LOAD' then do
ch = mAddKy(ldRoot, 'load', tmpl)
utilNext = analyzeLoad(sc, co, ch, tmpl)
end
else do
u = scanUtil(sc)
if u == 'u' then
utilNext = m.val
else if u == '' then
leave
end
end
call ooReadClose pu
return
endProcedure analyzePunch
/*--- analyze template -----------------------------------------------*/
analyzeTemplate: procedure expose m.
parse arg sc, nd
if 'u' = scanUtil(sc) then
return m.val
else if m.utilType ^= 'n' then
call scanErr sc, 'template name expected'
na = m.tok
ch = mAddK1(nd, na, 'template')
do forever
if 'u' == scanUtil(sc) | m.utilType = '' then do
return m.val
end
else if m.utilType == 'n' & m.scan.sc.utilBrackets = 0 then do
parm = m.val
if wordPos(parm, 'DSN VOLUME') > 0 then
call mAddK1 ch, parm, scanUtilValue(sc)
else if parm = 'VOLUMES' then
call mAddK1 ch, 'VOLUME', scanUtilValue(sc)
else
call debug 'ignoring' parm scanUtilValue(sc)
end
else do
call debug 'template chunck' m.utilType m.tok
end
end
endProcedure analyzeTemplate
/*--- analyze load ---------------------------------------------------*/
analyzeLoad: procedure expose m.
parse arg sc, cc, ldNd, tmplNd
if scanUtil(sc) ^== 'n' & m.val ^== 'DATA' then
call scanErr sc, 'load data expected'
nd = ldNd
/* the load into syntax is too complex to analyze completly
instead, we use treeCopy to copy all unAnalyzed text */
call treeCopyDest cc, nd
call treeCopyOn cc, m.scan.sc.pos
do while 'u' ^== scanUtil(sc) & m.utilType ^== ''
if m.utilType ^= 'n' | m.scan.sc.utilBrackets ^= 0 then
iterate
opt = m.val
if wordPos(m.val, 'INDDN RESUME SHRLEVEL REPLACE COPYDDN' ,
'LOG INTO PART') < 1 then
iterate
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
if opt == 'INTO' then do
if scanUtil(sc) ^== 'n' | m.val ^== 'TABLE' then
call scanErr sc, 'into table expected'
if scanUtil(sc) ^== 'n' & m.utilType ^== '"' then
call scanErr sc, 'table name expected'
nd = mAddKy(ldNd, opt, '')
call mAddK1 nd, 'ow', strip(m.val)
if scanUtil(sc) ^== '.' then
call scanErr sc, '.table expected'
if scanUtil(sc)^=='n' & m.utilType^=='"' then
call scanErr sc, 'table name expected'
call mAddK1 nd, 'tb', strip(m.val)
call treeCopyDest cc, nd
end
else if opt == 'INDDN' then do
dd = scanUtilValue(sc)
ddNd = mAtK1(tmplNd, dd)
if ddNd = '' & m.load = '' then
call err 'template not found for inDDn' dd
call mAddK1 nd, 'INDDN', ddNd
end
else if opt == 'REPLACE' then do
call mAddK1 nd, opt, 1
end
else do
call mAddK1 nd, opt, scanUtilValue(sc)
end
call treeCopyOn cc, m.scan.sc.pos
end
call treeCopyOff cc, m.scan.sc.pos - length(m.tok)
return m.val
endProcedure analyzeLoad
/*--- check loads and override values --------------------------------*/
checkOverride: procedure expose m.
parse arg ldRoot
rs = translate(m.resume)
do lx=1 to mSize(ldRoot) /* for each load */
ld = mAtSq(ldRoot, lx)
loDdn = overrideLoad(mAtK1(ld, 'INDDN'))
if rs <> '' then
call mPut ld, 'RESUME', rs
do ix=1 to mSize(ld) /* for each into */
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
nd = mAtK1(in, 'PART')
if nd = '' then
nd = mAddK1(in, 'PART', '*')
part = m.nd
info = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb') 'part' part
if part == '*' then
nop
else if ^ datatype(part, 'n') | length(part) > 5 then
call scanErr sc, 'bad partition' part 'for' info
else
part = right(part, 5, 0)
m.nd = part
inDdn = overrideLoad(mAtK1(in, 'INDDN'))
if inDDn = '' then do
if loDDn = '' then
call err 'no inDDN for' info
DDn = loDDn
end
else do
if loDDn <> '' then
call err 'inDDn twice specified for' info
ddn = inDDn
end
if m.volume <> '' & mAtK1(ddn, 'VOLUME') = '' then
call mAddK1 in, 'VOLUME', m.volume
if rs <> '' then
call mPut in, 'RESUME', rs
end /* for each into */
end /* for each load */
return
endProcedure checkOverride
/*--- override or modify the load pointed to by nd -------------------*/
overrideLoad: procedure expose m.
parse arg nd
if nd == '' then
return nd
if m.load <> '' then do
if symbol('m.loadNd') <> 'VAR' then do
m.loadNd = mAddK1(m.treeRoot, 'overLoad')
call ds2Tree m.load, m.loadNd
end
m.nd = m.loadNd
end
if m.volume <> '' then
call mPut m.nd, 'VOLUME', m.volume
return nd
endProcedure overrideLoad
/*--- create tables: find destination creator and ts in catalogue
create tree for destination table and
link it to all into nodes -----------------------*/
createTables: procedure expose m.
parse arg ldRoot, tbRoot
do lx=1 to mSize(ldRoot)
ld = mAtSq(ldRoot, lx)
do ix=1 to mSize(ld)
in = mAtSq(ld, ix)
if mKy(in) <> 'INTO' then
iterate
oOw = mVaAtK1(in, 'ow')
oTb = mVaAtK1(in, 'tb')
if symbol('old.oOw.oTb') = 'VAR' then do
nd = old.oOw.oTb
call debug 'found' nd 'for old table' oOw'.'oTb
end
else do /* search table in db2 catalog */
parse value queryTable(oOw, oTb) ,
with nOw'.'nTb':'db'.'ts
nd = mAtK1(tbRoot, nOw'.'nTb)
if nd <> '' then do
call debug 'found' nd 'for new table' nOw'.'nTb
end
else do /* create node for table */
nd = mAddK1(tbRoot, nOw'.'nTb)
call mAddK1 nd, 'ow', nOw
call mAddK1 nd, 'tb', nTb
call mAddK1 nd, 'db', db
call mAddK1 nd, 'ts', ts
call mAddK1 nd, 'parts'
call debug 'created' nd 'for new table' nOw'.'nTb
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
end
m.in = nd
pp = mVaAtK1(in, 'PART')
op = mVaAtK1(nd, 'parts')
if op = '' then do
np = pp
ni = in
if pp = '*' then
call mAddK1 nd, 'tsPa', 'TS'
else
call mAddK1 nd, 'tsPa', 'PA'
end
else if pp = '*' | op = '*' then
call err 'part * not alone in tb' nOw'.'nTb
else if wordPos(pp, op) > 0 then
call err 'part' pp 'duplicate n tb' nOw'.'nTb
else do /* add new partition into sorted list */
do wx=1 to words(op) while pp > word(op, wx)
end
np = subword(op, 1, wx-1) pp subword(op, wx)
oi = mVaAtK1(nd, 'intos')
ni = subword(oi, 1, wx-1) in subword(oi, wx)
end
call mPut nd, 'parts', np
call mPut nd, 'intos', ni
end
end
return
endProcedure createTables
/*--- query the db2 catalog for creator, db, ts etc.
of the tables to load --------------------------------------*/
queryTable: procedure expose m.
parse upper arg ow, tb
sql = "select t.name, t.creator, tsName, t.dbname, s.nTables" ,
"from sysibm.systables t, sysibm.systablespace s" ,
"where t.type = 'T'" ,
"and s.dbName = t.dbName and s.name = t.tsName" ,
"and t.name = '"strip(tb)"' and t.creator"
if m.owner <> '' then do /* override owner */
sql = sql "= '"strip(m.owner)"'"
end
else if left(ow, 3) == 'OA1' then do /* translate OA1* owners */
o = substr(strip(m.db2SubSys), 3, 1)
if o = 'O' | sysvar(sysnode) <> 'RZ1' then
o = 'P'
nn = overlay(o, ow, 4)
if nn = 'OA1P' then
sql = sql "in ('OA1P', 'ODV', 'IMF')"
else
sql = sql "= '"strip(nn)"'"
end
else do /* user owner as is */
sql = sql "= '"strip(ow)"'"
end
/* execute sql and fetch row */
call adrSql 'prepare s1 from :sql'
call adrSql "declare c1 cursor for s1"
call adrSql 'open c1'
cnt = 0
do forever
call adrSql 'fetch c1 into :tb, :cr, :ts, :db, :tbCnt'
if sqlCode = 100 then
leave
cnt = cnt + 1
if cnt > 1 then
call err 'fetched more than 1 row for table' ow'.'tb ':'sql
end
if cnt = 0 then
call err 'table' ow'.'tb 'not found in catalog:' sql
else if tbCnt <> 1 then do
say 'ts' db'.'ts 'hat' tbCnt 'Tabellen'
say 'pLoad kann mit RESUME=NO Daten ueberschreiben'
say 'trotzdem weitermache (w=weiter)?'
parse upper pull a
if ^ abbrev(a, 'W') then
call err 'nicht weiter'
end
call adrSql 'close c1'
return strip(cr)'.'strip(tb)':'strip(db)'.'strip(ts)
endProcedure queryTable
/*--- write the generated jcl ----------------------------------------*/
writeJcl: procedure expose m.
parse arg dsn
x = dsnAlloc(dsn, 'SHR', jclGen)
dd = word(x, 1)
call writeDDBegin dd
call writeDD dd, 'M.JOBCARD.'
do j = 1 to m.jclCard.0
call debug 'jclCard j' M.JCLCARD.j.0
call writeDD dd, 'M.JCLCARD.'j'.'
end
call writeDDEnd dd
interpret subword(x, 2)
return
endProcedure writeJCL
/*--- generate the JCL -----------------------------------------------*/
jclGenStart: procedure expose m.
parse arg pnRoot, tbRoot
call jclIni
/* show our infos in comment */
call jcl '10'copies('*', 69)
parse source . . ggS3 .
call jcl '10* load job generated by' ggS3 ,
'in' sysvar(sysnode) 'for' m.db2SubSys 'by' userid()
call jcl '10* id' m.id 'at' date('s') time()
do px=1 to mSize(pnRoot) /* show input punch */
pn = mAtSq(pnRoot, px)
call jcl '1* punch ' m.pn
end
do tx=1 to mSize(tbRoot) /* show output tables */
tn = mAtSq(tbRoot, tx)
call jcl '1* load ' ,
mVaAtK1(tn, 'ow')'.'mVaAtK1(tn, 'tb') ,
'in' mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
p = mVaAtK1(tn, 'parts')
if p <> '*' then
call jcl '1* ' words(p) 'partitions between' word(p, 1),
'and' word(p, words(p))
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos) /* show input tables and dsns */
in = word(intos, ix)
owTb = mVaAtK1(in, 'ow')'.'mVaAtK1(in, 'tb')
if i.owTb == 1 then
iterate
i.owTb = 1
if length(owTb) < 16 then
owTb = left(owTb, 16)
tmpl = mFirst('INDDN', , in, mPar(in))
call jcl '1* from' owTb mVaAtK1(tmpl, 'DSN')
end
drop i.
end
call jcl '10'copies('*', 69) /* end of info comment */
call jcl '1* alle Dataset löschen, die wir nachher neu erstellen'
call jcl '1'jclExec() 'PGM=IEFBR14'
return
endProcedure jclGenStart
/*--- copy all input dsns to our Prefix ------------------------------*/
jclGenCopyInput: procedure expose m.
parse arg puRoot, tbRoot
do px=1 to mSize(puRoot) /* punch files */
pn = mAtSq(puRoot, px)
call jcl '2* Originales Punchfile Kopieren'
call jclCopy ds2Tree(m.pn, m.jclNdFr) ,
, ds2Tree(genSrcDsn('OPUNCH', px), m.jclNdTo)
end
/* load input dsns */
m.dsnLoadTS = genDsn('&DB..&TS.', 'LOAD')
m.dsnLoadPA = genDsn('&DB..&TS..P&PA.', 'LOAD')
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
do ix=1 to words(intos)
in = word(intos, ix)
ln = mPar(in)
if mAtK1(in, 'INDDN') <> '' then
dn = mVaAtK1(in, 'INDDN')
else
dn = mVaAtK1(ln, 'INDDN')
dnDsn = mVaAtK1(dn, 'DSN')
chDsn = expDsn(in, dnDsn)
if dnDsn <> chDsn then do
dn = mAddTree(mRemCh(m.jclNdFr), dn)
call mPut dn, 'DSN', chDsn
end
vv = 'DSNLOAD'mVaAtK1(tn, 'tsPa')
newLo = expDsn(in, m.vv)
call jcl '2* Originales Loadfile Kopieren'
call jclCopy dn, dsNew2Tree(newLo, m.jclNdTo)
end
end
return
endProcedure jclGenCopyInput
/*--- generate the db2 utility statements for copy & unload ----------*/
jclGenPunch: procedure expose m.
parse arg tbRoot, puDsn
if m.mgmtClas == '' then
m.mgmtClasCl = ''
else
m.mgmtClasCl = 'MGMTCLAS('m.mgmtClas')'
call jcl '2* Neues Punchfile Kopieren'
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 's', 'SYSUT2', ds2Tree(puDsn, m.jclNdTo)
call jcl '20SYSUT1 DD *'
/* add a second copy template,
to avoid duplicate on the copy before/after */
call jcl '2 TEMPLATE TCOPYQ'
call jcl '2 ' ,
"DSN('&SSID..&DB..&SN..Q&PART(2)..D&DATE(3)..T&TIME.')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
call jcl '2 TEMPLATE TMLOADTS'
call jcl "2 DSN('"m.dsnLoadTS"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
call jcl '2 TEMPLATE TMLOADPA'
call jcl "2 DSN('"m.dsnLoadPA"')"
call jcl "2 DISP(SHR,KEEP,KEEP)"
xx = overlay(".UNLO", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULTS'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNLO", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNPU", m.dsnLoadTS, lastPos(".", m.dsnLoadTS))
call jcl '2 TEMPLATE TMULPUN'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A011)'
call jcl '2 SPACE (1,10) CYL'
do tx=1 to mSize(tbRoot)
tn = mAtSq(tbRoot, tx)
intos = mVaAtK1(tn, 'intos')
call jclGenPunchCopyUnload tn, tx
call jclGenPunchInto word(intos, 1), 0, tn
do ix=1 to words(intos)
in = word(intos, ix)
call jclGenPunchInto in, ix, tn
end
end
return
endProcedure jclGenPunch
/*--- generate utility copy and unload statement for table tn --------*/
jclGenPunchCopyUnload: procedure expose m.
parse arg tn, tx
parts = mVaAtK1(tn, 'parts')
paMin = word(parts, 1)
paMax = word(parts, words(parts))
dbTs = mVaAtK1(tn, 'db')'.'mVaAtK1(tn, 'ts')
if parts == '*' then do
call jcl '2 COPY TABLESPACE' dbTS 'FULL YES'
end
else do
call jcl '2 LISTDEF COLI'tx
call jcl '2 INCLUDE TABLESPACE' dbTs 'PARTLEVEL'
call jcl '2 COPY LIST COLI'tx 'FULL YES PARALLEL'
end
call jcl '2 COPYDDN (TCOPYQ) SHRLEVEL REFERENCE'
/* unload before */
call jcl '2 UNLOAD TABLESPACE' dbTS
if parts = '*' then
nop
else if paMin == paMax then
call jcl '2 PART' paMin
else
call jcl '2 PART' paMin ':' paMax
call jcl '2 FROM TABLE' mVaAtK1(tn, 'ow') ,
|| '.'mVaAtK1(tn, 'tb')
call jcl '2 PUNCHDDN TMULPUN UNLDDN TMUL'mVaAtK1(tn,'tsPa')
call jcl '2 SHRLEVEL REFERENCE'
return
endProcedure jclGenPunchCopyUnload
/*--- generate the db2 utility statements for 1 load or into ---------*/
jclGenPunchInto: procedure expose m.
parse arg in, ix, tn
pa = mVaAtK1(in, 'PART')
ln = mPar(in)
rs = mFirst('RESUME', 'NO', in, ln)
if rs = 'NO' then do
rsSp = 'RESUME NO REPLACE COPYDDN TCOPYD'
end
else do
rsSp = 'RESUME YES'
sh = mFirst('SHRLEVEL', '', in, ln)
if sh <> '' then
rsSp = rsSp 'SHRLEVEL' sh
end
if ix == 0 then do
if pa == '*' then do
call jcl '3 LOAD DATA INDDN TMLOADTS'
call jcl '3 ' rsSp 'LOG' rs
if rs == 'NO' then
call jcl '3 STATISTICS TABLE(ALL)' ,
'INDEX(ALL) UPDATE ALL'
end
else do
call jcl '3 LOAD DATA LOG' rs
end
jn = mPar(in)
end
else do
call jcl '3 INTO TABLE' mVaAtK1(tn,'ow')'.'mVaAtK1(tn,'tb')
if pa <> '*' then do
call jcl '3 PART' pa
call jcl '3 ' rsSp
call jcl '3 INDDN TMLOADPA'
end
jn = in
end
do cx=1 to mSize(jn)
cn = mAtSq(jn, cx)
key = mKy(cn)
if key = '' then
call jcl '3 'm.cn
end
return
endProcedure jclGenPunchInto
/*--- jcl to run the db2 utility -------------------------------------*/
jclGenUtil: procedure expose m.
parse arg pun, dbSys
call jcl '4* db2 utility macht die Arbeit'
call jcl '42IF RC=0 THEN'
call jcl '4'jclExec() "PGM=DSNUTILB,PARM='"dbSys","userid()".UN.LO'"
call jcl '40SYSMAP DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSUT1 DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SORTOUT DD DISP=(,PASS),UNIT=SYSDA'
call jcl '40SYSERR DD SYSOUT=*'
call jcl '40SYSPRINT DD SYSOUT=*'
call jcl '40UTPRINT DD SYSOUT=*'
call jcl '40SYSTEMPL DD DISP=SHR,DSN='dbSys'.DBAA.LISTDEF(TEMPL)'
call jcl '40SYSIN DD DISP=SHR,DSN='pun
call jcl '42ENDIF'
return
endProcedure jclGenUtil
/*--- generate DSN for this id, with the given llq and index ---------*/
genDSN: procedure expose m.
parse arg dbTs, leLlq, lx
llq = leLLq || lx
if length(llq) > 8 then
llq = left(leLlq, 8 - length(lx)) || lx
if dbTs = '' then
return m.dsnPref || '.'m.id'.'llq
else
return m.dsnPref || '.'m.id'.'dbTs'.'llq
endProcedure genDSN
/*--- generate DSN for the src DS of the id, with member and index ---*/
genSrcDsn: procedure expose m.
parse arg mbr, lx
dsn = m.dsnPref'.'m.id'.SRC'
if mbr = '' then
return dsn
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')'
endProcedure genSrcDsn
/*--- expand variables in dsn from the into node in ------------------*/
expDsn: procedure expose m.
parse arg in, dsn
do forever
px = pos('&', dsn)
if px = 0 then
return dsn
dx = pos('.', dsn, px+1)
if dx <= px then
call err 'no . after & in' dsn
k = translate(substr(dsn, px+1, dx-px-1))
if k = 'DB' then
v = mVaAtK1(m.in, 'db')
else if k = 'PART' | k = 'PA' then
v = mVaAtK1(in, 'PART')
else if k = 'TS' | k = 'SN' then
v = mVaAtK1(m.in, 'ts')
else
call err 'bad variable' k 'in' dsn
dsn = left(dsn, px-1) || v || substr(dsn,dx+1)
end
endProcedure expDsn
/*--- transform the dataset spec into a tree at node nd --------------*/
ds2tree: procedure expose m.
parse arg spec, nd
call mRemCh nd
upper spec
dsn = ''
do ix=1 by 1
w = word(spec, ix)
if w = '' then
leave
if abbrev(w, 'DSN(') then
dsn = substr(w, 5, length(w) - 5)
else if abbrev(w, 'VOLUME(') then
call mAddK1 nd, 'VOLUME', substr(w, 8, length(w) - 8)
else if dsn == '' then
dsn = w
end
if dsn ^= '' then
call mAddK1 nd, 'DSN', dsn
return nd
endProcedure ds2Tree
/*--- transform the spec for a new DS into a tree at node nd ---------*/
dsNew2tree: procedure expose m.
parse arg spec, nd
x = ds2Tree(spec, nd)
if m.mgmtClas <> '' then
call mPut x, 'MGMTCLAS', m.mgmtClas
return x
endProcedure dsNew2tree
/*--- jcl to copy a sequential DS ------------------------------------*/
jclCopy: procedure expose m.
parse arg fr, to
call jcl '2'jclExec() 'PGM=IEBGENER'
call jcl '20SYSPRINT DD SYSOUT=*'
call jcldd 2, 'o', 'SYSUT1', fr
if pos('(', mVaAtK1(to, 'DSN')) > 0 then
call jcldd 2, 's', 'SYSUT2', to
else
call jcldd 2,'nr', 'SYSUT2', to, fr
return
endProcedure jclCopy
/*--- generate a jcl dd statement
opt: n=new, s=shr, r=remove in first step
dd: ddname
nd: tree representation dataset spec
like: tree representation of like dataset ----------------------*/
jclDD: procedure expose m.
parse arg j, opt, dd, nd, like
new = pos('n', opt) > 0
li=left('0'dd, 12)'DD'
if new then
li = li 'DISP=(NEW,CATLG,DELETE)'
else if pos('s', opt) > 0 then
li = li 'DISP=SHR'
else
li = li 'DISP=OLD'
do cx=1 by 1 to m.nd.0
ch = nd'.'cx
va = m.ch
ky = mKy(ch)
if wordPos(ky, 'DSN MGMTCLAS') > 0 then
li = jclDDClause(j, li, ky'='va)
else if ky == 'VOLUME' then
li = jclDDClause(j, li, 'VOL=SER=('va'),UNIT=DISK')
else
call err 'bad dd attribute' ky'='va
end
if like == '' then do
end
else if like == 'fb80' then do
li = jclDDClause(j, li, 'RECFM=FB,LRECL=80')
end
else do
if '' == mAtK1(like, 'VOLUME') then do
li = jclDDClause(j, li, 'LIKE='mVaAtK1(like, 'DSN'))
end
else do
aa = jcl2dsn(mVaAtK1(like, 'DSN')) ,
'VOLUME('mVaAtK1(like, 'VOLUME')')'
lRc = listDsi(aa)
if lRc <> 0 then
call err 'rc' lRc from 'listDsi' aa
if sysUnits = 'CYLINDER' then
u = 'CYL'
else if sysUnits = 'TRACK' | sysUnits = 'BLOCK' then
u = left(sysUnits, 2) || 'K'
else
call err 'bad sysunits from listDsi:' sysUnits
li = jclDDClause(j, li, 'SPACE=('u',('sysPrimary',' ,
|| sysSeconds'))')
li = jclDDClause(j, li, 'RECFM='sysRecFm)
end
end
call jcl j || li
if new & pos('r', opt) > 0 then
call jclRemove nd
return
endProcedure jclDD
/*--- add a DS to the remove step ------------------------------------*/
jclRemove: procedure expose m.
parse arg nd
m.jclRemove = m.jclRemove + 1
li = left('0RM'm.jclRemove, 12)'DD DISP=(MOD,DELETE,DELETE)'
li = jclDDClause(1, li, 'DSN='mVaAtK1(nd, 'DSN'))
call jcl '1'li
return
endProcedure jclRemove
/*--- add one clause to a jcl dd statement
if the line overflows write it out
return rest of line ---------------------------------------*/
jclDDClause: procedure expose m.
parse arg j, li, cl
if left(li, 1) = '6' then
a = 15
else
a = 1
if a + length(li) + length(cl) < 70 then
return li','cl
call jcl j || li','
return '6'cl
endProcedure jclDDClause
/*--- generate an exec statement -------------------------------------*/
jclExec: procedure expose m.
m.jclStep = m.jclStep + 1
return left('0S'm.jclStep, 10)'EXEC'
endProcedure jclExec
/*--- initialize jcl generator ---------------------------------------*/
jclIni: procedure expose m.
m.jclCard.0 = 9
do x=1 to m.jclCard.0
m.jclCard.x.0 = 0
end
m.jclRemove=0
m.jclStep = 0
m.jclPref.0 = '//'
m.jclPref.2 = left('//', 11)
m.jclPref.4 = left('//', 13)
m.jclPref.6 = left('//', 15)
xx = ' '
m.jclPref.xx = ''
xx = '*'
m.jclPref.xx = '//*'
m.jclNdFr = mRoot()
m.jclNdTo = mRoot()
return
endProcedure jclIni
/*--- output one jcl line:
j (char 1): which stem
t (char 2): prefix
m (char 3 to end): message ----------------------------------*/
jcl: procedure expose m.
parse arg j 2 t 3 m
if m.orderTS & j > 2 then
j = 2
x = m.jclCard.j.0 + 1
m.jclCard.j.0 = x
if m.debug then
if symbol('m.jclPref.t') <> 'VAR' then
call err undefined jclPref for t 'in' j || t || m
m.jclCard.j.x = m.jclPref.t || strip(m, 't')
if m.debug then
say 'jcl'j m.jclCard.j.x
return
endProcedure jcl
/*--- add one line text to the stem m.st -----------------------------*/
/*--- copy a DS in tso -----------------------------------------------*/
copyDS: procedure
parse arg fj fa, tj ta
say 'copyDs from' fj fa 'to' tj ta
call adrTso 'free dd(sysut1)', '*'
call adrTso 'alloc dd(sysut1) shr dsn('jcl2dsn(fj)')' fa
call adrTso 'free dd(sysut2)', '*'
call adrTso 'delete' jcl2dsn(tj), '*'
call adrTso 'alloc dd(sysut2) new catalog refdd(sysut1)' ,
'dsn('jcl2dsn(tj)')' ta
call adrTso 'alloc dd(sysin) dummy reuse'
call adrTso 'alloc dd(sysprint) sysout(T) reuse'
/* call iebGener */
CALL ADRTSO 'CALL *(IEBGENER)', '*'
say 'iebGener rc' rc 'result' result
call adrTso 'free dd(sysin sysprint sysut1 sysut2)'
return
endProcedure copyDS
/* treeCopy : make a copy of a reader to a tree ***********************/
treeCopyLine: procedure expose m.
parse arg m, nx
if ^m.treeCopy.m.read then
return
if nx > length(m.treeCopy.m.line) then
qx = length(m.treeCopy.m.line)
else
qx = nx - 1
if m.treeCopy.m.on then do
le = left(m.treeCopy.m.line, qx)
if le <> '' then
call mAddKy m.treeCopy.m.dest, , le
end
m.treeCopy.m.line = overlay('', m.treeCopy.m.line, 1, qx)
return
endProcedure treeCopyLine
treeCopyDest: procedure expose m.
parse arg m, m.treeCopy.m.dest
return
endProcedure treeCopyDest
/*--- start copying at character nx of current line ------------------*/
treeCopyOn: procedure expose m.
parse arg m, nx
if m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 1
return
endProcedure treeCopyOn
/*--- stop copying at character nx of current line -------------------*/
treeCopyOff: procedure expose m.
parse arg m, nx
if ^ m.treeCopy.m.on then
return
call treeCopyLine m, nx
m.treeCopy.m.on = 0
return
endProcedure treeCopyOff
treeCopyRead: procedure expose m.
parse arg m, rdr, var
call treeCopyLine m, 1 + length(m.treeCopy.m.line)
m.treeCopy.m.read = ooRead(rdr, var)
m.treeCopy.m.line = m.var
return m.treeCopy.m.read
endProcedure treeCopyRead
treeCopyOpen: procedure expose m.
parse arg m, rdr, m.treeCopy.m.dest, isOn
call ooDefRead m, 'res = treeCopyRead("'m'", "'rdr'", var);'
m.treeCopy.m.read = 0
m.treeCopy.m.on = isOn = 1
return m
endProcedure treeCopyOpen
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
m.scan.m.utilBrackets = 0
return m
endProcedure scanUtilReader
/*--- scan next token and put its type in m.utilType:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
call scanSpaceNl sc
ty = '?'
if scanLit(sc, '(') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.scan.sc.utilBrackets = m.scan.sc.utilBrackets - 1
if m.scan.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.val = translate(m.tok)
if m.scan.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.val, 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD') then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.val = translate(m.tok)
end
else if ^scanAtEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
/* say 'scanUtil return atEnd' */
ty = ''
m.val = ''
end
if ty == '?' then
m.utilType = left(m.tok, 1)
else
m.utilType = ty
return m.utilType
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc
if '(' ^== scanUtil(sc) then
return scanUtilValueOne(sc)
v = ''
brx = m.scan.sc.utilBrackets
do forever
call scanUtil sc
one = scanUtilValueOne(sc)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.scan.sc.utilBrackets then
return v
v = v || one
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc
if utilType == '' then
return ''
else if m.utilType == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
else if pos(m.utilType, 'nv''"') > 0 then
return m.val
else
return m.tok
endProcedure scanUtilValueOne
/* copy scanUtil end **************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
lmmRmMbr: procedure
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
/**********************************************************************
adr*: address an environment
***********************************************************************/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy 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
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 scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line
scanStem(m,ln) : begin scanning all lines in a stem
scanAtEOL(m) : returns whether we reached end of line
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
scanNum(m) : scan integer (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
call scanStart m
return
endProcedure scanLine
/*--- begin scanning the lines of a stem -----------------------------*/
scanReader: procedure expose m.
parse arg m, inRdr
call scanStart m, inRdr
m.scan.m.src = ''
m.scan.m.atEnd = ^ scanNL(m, 1)
return m
endProcedure scanReader
/*--- switch to next line if atEOF or argument unCond=1 --------------*/
scanNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then
m.scan.m.pos = 1 + length(m.scan.m.src)
else if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 0
else if ^ ooRead(m.scan.m.reader, 'SCAN.'m'.SRC') then do
m.scan.m.atEnd = 1
return 0
end
m.scan.m.pos = 1
m.scan.m.tok = ''
return 1
endProcedure scanNL
/*--- initialize scanner for m --------------------------------------*/
scanStart: procedure expose m.
parse arg m, m.scan.m.reader
m.scan.m.pos = 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 scanStart
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, comm
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanStart
if nameOne ^== '' then
m.scan.m.Name1 = nameOne
if nameOne ^= '' | namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
m.scan.m.comment = comm
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if m.scan.m.reader = '' then
return 1
else
return m.scan.m.atEnd
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: 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
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 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 number --------------------------------------------------*/
scanNum: 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 scanNum
/*--- 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 *.key and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(scanSkip(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
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
call err 'scanErr' txt
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
cc = m.scan.m.comment
do forever
if scanVerify(m, ' ') then nop
else if scanNL(m) then nop
else if cc == '' then leave
else if ^ scanLit(m, cc) then leave
else if ^scanNL(m, 1) 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
/* copy scan end ****************************************************/
/* copy ooDiv begin ****************************************************
***********************************************************************/
readDsnOpen: procedure expose m.
parse arg oid, spec
x = dsnAlloc(spec, 'SHR', 'RE'oid)
dd = word(x, 1)
call readDDBegin dd
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
readCatOpen: procedure expose m.
parse arg oid, src
if symbol("m.oo.oid.readCatOid") ^= 'VAR' then
m.oo.oid.readCatOid = ooNew()
catOid = m.oo.oid.readCatOid
ox = 0
do ix=2 to arg()
s = arg(ix)
do while s <> ''
ex = pos('$', s)
if ex > 0 then do
w = strip(left(s, ex-1))
s = substr(s, ex+1)
end
else do
w = strip(s)
s = ''
end
if w ^= '' then do
ox = ox + 1
m.oo.oid.readCat.ox = w
end
end
end
m.oo.oid.readCat.0 = ox
m.oo.oid.readCatIx = 0
call ooDefRead catOid, 'res=0'
return ooDefRead(oid, 'res = readCat("'oid'", var);',
, 'call readCatClose "'oid'";')
endProcedure readCatOpen
readCat: procedure expose m.
parse arg oid, var
catOid = m.oo.oid.readCatOid
do forever
if ooRead(catOid, var) then
return 1
catIx = m.oo.oid.readCatIx + 1
if catIx > 1 then
call ooReadClose catOid
if catIx > m.oo.oid.readCat.0 then
return 0
m.oo.oid.readCatIx = catIx
src = m.oo.oid.readCat.catIx
if left(src, 1) = '&' then
call ooReadStemOpen catOid, strip(substr(src, 2))
else
call readDsnOpen catOid, src
end
endProcedure readCat
readCatClose: procedure expose m.
parse arg oid
if m.oo.oid.readCatIx > 0 then
call ooReadClose m.oo.oid.readCatOid
return
endProcedure readCatClose
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
call ooIni
/* ri = readDsnOpen(ooNew(), 'wk.text(testin)') */
call ooArgs2Stem aaa, 1, 'aaa.1 eins', 'aaa.2 zwei', 'aaa.3 drei'
ri = readCatOpen(ooNew(), "&AAA $ wk.text(testin) ",,'&' aaa,
, 'wk.text(msk1) $ &AAA')
do i=1 by 1 while ooRead(ri, line)
say 'line' i strip(m.line, 't')
end
call ooReadClose ri
exit
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
ooNew: procedure expose m.
m.oo.lastId = m.oo.lastId + 1
return m.oo.lastId
endProcedure newoo
ooFree: procedure expose m.
parse arg id
return
endProcedure ooFree
ooRead: procedure expose m.
parse arg oid, var
res = '?'
interpret m.oo.oid.read
return res
endProcedure ooRead
ooReadClose: procedure expose m.
parse arg oid
stem = ''
interpret m.oo.oid.readClose
m.oo.oid.read = 'res=0'
m.oo.oid.readClose = ''
return
endProcedure ooReadClose
ooDefRead: procedure expose m.
parse arg oid, m.oo.oid.read, m.oo.oid.readClose
return oid
endProcedure ooDefRead
ooDefReadStem: procedure expose m.
parse arg oid, m.oo.oid.readStem, close
m.oo.oid.0 = 0
m.oo.oid.readStemCx = 0
return ooDefRead(oid, 'res = ooReadStem2Ln("'oid'", var);', close)
endProcedure ooDefReadStem
ooReadStem2Ln: procedure expose m.
parse arg oid, v
cx = m.oo.oid.readStemCx
if cx >= m.oo.oid.0 then do
res = '?'
stem = 'OO.'oid
m.stem.0 = 0
m.oo.oid.stCx = 0
interpret m.oo.oid.readStem
if ^ res then
return 0
else if m.stem.0 < 1 then
call err 'stem.0='m.stem.0 'after 1 from' m.oo.oid.readStem
cx = 0
end
cx = cx + 1
m.v = m.oo.oid.cx
m.oo.oid.readStemCx = cx
return 1
endProcedure ooReadStem2Ln
ooReadStemOpen: procedure expose m.
parse arg oid, stem
call ooDefReadStem oid, 'res = 0;'
do ix=0 by 1 to m.stem.0
m.oo.oid.ix = m.stem.ix
end
m.oo.oid.0 = m.stem.0
return oid
endProcedure ooReadStemOpen
ooReadArgsOpen: procedure expose m.
parse arg oid, ox
call ooDefReadStem oid, 'res = 0;'
if ox = '' then
ox = m.oo.oid.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.oo.oud.ox = arg(ax)
end
m.oo.oid.0 = ox
return oid
endProcedure ooReadArgsOpen
ooArgs2Stem: procedure expose m.
parse arg stem, ox
if ox = '' then
ox = m.stem.0
else
ox = ox - 1
do ax=3 by 1 to arg()
ox = ox + 1
m.stem.ox = arg(ax)
end
m.stem.0 = ox
return stem
endProcedure ooArgs2Stem
/* copy oo 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', "'")
else if sysvar('SYSPREF') = '' | addPrefix = 0 then
return dsn
else
return sysvar('SYSPREF')'.'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
m.dsnAlloc.dsn = ''
if left(spec, 1) = '=' then
return strip(substr(spec, 1))
addPref = pos('~', spec) > 0
if addPref then
spec = strip(spec, 'b', '~')
do wx=1 to 3
w = word(spec, wx)
if w = '' then
leave
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if m.dsnAlloc.dsn = '' then
m.dsnAlloc.dsn = dsn2jcl(w, addPref)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
if m.dsnAlloc.dsn <> '' then
disp = disp "dsn('"m.dsnAlloc.dsn"')"
call adrTso 'alloc dd('dd')' disp subword(spec, wx)
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
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 tree handling
***********************************************************************/
/*--- increase m.m and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg m, delta
if delta = '' then
m.m = m.m + 1
else
m.m = m.m + delta
return m.m
endProcedure mInc
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg m
return m.mKey.m
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg m
if symbol('m.m.0') == 'VAR' then
return m.m.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg m
dx = lastPos('.', m)
if dx <= 1 then
return ''
else
return left(m, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg m, Ky, val
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- add one or several values to stem m.m --------------------------*/
mAdd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
end
m.m.0 = ix
return m'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg m
ix = mSize(m)
do ax = 2 to arg()
ix = ix + 1
m.m.ix = arg(ax)
m.m.ix.0 = 0
end
m.m.0 = ix
return m'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.m -----------------------------*/
mAddKy: procedure expose m.
parse arg m, Ky, val
nn = mAddNd(m, val)
m.mKey.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg m, ky, val
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.mKey.nn = ky
m.mIndex.m.mKey.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg m, Ky, val
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
m.ch = val
return ch
end
else do
return mAddK1(m, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg m, ky
if symbol('m.mIndex.m.mKey.ky') == 'VAR' then
return m.mIndex.m.mKey.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg m, Ky
if symbol('m.mIndex.m.mKey.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' m
ch = m.mIndex.m.mKey.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
m = arg(ax)
if symbol('m.mIndex.m.mKey.Ky') == 'VAR' then do
ch = m.mIndex.m.mKey.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg m, seq
if symbol('m.m.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.mKey.ch
drop m.mIndex.pa.mKey.ky m.mKey.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.mKey.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.mKey.sCh
if symbol('m.mIndex.src.mKey.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg m
pa = mPar(m)
t = 'node' m 'pa='pa
if symbol('m.m') == 'VAR' then
t = t 'va='m.m
if symbol('m.m.0') == 'VAR' then
t = t 'size='m.m.0
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
t = t 'ky='ky
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t = t 'index='m.mIndex.pa.mKey.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg m, lv
if lv = '' then
lv = 0
t = left('', lv)m
if symbol('m.mKey.m') == 'VAR' then do
ky = m.mKey.m
pa = mPar(m)
if symbol('m.mIndex.pa.mKey.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.m, 't')
do cx=1 to mSize(m)
call mShow mAtSq(m, cx), lv+1
end
return
endProcedure treeShow
/* 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 *****************************************************/