zOs/REXX.O08/CHECKRTS
/* REXX */
/******************************************************************/
/* CHECKRTS */
/* -------- */
/* */
/* 1 function: db2 real time statistics für reorg anwenden: */
/* 1. preview der listdefs einlesen */
/* 2. listdefs einlesen */
/* 3. rts abfragen */
/* 4. neue listdef erstellen */
/* */
/* 2 history: */
/* 25.10.2004 v1.0 grundversion (m.streit,A234579) */
/* 16.09.2005 v1.1 inkl.reorg index ohne rts (A234579) */
/* 20.09.2005 v1.2 erweiterte abfrage auf noload repl */
/* 23.09.2005 v2.0 index mit rts-abfrage (A234579) */
/* 10.11.2005 v2.1 schwellwerte erweitert (A234579) */
/* 10.04.2006 v2.2 pgm läuft auch ohne ispf (A234579) */
/* Diagnose Statement erlaubt (A234579) */
/* 20.11.2006 v2.21 RSU0610 bewirkt Meldung: */
/* 'insuff. operands for keyword listdef'*/
/* Neu wird leeres Member erstellt falls */
/* keine Objekte die Schwellwerte erreich*/
/* 04.12.2006 v2.3 Optimierung mit Gruppenbruch-Logik */
/* 10.04.2008 v4.0 Umstellung auf neue exception tabl/vws*/
/* 20.05.2008 v4.1 Bereinigung */
/* 21.08.2008 v4.2 vRtsReoIx.cr (statt .Creator) fuer V9 */
/* 08.09.2008 v4.3 vRtsReoIx.is fuer Indexspace */
/* (nicht null bei fehlenden rts Daten) */
/* */
/* 3 usage checkrts programm(rexx) */
/* S100447.vRtsReoTS db2 ts part Grenzwerte */
/* S100447.vRtsReoIX db2 ix part Grenzwerte */
/* */
/* 4 parms checkrts <parm1> <parm2> */
/* parm1 = db2 subsystem */
/* parm2 = type ts or ix */
/* */
/* 5 location tso.rzx.p0.user.exec */
/* */
/******************************************************************/
m.debug = 0
parse upper arg ssid type fun
if 0 & ssid = '' then /* für online test */
parse upper value 'DBTF TS TEST' with ssid type fun
say "CheckRts Programmversion = 4.3"
say " DB2 Subsystem = "ssid
if type = '' then do
type = 'TS'
say " kein Type gewählt, also TS-Reorg getriggert"
end
say " Type = "type
call errReset 'h'
call mapIni
call sqlIni
call sqlConnect ssid
/*-------------- Hauptprogramm -----------------------------------*/
if fun = '' then
call doCheckRts type, '-ddIn1', '-ddIn2', dsn4allocated('ddOUt1')
else if fun = 'TEST' then
call testCheckRts type
else if fun = 'T0' then
call testRT0 ssid type
else
call err 'bad fun' fun 'in Argumenten' arg(1)
call sqlDisconnect
exit
testRT0: procedure expose m.
parse arg ssid type
MBR=QR04412
MBR=QR57101
call adrTso "alloc dd(ddIn1) shr" ,
"dsn('A540769.CHECKRTS.SYSPRINT("MBR")')"
call adrTso "alloc dd(ddIn2) shr" ,
"dsn('"ssid".DBAA.LISTDEF("MBR"1)')"
/* "dsn('A540769.CHECKRTS.LISTDEF("MBR"1)')" */
call adrTso "alloc dd(ddOut1) shr" ,
"dsn('A540769.CHECKRTS.OLI"type"NEW("MBR")')"
if 1 then do /* neu */
call doCheckRts type, '-ddIn1', '-ddIn2',
, dsn4allocated('ddOUt1')
end
else do /* alt */
call checkRt0 ssid type
say 'checkRt0 rc' rc
end
call adrTso 'free dd(ddIn1 ddIn2 ddOut1)'
return
endProcedure testRT0
testCheckRts: procedure expose m.
parse arg type
mbrs = 'QR04412 QR03202 QR20801'
mbrs = 'QR04412'
mbrs = QR30403
mbrs = QR06801
do mx=1 to words(mbrs)
mb = word(mbrs, mx)
say 'member' mb '**********'
call doCheckRts type, '~checkrts.sysprint('mb')',
, 'DBTF.DBAA.listDef('mb'1)',
, '~checkrts.output('mb')'
/* , '~checkrts.listDef('mb'1)' */
end
return
endProcedure testCheckRts
/*--- main function
analyse utility preview sysprint
analyse utitlity listdef input
check rts
generate new utility ctrl cards ----------------------------*/
doCheckRts: procedure expose m.
parse arg type, ddIn1, ddIn2, ddOut
call mapReset lst, 'K'
call analyzeSysprint lst, ddIn1
call debugLst lst, 'lists in sysprint'
call mapReset ctl, 'K'
call analyzeListdef ctl, ddIn2
call debugListdef ctl
call mapReset rl, 'K'
kk = mapKeys(ctl)
typ1 = left(type, 1)
do kx=1 to m.kk.0
listName = m.kk.kx
if ^ mapHasKey(lst, listName) then do
say '*** warning' listName 'in ListDef,',
'aber nicht im SysPrint (leer?)'
end
else if word(m.lst.listName, 1) ^== typ1 then do
call debug 'list' listName '->' m.lst.listName ,
'nicht type' type 'wird ignoriert'
end
else do
call mapPut rl, listName
call mapReset rl'.'listName, 'K'
call selectRts rl'.'listName, lst'.'listName, type
lstKeys = mapKeys(lst'.'listName)
rtsKeys = mapKeys(rl'.'listName)
if m.lstKeys.0 <> m.rtsKeys.0 then
call err 'Liste' listName 'Anzahl Objekte:',
'sysPrint' m.lstKeys.0 '<> rts' m.rtsKeys.0
end
end
call debugLst rl, 'lists rts selection'
call genCtrl ddOut, rl, type, ctl
return
endProcedure doCheckRts
/*--- generate utiltity ctrl cards for run
ddOut: output dd spec to write ctrl to
all: map of partitions to reorg
type: TS or IX
ctl: input ctrl cards ------------------------------------*/
genCtrl: procedure expose m.
parse arg ddOut, all, type, ctl
if type = 'TS' then
ldType = 'TABLESPACE'
else if type = 'IX' then
ldType = 'INDEXSPACE'
else
call err 'bad type' type
m.o.1 = ' -- checkRts' date('s') time()
m.o.0 = 1
kk = mapKeys(all)
do kx = 1 to m.kk.0
lst = m.kk.kx
call mAdd o, m.lstCount.lst
oStart = m.o.0
lstKeys = mapKeys(all'.'lst)
do lx=1 to m.lstKeys.0
ob = m.lstKeys.lx
rng = mapGet(all'.'lst, ob)
do rx=1 to words(rng)
parse value word(rng, rx) with von '-' bis
if bis = '' then
bis = von
do pa=von to bis
if pa = 0 then
paLe = ''
else
paLe = 'PARTLEVEL('pa')'
call mAdd o, ' INCLUDE' ldType ob paLe
end /* do pa */
end /* do rx */
end /* do ob */
if m.o.0 = oStart then do
m.o.0 = oStart - 1
end
else do
st = ctl'.'lst
do s1=1 to m.st.0
call mAdd o, ' -- utility' s1 'for' lst
do s2=1 to m.st.s1.0
call mAdd o, strip(m.st.s1.s2, 't')
end
end
end
end /* do lst */
call writeDsn ddOut, 'M.'o'.', ,0
return
endProcedure genCtrl
/*--- debug a listDef ------------------------------------------------*/
debugListDef: procedure expose m.
parse arg lst, tit
if m.debug ^== 1 then
return
call debug tit
kk = mapKeys(lst)
do kx=1 to m.kk.0
call debug 'list' m.kk.kx
st = lst'.'m.kk.kx
do s1=1 to m.st.0
do s2=1 to m.st.s1.0
call debug ' ' st'.'s1'.'s2 strip(m.st.s1.s2, t)
end
end
end
return
endProcedure debugListDef
/*--- debug a list ---------------------------------------------------*/
debugLst: procedure expose m.
parse arg lst, tit
if m.debug ^== 1 then
return
call debug tit
k1 = mapKeys(lst)
do kx=1 to m.k1.0
call debug 'list' m.k1.kx '-->' mapGet(lst, m.k1.kx)
call debugMap lst'.'m.k1.kx, ' '
end
return
endProcedure debugLst
/*--- debug a map ----------------------------------------------------*/
debugMap: procedure expose m.
parse arg mp, pr
if m.debug ^== 1 then
return
kk = mapKeys(mp)
do kx=1 to m.kk.0
k2 =
call debug pr m.kk.kx '->' mapGet(mp, m.kk.kx)
end
return
endProcedure debugMap
/*--- select the rts views and
put the partitions to reorg in the map slt -----------------*/
selectRts: procedure expose m.
parse arg slt, lst, type
if type = 'IX' then
sql = 'select db, is, cr, ix, part, reason,',
'real(totalEntries) rows,',
'real(nActive)*4*1024 act,',
'real(space)*1024 space' ,
'from S100447.vRtsReoIX' ,
'where' genWhere(word(m.lst, 1), lst)
else if type = 'TS' then
sql = 'select db, ts, db db2, ts ts2, part, reason,',
'real(totalRows) rows,',
'real(nActive)*pgSize*1024 act,',
'real(space)*1024 space' ,
'from S100447.vRtsReoTS' ,
'where' genWhere(word(m.lst, 1), lst)
else
call err 'selectRts type' type
call debug 'sql1' sql
gr = "case when left(reason, 3) = 'no' then 'NO'" ,
"when left(reason, 10) = 'reorgDays' then 'DAY'" ,
"else 'REO' end"
sql = "with s as ("sql")",
"select * from s" ,
"union all (select ' db', ' ts', 'cr', 'nm', -9," gr ",",
"sum(rows), sum(act), sum(space)",
"from s group by" gr ")",
"order by 1, 2, 5"
call debug 'sql2' sql
call sqlPreOpen 1, sql
act.day = 0
act.no = 0
act.reo = 0
act.sum = -99 /* in case no records fetched */
act.dLi = -99 /* in case no records fetched */
reoMax = .25 /* if we have to reorg more than this part
of the total size */
dayMin = .15 /* than reduce reorg of year old partititons
to that part of size */
dayCum = 0
reoCum = 0
actCalc = 1
drop sql o
feFi = sqlVars('M.O', 'DB TS CR NM PART REASON ROWS ACT SPACE', 1)
do while sqlFetchInto(1, feFi)
if left(m.o.db, 1) = ' ' then do
if ^ actCalc then
call err 'act space must be in beginning'
g = m.o.reason
if m.o.act ^== m.sql.null then
act.g = m.o.act
else
act.g = 1e7
iterate
end
if actCalc then do
actCalc = 0
act.sum = act.day + act.no + act.reo
/* compute the limit for old partitions */
act.dLi = max(act.sum * reoMax - act.reo, dayMin * act.day)
end
key = strip(m.o.db)'.'strip(m.o.ts)
pa = m.o.part + 0
if ^rangeIsIn(mapGet(lst, key), pa) then
call debug 'part' pa 'not in' key
else do
if left(m.o.reason, 3) == 'no ' then
f = 'ignoriere '
else if left(m.o.reason, 10) ^== 'reorgDays ' then do
if m.o.act ^== m.sql.null then
reoCum = reoCum + m.o.act
f = 'reorganisiere'
end
else if dayCum < act.dLi then do
if m.o.act ^== m.sql.null then
dayCum = dayCum + m.o.act
f = 'reorganisiere'
end
else /* over limit for old partitions */
f = 'spaeter '
if ^mapHasKey(slt, key) then
call mapPut slt, key, ''
if abbrev(f, 'r') then
call mapPut slt, key, rangeAdd(mapGet(slt, key), pa)
say f strip(m.o.cr)'.'strip(m.o.nm)||right(pa, 4) m.o.reason
end
end
say statsline('')
say statsLine('Space dieser Objekte')
say statsline(' nicht zu reorganisieren' , act.no)
say statsline(' zu reorganisieren wegen Schwellwerten' , act.reo)
say statsline(' zu reorganisieren da aelter als x Tage' , act.day)
say statsline('' , '=')
say statsLine(' Total' , act.sum)
say statsline('')
say statsLine('Space der generierten Reorgs')
say statsline(' generierte Reorgs wegen Schwellwerten' , reoCum)
say statsline(' generierte Reorgs da aelter als x Tage' , dayCum)
say statsline('' , '=')
say statsLine(' Total generierte Reorgs' , reoCum + dayCum)
say statsline('')
say statsline(' auf spaeter verschobene Reorgs' ,
, act.reo+act.day - reoCum - dayCum)
say statsline(' aelter als x Tage,')
say statsline(' da ueber berechneter Limite von')
say statsline(' ' asMB(act.dLi) 'MB =',
'max('asMB(act.sum) '*' reoMax '-' asMB(act.reo)',' ,
asMB(act.day) '*' dayMin')')
call sqlClose 1
return
endProcedure selectRts
statsLine: procedure expose m.
parse arg m1, by
r = left(m1, 50)
if by == '=' then
r = r || left('', 11, by)
else if by ^== '' then
r = r || right(asMB(by), 8) 'MB'
return r
endProcedure statsLine
asMB: procedure expose m.
parse arg by
return trunc(by/1024/1024 + .5, 0)
/*--- analyze sysprint of utility preview
put listelements in map lst -----------------------------*/
analyzeSysprint: procedure expose m.
parse arg lst, inp
call mapReset lst, 'K'
call readDsn inp, i1.
rx = 1
listName = ''
do while rx <= i1.0
if word(i1.rx, 1) == 'DSNU1020I' then do
ex = wordPos('EXPANDING', i1.rx)
listName = word(i1.rx, ex + 2)
if listName = '' | word(i1.rx, ex + 1) ^== 'LISTDEF' then
call err 'bad expanding line' i1.rx
call mapAdd lst, listName
call mapReset lst.listName, 'K'
rx = rx + 1
end
else if word(i1.rx, 1) == 'LISTDEF' then do
if listname ^== word(i1.rx,2) then
call err 'mismatch in list' listName 'line' i1.rx
m.lstCount.listName = strip(i1.rx)
types = ''
dbs = ''
do rx=rx+1 TO I1.0 while word(i1.rx, 1) = 'INCLUDE'
parse var i1.rx . obj db'.'ts prt
if wordPos(obj, 'TABLESPACE INDEXSPACE') < 1 then
call err 'bad obj type' obj 'in' i1.rx
ty = left(obj, 1)
if types == '' then
types = ty
else if types ^== ty then
call err 'Liste' lst 'mit verschiedene Types' i1.rx
if wordPos(db, dbs) < 1 then
dbs = dbs db
parse var prt 'PARTLEVEL(' part ')'
if part = '' then
part = 0
else
part = part + 0
ky = db'.'ts
if mapHasKey(lst'.'listName, ky) then
call mapPut lst'.'listName, ky,
, rangeAdd(mapGet(lst'.'listName, ky), part)
else
call mapPut lst'.'listName, ky, part
/* say ky '+' part '->' mapGet(lst'.'listName, ky)
*/ end
say 'sysprint list' listName types dbs
call mapPut lst, listName, types dbs
listName = ''
end
else do
rx = rx+1
end
end
return
endProcedure analyzeSysprint
/*--- return the sql where condition
from the partition list in map lst ------------------*/
genWhere: procedure expose m.
parse arg ty, lst
if ty = 'I' then
spFi = 'is'
else if ty = 'T' then
spFi = 'ts'
else
call err 'bad type in genWhere('ty',' lst')'
tyDbs = m.lst
keys = mapKeys(lst)
call debug 'genWhere' lst '-->' m.lst '-->' mapKeys(lst)
wh = ''
do dx=2 to words(tyDbs)
db = word(tyDbs, dx)
fo = 0
do kx=1 to m.keys.0
if ^ abbrev(m.keys.kx, db'.') then
iterate
parse var m.keys.kx pDb '.' pTs
fo = fo + 1
if fo = 1 then
wh = wh "or (db = '"db"' and" spFi "in("
wh = wh "'"pTs"',"
end
if fo > 0 then
wh = left(wh, length(wh)-1)'))'
end
if wh = '' then
return ''
else
return substr(wh, 4)
endProcedure genWhere
rangeTest:
call rt1 '', 1
call rt1 '5', 1
call rt1 '5', 4
call rt1 '5', 5
call rt1 '5', 6
call rt1 '5', 9
call rt1 '4-6', 1
call rt1 '4-6', 3
call rt1 '4-6', 4
call rt1 '4-6', 5
call rt1 '4-6', 6
call rt1 '4-6', 7
call rt1 '4-6', 9
call rt1 '0 4-6', 1
call rt1 '0 4-6', 3
call rt1 '0 4-6', 4
call rt1 '0 4-6', 5
call rt1 '0 4-6', 6
call rt1 '0 4-6', 7
call rt1 '0 4-6', 9
call rt1 '0 4-6 11-12 15', 1
call rt1 '0 4-6 11-12 15', 3
call rt1 '* 4-6 11-12 15', 4
call rt1 '* 4-6 11-12 15', 5
call rt1 '* 4-6 11-12 15', 6
call rt1 '* 4-6 11-12 15', 7
call rt1 '* 4-6 11-12 15', 9
return
endProcedure rangeTest
rt1:procedure
parse arg ra, nn
res = rangeAdd(ra, nn)
say 'rangeAdd' ra',' nn '->' res
return res
endProcedure rt1
/*--- add a member to a range
a range is a string of the form '7 6-9 11' ---------------------*/
rangeAdd: procedure expose m.
parse arg ra, nn
do wx=1 to words(ra)
parse value word(ra, wx) with von '-' bis
if bis = '' then
bis = von
if nn-1 > bis then
iterate
else if nn-1 = bis then
bis = nn
else if nn >= von then
return ra
else if nn+1 = von then
von = nn
else
return strip(subWord(ra, 1, wx-1) nn subWord(ra, wx))
return strip(subWord(ra, 1, wx-1) von'-'bis subWord(ra, wx+1))
end
return strip(ra nn)
endProcedure rangeAdd
/*--- return true/false whether nn is in range ra --------------------*/
rangeIsIn: procedure expose m.
parse arg ra, nn
do wx=1 to words(ra)
parse value word(ra, wx) with von '-' bis
if bis = '' then
bis = von
if nn < von then
return 0
if nn <= bis then
return 1
end
return 0
endProcedure rangeIsIn
/*--- analyse a listdef in dsn spec inp
put the different parts into map ctl -----------------------*/
analyzeListdef: procedure expose m.
parse arg ctl, inp
call readDsn inp, i2.
st = ''
do rx=1 to i2.0
w = word(i2.rx, 1)
if w = '' then do
end
else if wordPos(w, 'REORG COPY REBUILD CHECK QUIESCE UNLOAD' ,
'LOAD MERGECOPY MODIFY RECOVER RUNSTATS DIAGNOSE') ,
> 0 then do
lx = wordPos('LIST', i2.rx)
listName = word(i2.rx, lx+1)
if lx < 1 | lstName = '' then do
say 'no list in' i2.rx
/* could be reorg option unload continue,
thus, ignore it | */
end
else do
if ^ mapHasKey(ctl, listName) then do
call mapAdd ctl, listName
m.ctl.listName.0 = 0
end
st = ctl'.'listName'.'mInc(ctl'.'listName'.0')
m.st.0 = 0
call debug w 'list' listName '->' st
end
end
if st ^== '' then
call mAdd st, i2.rx
end
return
endProcedure analyzeListdef
/*--- search the ds Name alloctade to dd dd --------------------------*/
dsn4Allocated: procedure expose m.
parse upper arg dd
/* it would be much easier with listDsi,
unfortuneatly listDsi returns pds name without member*/
dd = ' 'dd' '
oldOut = outtrap(l.)
call adrTso "listAlc st"
xx = outtrap(off)
do i=2 to l.0 while ^abbrev(l.i, dd)
end
if i > l.0 then
return '' /* dd not found */
j = i-1
dsn = word(l.j, 1)
if abbrev(l.j, ' ') | dsn = '' then
call err 'bad dd lines line\n'i l.i'\n'j l.j
return dsn
endProcedure dsn4Allocated
/***********************************************************************
ende Programm
ab hier kommen nur noch allgemeine Service Routinen
***********************************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm: procedure expose m.
parse arg src
call sqlExec 'execute immediate :src'
return
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* 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
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure
parse arg ggSys, ggRetCon
call sqlIni
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 sqlExec "connect" ggSys, ggRetCon ,1
return
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()[]', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = ''
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
if abbrev(a, 'MAP.') then do
do kx=1 to m.map.loKy.a.0
drop m.map.loKy.a.kx m.map.loVa.a.kx
end
m.map.loKy.a.0 = 0
end
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
if mapValAdr(a, ky) ^== '' then
call err 'duplicate key in mAdd('a',' ky',' val')'
if length(ky) < 200 then do
m.a.ky = val
end
else do
kx = mInc('MAP.LOKY.'a'.0')
m.map.loKy.a.kx = ky
m.map.loVa.a.kx = val
end
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky)
if vv ^== '' then
m.vv = val
else
call mapAdd a, ky, val
return val
endProcedure mapPut
/*--- return the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg a, ky
if length(ky) < 200 then do
if symbol('m.a.ky') == 'VAR' then
return a'.'ky
end
else if ^ abbrev(a, 'MAP.') then do
call err 'key too long mapValAdr('a',' ky')'
end
else do
do kx=1 to m.map.loKy.a.0
if m.map.loKy.a.kx == ky then
return 'MAP.LOVA.'a'.'kx
end
end
return ''
endProcedure mapValAdr
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if abbrev(vv, 'MAP.LOVA.') then
call err 'not implemented mapRemove('a',' ky')'
drop m.a.ky
return val
endProcedure mapRemove
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a,
fail if it does not exist ----------------------------------*/
mapGet: procedure expose m.
parse arg a, ky, noKey
vv = mapValAdr(a, ky)
if vv == '' then
call err 'missing key in mapGet('a',' ky')'
return m.vv
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use ="dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 to 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
leave
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
return atts 'mgmtclas(s005y000) space(10, 1000) cyl'
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure
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 *****************************************************/