zOs/REXX.O13/PLOAD
/* 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
************************************************************************
7. 9.2011 W. Keller: templates fuer Utility statt jcl alloc
************** end help ***********************************************/
/************* rest of history *****************************************
toDo: enforce no einfügen (und check anhängen?)
copy load stirbt mit b37 ==> manuell space Angaben einfügen
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
7. 9.2011 W. Keller: dsn <= 44 auf für maximal db, ts und parts
1.12.2009 W. Keller: inDDn nicht mehr nötig mit m.load <> ''
13.11.2009 W. Keller: orderTS Option funktioniert wieder
08.08.2008 W. Keller: orderTS Option eingefügt
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
call errReset 'h'
/* Info DSN spezifizieren - hier sind alle LOADS verzeichnet */
m.mainLib = 'DSN.pLoad.INFO' /* read configs from here| */
m.debug = 0 /* Debug Funktion ausschalten */
/* Programm Inputparameter (args) verarbeiten */
idN = '' /* idN = pload Nummer */
do wx = 1 to words(args) /* Anzahl Worte in args */
w = word(args, wx) /* w = Wort1,2 - wenn wx=1,2 */
if w = '?' then
call help
else if w = 'D' then /* Anschalten Debug Funktion */
m.debug = 1
else if verify(w, '0123456789') = 0 then
idN = w /* Wort in '0123456789' - NOMATCH = Default */
else
call errHelp 'bad argument "'w'" in' args
end
/* interpret mainOpt/userOpt */
call interDsn m.mainLib'(mainOpt)' /* m.mainlib = DSN.PLOAD.INFO */
/* überprüfen ob userOpt member existiert */
/* Wenn ja, hat dieses Priorität 1 */
userOpt = m.mainLib"("userId()")"
if sysDsn("'"userOpt"'") = 'OK' then /* dsn,member vorhanden? */
call interDsn userOpt /* m.mainlib = DSN.PLOAD.INFO */
/* get next ploadid (idN) */
if idN = '' then
idN = log('nextId') /* get next ploadid from log */
call genId idN /* idN = ploadid ohne N */
/* edit the options dataset with the data to be loaded */
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
call adrIsp "edit dataset('"m.optDsn"')", 4
/* pssss..... warten.... */
/* pssss..... warten.... */
/* pssss..... warten.... */
/* User hat PF3 gedrückt, weiter gehts... */
/* interpret options dataset */
call interDsn m.optDsn /* m.optDsn = DSN.PLOAD.N0186.SRC(OPTIONS) */
/* überprüfen ob Punchfile im Options Member spezifiziert wurde */
if m.punchList = '' then /* m.punchlist aus MAINOPT Member */
call errHelp 'no punch files specified in m.punchList'
call init
m.volume = strip(m.volume) /* m.volume aus MAINOPT Member */
vol = ''
if m.volume <> '' then
vol = 'volume('m.volume')' /* default value aus mainopt */
/* member, anonsten BLANK */
/* Wenn orderts = 1, dann erst alle copy und unloads
und erst nachher loads,
wenn SONST wegen Referential Integrity TS check pending werden
geht weder copy noch unload */
if m.orderts \= 0 then
m.orderts = 1
do wx=1 to words(m.punchList) /* analyze all punchfiles */
/* 1.Punchfile, dann word = 1 */
/* 2.Punchfile, dann word = 2 */
w = word(m.punchList, wx) /* save current punshfile dsn in w */
call debug 'analyzing punchfile' w vol
/* if m.debug=1 - say xxxxx */
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 /* set m.oo.lastId= 1 */
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
/*--- Adress SQL -----------------------------------------------------*/
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
/*--- SQL Connect ----------------------------------------------------*/
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
/*--- SQL Disconnect -------------------------------------------------*/
adrSqlDisconnect: procedure
parse arg ggRet
call adrSql "disconnect ", ggRet, 1
return
endProcedure adrSqlDisconnect
/*--- Write SQLCA ----------------------------------------------------*/
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
/*--- cleanup at end of program and disconnect from DB2 --------------*/
finish: procedure expose m.
call adrSqlDisconnect
return
endProcedure finish
/*--- generate a SRC datatset for the created ploadid ----------------*/
/*--- Members are PUNCH and OPTIONS ----------------*/
genId: procedure expose m.
parse arg iNum /* iNum = idN (ploadid ohne N) */
m.id = 'N'right(iNum, 4, 0) /* m.id = Nnnnn, e.g N0125 */
/* return punch dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC(PUNCH) */
puDsn = genSrcDsn("PUNCH")
/* format dsn from jcl format to tso format */
puSta = sysDsn(jcl2dsn(puDsn))
if puSta = 'OK' then do /* punch dataset existiert bereits */
say 'Job wurde bereits gestartet, und hat Daten erstellt'
say 'Weiterarbeit kann diese Daten überschreiben'
say 'enter WEITER, falls Sie das wollen'
parse upper pull ans
if ans ^== 'WEITER' then
call err 'Weiterarbeit abgebrochen'
end
else if puSta ^= 'DATASET NOT FOUND' & puSta ^= 'MEMBER NOT FOUND',
then do
call err 'bad sysDsn result' puSta 'for' puDsn
end
/* return options dsn name but do not create it */
/* e.g. lib = DSN.PLOAD.N0187.SRC */
lib = genSrcDsn()
/* e.g. lib = DSN.PLOAD.N0187.SRC(OPTIONS) */
m.optDsn = genSrcDsn('OPTIONS')
/* format dsn from jcl format to tso format */
libSta = sysdsn(jcl2dsn(m.optDsn))
if libSta = 'DATASET NOT FOUND' then do
if m.mgmtClas <> '' then /* m.mgmtClas aus MAINOPT Member */
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: contains 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 mAdd 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
/* write new OPTIONS member */
call writeDsn m.optDsn, m.op.
return
endProcedure writeOptions
/*--- interpret the given dsn ----------------------------------------*/
/* DSN.PLOAD.INFO(MAINOPT) */
/* DSN.PLOAD.INFO(userid()) */
/* DSN.PLOAD.INFO(OPTIONS) */
interDsn: procedure expose m.
parse arg dsn /* procedure input variable
in dsn ablegen */
call debug 'interpreting' dsn /* if m.debug=1 - say xxxxx */
call readDsn dsn, x. /* read dataset */
/* concat all the lines */
/* seperate them when a ; was found */
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 /* if m.debug=1 - say xxxxx */
return
endProcedure interDsn
/*--- get the next ploadid from DSN.PLOAD.INFO(LOG) -----------------*/
/*--write the next ploadid into DSN.PLOAD.INFO(LOG) -----------------*/
log: procedure expose m.
parse arg fun /* fun = 'nextId' or 'load' */
dsn = m.mainLib'(LOG)'
call readDsn dsn, l. /* read dataset */
zx = l.0 /* Anzahl lines in dsn */
cId = m.id /* next ploadid */
/* für fun = 'load' */
/* next ploadid reservieren */
if fun = 'nextId' then do
id = strip(left(l.zx, 8)) /* ploadid aus log member */
/* pos1-8, e.g. N0125 */
if left(id, 1) ^== 'N',
| verify(substr(id, 2), '0123456789') > 0 then
/* | = ODER Verknüpfung */
call err 'illegal id "'id'" in line' zx 'of' dsn
cId = 'N'right(1 + substr(id, 2), 4, '0')
/* max ploadid + 1 e.g. max=N0192, next=N0193 */
zx = zx + 1
/* max line dsn + 1 */
l.zx = left(cId, 8) date('s') left(time(), 5) 'newId'
/* l.zx = N0192 20081112 11:29 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 /* fun <> 'nextId' or 'load' */
call err 'bad log fun' fun
end
/* write new ploadid in LOG member */
call writeDsn dsn, l., zx /* DSN.pLoad.INFO(LOG) L. 163 */
return substr(cId, 2) /* return next ploadid ohne N */
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
/* w vol, m.treeLd, m.treePn */
pu = readDsnOpen(ooNew(), puDsn) /* open (alloc) punchfile */
/* ooNew() = increment m.oo.lastId (initialised by ooInit proc.) */
/* ooNew() = save punchfile in tree structure. */
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)
/* if m.debug=1 - say xxxxx */
end
else do
call debug 'template chunck' m.utilType m.tok
/* if m.debug=1 - say xxxxx */
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 do
if m.load = '' then
call err 'no inDDN for' info
loDdn = overrideLoad(mAddK1(ld, 'INDDN'))
end
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
/* if m.debug=1 - say xxxxx */
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
/* if m.debug=1 - say xxxxx */
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
/* if m.debug=1 - say xxxxx */
end
old.oOw.oTb = nd
call debug 'map old tb' oOw'.'oTb 'to' nOw'.'nTb 'nd' nd
/* if m.debug=1 - say xxxxx */
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
/* if m.debug=1 - say xxxxx */
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.', 'LOA')
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 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#A045)'
call jcl '2 SPACE (10,250) CYL'
xx = overlay(".UNL", m.dsnLoadPA, lastPos(".", m.dsnLoadPA))
call jcl '2 TEMPLATE TMULPA'
call jcl "2 DSN('"xx"')"
call jcl '2 DATACLAS (NULL12) MGMTCLAS(COM#A045)'
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#A045)'
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 (TCOPYD) 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)
call jcl '3 SORTDEVT DISK'
call jcl '3 WORKDDN(TSYUTD,TSOUTD)'
call jcl '3 ERRDDN TERRD MAPDDN TMAPD'
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)',
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SYSUT1 DD DISP=(,PASS)',
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SORTOUT DD DISP=(,PASS)' ,
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005,'
call jcl '46SPACE=(CYL,(1000,5000))'
call jcl '40SYSERR DD DISP=(,PASS)' ,
|| ',DATACLAS=ENN35,MGMTCLAS=COM#E005'
*/ 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 /* mbr = PUNCH oder OPTIONS */
dsn = m.dsnPref'.'m.id'.SRC' /* e.g.dsn = DSN.PLOAD.N0181.SRC */
/* m.dsnpref aus MAINOPT Member */
if mbr = '' then
return dsn /* e.g.dsn = DSN.PLOAD.N0181.SRC */
m = mbr || lx
if length(m) > 8 then
m = left(mbr, 8 - length(lx)) || lx
return dsn'('m')' /* DSN.PLOAD.N0185.SRC(PUNCH) */
/* DSN.PLOAD.N0185.SRC(OPTIONS) */
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 do
if length(dsn) > 44 then
call err 'dsn too long' dsn
return dsn
end
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
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 *************************************************/
/**********************************************************************
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 ****************************************************
***********************************************************************/
/* File einlesen, z.B. PUNCHFILE */
readDsnOpen: procedure expose m.
parse arg oid, spec
/* oid = ooNew(), spec = punchfile(volume) */
x = dsnAlloc(spec, 'SHR', 'RE'oid)
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* x = RE2 call adrTso "free dd(RE2)"; */
dd = word(x, 1)
/* dd = RE2 */
return ooDefReadStem(oid, 'res = readDD('dd', "M."stem".")',
, 'call readDDEnd' dd';' subword(x, 2))
endProcedure readDsnOpen
/* copy ooDiv end ***************************************************/
/* copy oo begin ******************************************************/
/* m.oo.lastid = 1 */
ooIni: procedure expose m.
m.oo.lastId = 1
return
endProcedure ooIni
/* m.oo.lastid inkrementieren */
/* m.oo.lastid = neue adresse (objekt) erstellen */
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
/* nächste Zeile einlesen */
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
/*--- 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: readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- 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 (member) ----------------------------------*/
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
/*--- read dsn, e.g. DSN.PLOAD.INFO(MAINOPT) -------------------------*/
readDSN:
parse arg ggDsnSpec, ggSt
/* DSN.PLOAD.INFO(MAINOPT), ggSt = X.
DSN.PLOAD.INFO(LOG) , ggSt = L. */
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
/* READDSN */ /* X. or L. */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
/* ggAlloc,2 = call adrTso "free dd(READDSN)"; */
return
endSubroutine readDsn
/*--- write dsn, e.g. DSN.PLOAD.INFO(LOG) ----------------------------*/
/*--- write dsn, e.g. DSN.PLOAD.INFO(OPTIONS) ------------------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
/* DSN.PLOAD.INFO(LOG) , ggSt = L., ggCnt = maxline + 1
DSN.PLOAD.INFO(OPTIONS), ggSt = m.op, ggCnt = ''
ggsay = wie m.debug = 1 */
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
/* dsnAlloc = Procedure zum anlegen/öffnen von datasets */
/* ggAlloc = READDSN call adrTso "free dd(READDSN)"; */
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)' /* READDSN */
/* L. or m.op */
interpret subword(ggAlloc, 2) /* interpret = Befehl ausführen
subword = Wörter ab Pos2
von ggAlloc */
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
***********************************************************************/
/*--- 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 /* m = ROOT, Ky = ROOT */
if m == '' then
m = 'mRoot.' || mIncD('mRoot.0')
m.m = val
m.mKey.m = Ky
m.m.0 = 0
return m
endProcedure mRoot
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg m, delta /* m = ROOT, delta = '' */
if symbol('m.m') <> 'VAR' then
m.m = 0
return mInc(m)
endProcedure mIncD
/*--- 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
/*--- 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
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out '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
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if symbol('m.out.ini') == 1 then
return
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/