zOs/REXX.O08/CHECKRTZ
/* 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*/
/* */
/* 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 1 & ssid = '' then
parse upper value 'DBTF TS TEST' with ssid type fun
if wordPos(ssid, 'DBAF DBTF DVTB') < 1 then do
call logg 'DSN.CHECKRTS.LOG', 'checkrts to old' ssid type fun
call checkrt0 ssid type fun
exit
end
say "CheckRts Programmversion = 4.0"
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=QR20801
call adrTso "alloc dd(ddIn1) shr" ,
"dsn('A540769.CHECKRTS.SYSPRINT("MBR")')"
call adrTso "alloc dd(ddIn2) shr" ,
"dsn('DBTF.DBAA.LISTDEF("MBR"1)')"
/* "dsn('A540769.CHECKRTS.LISTDEF("MBR"1)')" */
call adrTso "alloc dd(ddOut1) shr" ,
"dsn('A540769.CHECKRTS.OUTLIOLD("MBR")')"
call checkRt0 ssid type
say 'checkRt0 rc' rc
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 '??? list' listName 'in ListDef aber nicht im SysPrint',
'wahrscheinlich 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, indexSpace, creator, 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 cr, ts nm, 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
ty = oFldONly('DB TS CR NM PART REASON ROWS ACT SPACE', 'n')
call sql2Cursor 1, sql, ty
call sqlOpen 1
act.day = 0
act.no = 0
act.reo = 0
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
do while sqlFetch(1, o)
call debug oFldCat(sqlType(1), o, m.sql.1.fmt)
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 = m.o.db'.'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 = 'ingoriere '
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 m.o.cr'.'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 aelter als x Tage,',
, act.reo+act.day - reoCum - dayCum)
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')')
/* act.dLi = max(act.sum * reoMax - act.reo, dayMin * act.day) */
/* say statsline(' generiert nicht Reorg', act.sum - dayCum- reoCum)
say lst 'dayLim set to' act.dLi 'min' dayMin 'max ' reoMax
say 'reorganisiere' (reoCum + dayCum) 'bytes davon' ,
dayCum 'fuer TagesLimite'
*/ call sqlClose 1
return
endProcedure selectRts
statsLine: procedure expose m.
parse arg m1, by
r = left(m1, 60)
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 = 'indexSpace'
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,
unfortuenatly 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
/*--- append a message to a seq DSif available
otherwise isssue a message ----------------------------*/
logg: procedure expose m.
parse arg dsn
o.1 = ''
do x=1 to arg()-1
o.x = ' ' strip(arg(x+1), t)
end
o.1 = date(s) time() strip(o.1)
x = max(1, arg() - 1)
address tso "alloc dd(logg) mod dsn('"dsn"') MGMTCLAS(COM#A092)"
if rc <> 0 then do
say 'cannot alloc logg' dsn
return
end
address tso 'execio' x 'diskw logg (stem o. finis)'
if rc <> 0 then
say 'execio logg rc' rc dsn
address tso 'free dd(logg)'
if rc <> 0 then
say 'execio free rc' rc
return
endProcedure logg
/* copy sql begin ***************************************************
sql interface
sqlIni --> nur sql ohne o und j Anbindung
sqlOini --> sql mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sql.ini = 1
call oFldIni
m.sql.null = '---'
return
endProcedure sqlIni
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
sqlPrepare: procedure expose m.
parse arg cx, src, desc
call sqlExec 'prepare s'cx 'from :src'
if desc == 1 | (desc == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
sqlExecute: procedure expose m.
parse arg cx
do ix=1 to arg()-1
val = arg(ix+1)
if val ^== m.sql.null then do
m.sql.cx.i.ix.sqlInd = 0
m.sql.cx.i.ix.sqlData = val
end
else do
m.sql.cx.i.ix.sqlInd = -1
end
end
if ^ m.noInsert then /* ??? wk test */
call sqlExec 'execute s'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure
sqlExeImm: procedure expose m.
parse arg src
call sqlExec 'execute immediate :src'
return
endProcedure exeImm
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlExec 'prepare s'cx 'into :M.SQL.'cx'.D from :src'
call sqlExec 'declare c'cx 'cursor for s'cx
if ty == '*' | ty = '' then do
flds = 'SQL.'cx'.FLD'
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
flds = oFlds(ty)
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
ff = m.Sql.cx.FMT
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
sqlOpen: procedure expose m.
parse arg cx
return sqlExec('open c'cx)
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
sqlFetchInto:
parse arg ggCx, ggVars
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sql.null, m.fo.ix)
end
return 1
endProcedure sqlFetch
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- 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
sqlConnect: 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 sqlExec "connect" ggSys, ggRetCon ,1
return
endProcedure sqlConnect
sqlDisconnect: procedure
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = 'sqlCode' sqlCodeText(sqlCode, sqlErrMc),
'\nstate' sqlState 'warn'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith\n '
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
sqlCodeText: procedure expose m.
parse arg co, mc
expEq = 0
if symbol('m.sql.code.0') <> 'VAR' then do
dsn = "'A540769.wk.texv(sql)'"
dsn = "'ORG.U0009.B0106.KIUT23.TEXV(SQLCODES)'"
m.sql.code.0 = 0
if sysDsn(dsn) <> 'OK' then
say 'sqlCode dsn' dsn':' sysDsn(dsn)
else
call readDsn dsn, 'M.SQL.CODE.'
end
co = co + 0
if length(co) < 3 then
co = left(co, 3, 0)
if co > 0 then
co = '+'co
co = co' '
do cx=1 to m.sql.code.0 until abbrev(m.sql.code.cx, co)
end
if cx > m.sql.code.0 then
li = "<<text for sqlCode" co "not found>>"
else
li = m.sql.code.cx
cx = 1
px = 1
res = ''
do forever
nx = pos('${', li, cx)
if nx < 1 then
leave
ex = pos('}', li, nx)
if ex < cx then
call err 'closing } missing in' li
res = res || substr(li, cx, nx - cx)
if expEq then
res = res || '<<' || substr(li, nx+2, ex-nx-2) || ' = '
cx = ex+1
if px > length(mc) then do
res = res || '<<missing>>'
end
else do
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res || substr(mc, px, qx-px)
if expEq then
res = res'>>'
px = qx + 1
end
end
res = res || substr(li, cx)
do while px <= length(mc)
qx = pos('FF'x, mc, px)
if qx < 1 then
qx = length(mc)+1
res = res '<<extraMsgArg =' substr(mc, px, qx-px)'>>'
px = qx + 1
end
return res
endProcedure sqlCodeText
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: 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 sqlDsn
/*--- sql o interface ------------------------------------------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.jOut, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "r£", m
return
endProcedure sqlLn
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType"),
, "jOpen call sqlOpen substr(m, 8)",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/* copy sql end **************************************************/
/* copy fmt begin **************************************************/
fmt: procedure
parse arg v, f 2 l
if abbrev('-', f) then
return v
else if f = 'l' then
return left(v, l)
else if f = 'r' then
return right(v, l)
else if f = 's' then
if l = '' then
return strip(v, 't')
else
return strip(v, l)
else if f = 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, f
return fmt(v, f)
endProcedure fmtS $
/* copy fmt end **************************************************/
/* copy oFld begin ****************************************************/
oFldIni: procedure expose m.
if m.oFld.ini = 1 then
return
m.oFld.ini = 1
call mIni
m.o.cla.0 = 0
call oFldNew 'Class', '=', , ,
'INST = MET .<>= FLD .<>=Class STEM =Class'
return
endProcedure oFldIni
oFldNew: procedure expose m.
parse arg name, va, st, flds, dup
if pos('*', name) > 0 then
name = oPut('O.CLA', name, , '*')
else
call oPut 'O.CLA', name, , 'n'
m.o.cla.name.inst = 0
m.o.cla.name.val = va
m.o.cla.name.stem = st
m.o.cla.name.FLD.0 = 0
m.o.cla.name.MET.0 = 0
return oFldAdd(name, flds, dup)
endProcedure oFldNew
oFldOnly: procedure expose m.
parse arg fs, dup
kk = space(fs, 1) dup
if symbol('m.o.fldOnly.kk') = 'VAR' then
return m.o.fldOnly.kk
nn = oFldNew('FldType*')
st = 'O.CLA.'nn'.FLD'
ll = ''
do wx=1 to words(fs)
ll = ll oPut(st, word(fs, wx), '=', dup)
end
if symbol('m.o.fldOnly.ll') = 'VAR' then
nn = m.o.fldOnly.ll
m.o.fldOnly.kk = nn
m.o.fldOnly.ll = nn
return nn
endProcedure oFldOnly
oFlds: procedure expose m.
parse arg type
return 'O.CLA.'type'.FLD'
oFldCat: procedure expose m.
parse arg ty, st, fmt
flds = oFlds(ty)
res = ''
do ix=1 to m.flds.0
f = m.flds.ix
if fmt == '' then
res = res m.st.f
else
res = res fmt(m.st.f, m.fmt.ix)
end
return substr(res, 2)
endProcedure oFldCat
oFldAdd: procedure expose m.
parse arg cla, fs, dup
st = 'O.CLA.'cla'.FLD'
do ix=1 by 2 to words(fs)
call oPut st, word(fs, ix), word(fs, ix+1), dup
end
return cla
endProcedure oFldAdd
oPut: procedure expose m.
parse arg st, k, v, dup
if dup = '*' then do
cx = pos('*', k)
if cx < 1 then
call err 'no * in key' k
k = oPutDupResolve(st, left(k, cx-1), 1)
end
else if symbol('m.st.k') = 'VAR' then do
if dup = '' | dup = 'o' then do
m.st.k = v
return k
end
if dup = '=' then do
if v <> m.st.k | ^ (v = '' & datatype(m.st.k, 'n')) then
call err 'not =: m.'st'.'k '=>' m.st.k '<>' v
return k
end
if dup = 'e' then
k = oPutDupResolve(st, k, 2)
else
call err 'key' k 'exists in' st 'but dup' dup
end
else if dup = 'o' then
call err 'old key' k 'does not exist in' st
if datatype(k, 'n') | words(k) <> 1 | pos('.', k) > 0 then
call err 'illegal name' name
x = m.st.0 + 1
m.st.0 = x
m.st.x = k
if v == '' then
m.st.k = x
else
m.st.k = v
return k
endProcedure oPut
oPutDupResolve: procedure expose m.
parse arg st, k, b
do ix=b
a = k || ix
if symbol('m.st.a') <> 'VAR' then
return a
end
endProcedure oPutDupResolve
/*--- parameterized types --------------------------------------------*/
oGetTypePara: procedure expose m.
parse arg m
if symbol('m.o.tyPa.m') == 'VAR' then
return m.o.tyPa.m
else
return '='
endProcedure oGetTypePara
oSetTypePara: procedure expose m.
parse arg m, type, noCall
if type = '' then
type = '='
if oGetTypePara(m) == type then
return
if noCall ^== 'noCall' then
interpret oObjMethod(m, 'oSetTypePara')
m.o.tyPa.m = type
return
endProcedure oSetTypePara
/* copy oFld end ***************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
***********************************************************************/
/*--- 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
return a
endProcedure
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
return a
endProcedure mapClear
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
mapAdd: procedure expose m.
parse arg a, ky, val
if symbol('m.a.ky') == 'VAR' then
call err 'duplicate key in mAdd('a',' ky',' val')'
m.a.ky = val
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
mapPut: procedure expose m.
parse arg a, ky, val
if m.map.keys.a ^== '' then
if symbol('m.a.ky') ^== 'VAR' then
call mAdd m.map.keys.a, ky
m.a.ky = val
return val
endProcedure mapPut
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
drop m.a.ky
return val
endProcedure mapRemove
mapHasKey: procedure expose m.
parse arg a, ky
return symbol('m.a.ky') == 'VAR'
endProcedure mapHasKey
mapGet: procedure expose m.
parse arg a, ky
if symbol('m.a.ky') ^== 'VAR' then
call err 'missing key in mapGet('a',' ky')'
return m.a.ky
endProcedure mapGet
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 ********************************************************
stem handling
***********************************************************************/
/*--- 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 adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
ds = ''
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))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
return 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 ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'MGMTCLAS(COM#A092) space(10, 1000)'
end
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy 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:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
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
/*--- 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 *****************************************************/