zOs/REXX/REOCHEC0
/* REXX **************************************************************
synopsis: reoCheck db fun
db = db2 subsystem
type = TS oder IX
function: db2 real time statistics für reorg anwenden:
1. preview der listdefs einlesen
2. listdefs einlesen
3. rts abfragen
4. neue listdef erstellen
5. *run* Tabellen mit History Infos fuellen
Tabellen und Views: siehe makeTableNames:
location: tso.rzx.p0.user.exec
docu: http://chsa4212/host/db2wiki/pmwiki.php?n=Main.RtsReo
history ***************************************************************
04.05.2012 v6.0 fix problem with multiple utilities for same type
**********/ /* end of help ********************************************
26.03.2012 v5.9 handle v9/v10 real time stats n
15.02.2012 v5.8 empty listdefs in v10 implementation
21.10.2011 v5.7 parallelism, undon insert tReoRunJob, new sql
7.02.2011 v5.61 fix Dupl. Abend on insert tReoRunJob, new sql
17.01.2011 v5.6 reOrder von v5.5
14.01.2011 v5.5 reFactoring und neue copies
30.11.2010 v5.41 fix tyInp in tReoRunJob
27.09.2010 v5.4 new name reoCheck, use s100447.?Reo* tb
24.09.2010 v5.3 split listdef by unCompressedDataSize limit
27.08.2010 v5.2 fix uncompressDatasize tsStatsFix in insertStats
29.07.2010 v5.1 fix ixSpae, namens Verschreiber
08.07.2010 v5.1 fix rngI0=-99
07.07.2010 v5.1 fix reoTimeLimite, StartAnzeige, checkRef err
06.07.2010 v5.1 jobException Table, Sort Limite, *run* history
09.12.2009 v5.0 weiterarbeiten wenn checkRef abstürzt
03.12.2009 v5.0 TS jetzt mit reoTime, die Grösse der
nicht Partitionierten Indexe berücksi.
23.04.2010 v4.4 reorg by part range für ts
falls partBis > für DB jJOB in Exc
08.09.2008 v4.3 vRtsReoIx.is fuer Indexspace
(nicht null bei fehlenden rts Daten)
21.08.2008 v4.2 vRtsReoIx.cr (statt .Creator) fuer V9
20.05.2008 v4.1 Bereinigung
10.04.2008 v4.0 Umstellung auf neue exception tabl/vws
04.12.2006 v2.3 Optimierung mit Gruppenbruch-Logik
20.11.2006 v2.21 RSU0610 bewirkt Meldung:
'insuff. operands for keyword listdef'
Neu wird leeres Member erstellt falls
keine Objekte die Schwellwerte erreich
10.04.2006 v2.2 pgm läuft auch ohne ispf (A234579)
Diagnose Statement erlaubt (A234579)
10.11.2005 v2.1 schwellwerte erweitert (A234579)
23.09.2005 v2.0 index mit rts-abfrage (A234579)
20.09.2005 v1.2 erweiterte abfrage auf noload repl
16.09.2005 v1.1 inkl.reorg index ohne rts (A234579)
25.10.2004 v1.0 grundversion (m.streit,A234579)
*******************************************************************/
m.debug = 0
parse upper arg ssid type
m.job = strip(MVSVAR('SYMDEF', 'JOBNAME'))
say "reoCheck Programmversion = 6.0 4.5.12 runTime" date('s') time()
say " DB2 Subsystem =" ssid
say " Job Name =" m.job
if ssid = '' | pos('?', ssid type) > 0 then
exit errHelp('fehlende Parameter:' ssid type)
call sqlConnect ssid
call makeTableNames ssid, 's100447'
call selectJobParms
say " Limiten"
say " Reo Zeit TS = " fmtTime(m.job.time.ts)
say " Reo Zeit IX = " fmtTime(m.job.time.ix)
say " unCompSizeI0 =" fmtDec(m.job.uncompI0) 'Bytes'
say " unCompSizeDef =" fmtDec(m.job.unCompDef) 'Bytes'
say " IX nach spaeter =" m.job.ixSpae
say " *Run* Stats =" m.job.stats
if m.runJob.tst = '' then
say " Last Run = nicht gefunden"
else
say " Last Run =" m.runJob.tst m.runJob.ty ,
"status" m.runJob.sta
if type = '' then do
type = 'TS'
say " kein Type gewählt, also TS-Reorg getriggert"
end
m.tyInp = type
if m.runJob.sta = 's' then do
if type = 'IX' & m.job.ixSpae = 't' then do
say " run" m.runJob.tst "mit spaeter typeChange auf TS"
type = "TS"
end
else if type = 'IX' & m.job.ixSpae = 'n' then do
say " run" m.runJob.tst "mit spaeter ==> STOP"
type = ''
end
else do
say " run" m.runJob.tst "mit spaeter"
end
end
m.ty = type
if type \== '' then
say " Type = "type
say ''
call errReset 'h'
call mapIni
call sqlIni
/* use adrTso, so we survive errors in reoRefSt */
call adrTso reoRefSt '-'ssid 'ref' 100 'staLevel' m.job.stats ,
'staJob' m.job, '*'
m.jobSta = 0
m.rngFi = 0
m.rngLa = 0
if type \== '' then do
call doreoCheck type, '-ddIn1', '-ddIn2', dsn4allocated('ddOUt1')
end
else do
o.1 = ' -- reoCheck' date('s') time() 'nicht nach spaeter'
call writeDsn ddOut1, 'O.', 1, 1
end
call sqlDisconnect
exit
/*--- main function
analyse utility preview sysprint
analyse utitlity ctl input
select Rts Infos and decide what to reorg
generate new utility ctrl cards ----------------------------*/
doReoCheck: procedure expose m.
parse arg doType, ddIn1, ddIn2, ddOut
m.lst.0 = 0
call analyzeSysprint lst, ddIn1
call debugLst lst, 'lists in sysprint'
m.ctl.0 = 0
call analyzeCtl ctl, ddIn2
call debugCtl ctl
typ1 = left(doType, 1)
do cx=1 to m.ctl.0
cc = ctl'.'cx
m.cc.list = ''
l1 = mapGet(lst'.N2L', m.cc.listName, '')
if l1 == '' then do
say '*** warning' m.cc.listName 'in ListDef,',
'aber nicht im SysPrint (leer?)'
end
else if word(m.l1.type, 1) ^== typ1 then do
call debug '*** warning list' m.l1.type m.l1.name ,
'nicht type' doType 'wird ignoriert'
end
else if m.l1.done == 1 then do
m.cc.list = l1
end
else do
m.cc.list = l1
m.l1.done = 1
call selectRts l1, doType
miss = ''
do ox = 1 to m.l1.0
if m.l1.ox.nm == '' then
miss = miss m.l1.ox.db'.'m.l1.ox.sp
end
if miss \== '' then
call err 'obj in sysprint fehlen in rts:'miss
rTi = makeRanges(l1, doType)
call reportReo l1, doType, rTi
end
end
call genCtl ddOut, ctl, doType
call insertStats lst, doType
return
endProcedure doReoCheck
/*--- view and tableNames, copy in reoRefSt --------------------------*/
makeTableNames: procedure expose m.
parse arg ssid, q
if q = 'OA1P' wordPos(ssid, 'DBAF DBTF DBZF DBLF') > 0 then
q = overlay(substr(ssid, 3, 1), q, 4)
r = q
m.rrTS = r".vReoTS"
m.rrIx = r".vReoIX"
m.dbSt = q".tDbState"
m.exJob = q".vReoJobParms"
m.ruJob = q".tReoRunJob"
m.ruPart = q".tReoRunPart"
m.ruTsSt = q".tReoRunTSStats"
m.ruIxSt = q".tReoRunIXStats"
m.ixStats= "sysibm.sysIndexSpaceStats"
m.tsStats= q".vReoTSStatsFix"
return
endProcedure makeTableNames
/*--- select job parameters from job parameter table -----------------*/
selectJobParms: procedure expose m.
if sqlPreAllCl( 9, "select",
"int(substr(max(prC2 || char(tsTime)), 3)),",
"int(substr(max(prC2 || char(ixTime)), 3)),",
"real(substr(max(prC2 || char(uncompDef)), 3)),",
"real(substr(max(prC2 || char(uncompI0 )), 3)),",
" substr(max(prC2 || char(ixSpae)), 3) ,",
" substr(max(prC2 || char(stats )), 3) ",
"from" m.exJob ,
"where left(job,jobLen) = left('"left(m.job,8)"', jobLen)",
, job, ":m.job.time.ts, :m.job.time.ix, :m.job.uncompDef," ,
":m.job.uncompI0, :m.job.ixSpae, :m.job.stats")<> 1 then
call err m.job.0 'rows from' m.exJob '\n'sqlMsg()
m.runJob.tst = ''
m.runJob.sta = ''
if sqlPreAllCl( 9, "select tst, ty, sta, eoj" ,
"from" m.ruJob ,
"where job = '"m.job"'" ,
"order by tst desc",
"fetch first row only",
, runJob, ":m.runJob.tst, :m.runJob.ty," ,
":m.runJob.sta, :m.runJob.eoj :m.runJob.eojInd"),
> 1 then
call err m.job.0 'rows from' m.ruJob'\n'sqlMsg()
return
endProcedure selectJobParms
/*--- analyze sysprint of utility preview
put listelements in m.lst. ------------------------------*/
analyzeSysprint: procedure expose m.
parse arg listen, inp
if m.listen.0 = 0 then
call mapReset listen'.N2L'
call readDsn inp, i1.
dbg = 0
do rx=1 to i1.0
if substr(i1.rx, 2, 10) == 'DSNU1010I ' ,
| substr(i1.rx, 2, 10) == 'DSNU1008I ' then do
sta = substr(i1.rx, 8, 2)
wx =wordPos('LISTDEF', i1.rx)
listName = word(i1.rx, wx+1)
if wx < 5 | listName == '' then
call 'bad sysprint line' rx':' i1.rx
if dbg then say '???nnn' sta listName
oKey = mapGet(listen'.N2L', listName, '')
if oKey \== '' then do
if dbg then say '???nnn list alrExists' oKey m.oKey.0
/* DSNU1008I may appear several times| */
if sta \== 08 | m.oKey.0 \= 0 then
call err 'list' listName 'alreadey exists with' ,
m.oKey.0 'objects sysprint line' rx':' i1.rx
end
else do /* add new list */
m.listen.0 = m.listen.0 + 1
lst = listen'.'m.listen.0
m.lst = lst
m.lst.0 = 0
call mapAdd listen'.N2L', listName, lst
call mapReset lst'.N2O'
m.lst.name = listName
m.lst.type = ''
end
if sta == 08 then
sta = '' /* DSNU1008I has only a single line */
m.lst.prtCnt = 0
end
else if substr(i1.rx, 2, 10) \== ' ' then do
sta = '' /* next message */
end
else if sta == 10 then do /* DSNU1010I line 2 */
wx =wordPos('OBJECTS', i1.rx)
if wx < 4 | \ datatype(word(i1.rx, wx-1), 'n') then
call err 'bad object count in sysprint line' rx':'i1.rx
m.lst.prtCnt = word(i1.rx, wx-1)
if dbg then say '???nnn 10' word(i1.rx,wx-1) 'objects'
sta = 102
end
else if sta == 102 then do /* DSNU1010I line 3... */
parse var i1.rx inc obj db1 '.' ts ' ' . 'LEVEL(' part ')'
if inc \== 'INCLUDE' ,
| wordPos(obj, 'TABLESPACE INDEXSPACE') < 1 then
call err 'bad sysprint include line' rx':' i1.rx
if dbg then say '???nnn 102 inc' obj db1'.'ts':'part'|'
ty = left(obj, 1)
if m.lst.type == '' then
m.lst.type = ty
else if m.lst.type \== ty then
call err 'ListDef' listName ,
'mit verschiedene Types, sysprint' rx':' i1.rx
ky = db1'.'ts
o = mapGet(lst'.N2O', ky, '')
if o \== '' then do /* add part to existing obj */
if part \== '' & m.o.parts \== '' then
/* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, m.o.parts, part)
else if part == '' & m.o.parts \== '0' then
call err 'part 0 mismatch for' m.o.db'.'m.o.sp
end
else do /* new obj */
ox = m.lst.0 + 1
m.lst.0 = ox
o = lst'.'ox
m.o.db = db1
m.o.sp = ts
m.o.dbSp = ky
m.o.nm = ''
if part == '' then
m.o.parts = 0
else /* parts: BitString with 1 at position of part */
m.o.parts = overlay(1, '', part)
call mapAdd lst'.N2O', ky, o
end
end
end
do lx=1 to m.listen.0
lst = listen'.'lx
if (m.lst.0=0) <> (m.lst.prtCnt=0) then
call err 'list' m.lst.name 'has' m.lst.0 'objects' ,
'but' m.prtCnt 'parts'
say 'list' m.lst.name 'has' m.lst.0 'objects with' ,
(m.lst.prtCnt+0) 'parts'
do ox=1 to m.lst.0
o = lst'.'ox
if m.o.parts == 0 then do
m.o.paFr = 0
m.o.paTo = 0
end
else do
m.o.paFr = pos(1, m.o.parts)
if m.o.paFr > 0 then
m.o.paTo = lastPos(1, m.o.parts)
else
m.o.paTo = -1
end
end
end
return
endProcedure analyzeSysprint
/*--- analyse a listdef in dsn spec inp
put the different parts into map ctl -----------------------*/
analyzeCtl: procedure expose m.
parse arg ctl, inp
cx = m.ctl.0
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)
liNa = word(i2.rx, lx+1)
if lx < 1 | lstName = '' then do
say 'warning no list in' i2.rx
/* could be reorg option unload continue,
thus, ignore it | */
end
else do
cx = cx + 1
st = ctl'.'cx
m.st.0 = 0
m.st.listName = liNa
call debug w 'list' liNa '->' st
end
end
if st ^== '' then
call mAdd st, i2.rx
end
m.ctl.0 = cx
return
endProcedure analyzeCtl
/*--- select the rts views for list lst and type type ----------------*/
selectRts: procedure expose m.
parse arg lst, type
if m.debug \== 1 then
m.sqlRetOk = 'w'
if m.lst.rts == 1 then
return
m.lst.rts = 1
if type == 'TS' then do
sql = "select db, ts, part, dbid, psid, reason, importance," ,
"reorgTime, i0Time, i0Parts," ,
"swRangeI0, swParallel, lastBuilt, uncompSz",
"from" m.rrTS ,
"where" genWhere(word(m.lst, 1), lst) ,
"order by importance desc, lastBuilt asc" ,
"with ur"
feFi = sqlVars('M.R', 'DB SP PART DBID SPID REASON IMP' ,
'RETI I0TI I0PA RAI0 PARA LABU UNCO', 1)
end
else if type == 'IX' then do
sql = "select db, is, part, ts, cr, ix, dbId, isoBid,",
"reason, importance, reorgTime, lastBuilt" ,
"from" m.rrIX ,
"where" genWhere(word(m.lst, 1), lst) ,
"order by importance desc, lastBuilt asc with ur"
feFi = sqlVars('M.R', 'DB SP PART TS CR IX DBID SPID',
'REASON IMP RETI LABU', 1)
m.r.i0Ti = 0
m.r.raI0 = 0
m.r.para = 0
m.r.unCo = 0
end
call debug 'sql' sql
call sqlPreOpen 1, sql
iLnk = lst
m.iLnk.impLnk = ''
m.iLnk.imp = 9e9
do while sqlFetchInto(1, feFi)
/* say 'db' m.r.db 'sp' m.r.sp 'pa' m.r.part
say ' imp' m.r.imp left(m.r.reason, 40) m.r.laBu
say 'reTi' m.r.reTi 'ioTi' m.r.i0Ti 'ix' m.r.i0Pa,
' raI0' m.r.raI0 'para' m.r.para */
key = strip(m.r.db)'.'strip(m.r.sp)
if m.iLnk.imp < m.r.imp then
call err 'importance increasing'
o = mapGet(lst'.N2O', key, '')
pa = m.r.part + 0
if o == '' then
call err key 'in rts but not lst'
if (pa == 0) \== (m.o.parts == 0) then
call err key 'part 0 misma rts' m.r.part 'lst' m.lst.parts
if pa \== 0 then
if substr(m.o.parts, pa, 1) \== 1 then do
say 'warning' key 'part' m.r.part 'not in lst'
iterate
end
if m.o.nm == '' then do
if type == 'TS' then do
m.o.nm = key
end
else do
m.o.ts = strip(m.r.ts)
m.o.cr = strip(m.r.cr)
m.o.ix = strip(m.r.ix)
m.o.nm = m.o.cr'.'m.o.ix
end
m.o.dbId = strip(m.r.dbId)
m.o.spId = strip(m.r.spId)
m.o.rngI0 = ''
m.o.i0Ti = m.r.i0Ti
m.o.i0Pa = m.r.i0Pa
m.o.raI0 = m.r.raI0
m.o.para = m.r.para
end
m.o.pa.impLnk = ''
m.iLnk.impLnk = o'.'pa
iLnk = o'.'pa
m.o.pa.part = pa
m.o.pa.obj = o
m.o.pa.reTi = m.r.reTi
m.o.pa.unco = m.r.unco
m.o.pa.imp = m.r.imp
m.o.pa.imRe = m.r.imp m.r.reason
m.o.pa.rng = ''
end
call sqlClose 1
return
endProcedure selectRts
/*--- group partitions into ranges
and make the ranges by thresholds for space, time etc ------*/
makeRanges: procedure expose m.
parse arg lst, type
iLnk = m.lst.impLnk
rLnk = lst
m.rLnk.reoLnk = ''
rTimax = m.job.time.type
rTi = 0
iRg = 0
if type = 'IX' then do /* Algorithmus 1: jede partition einzeln
reorganisieren bis zur ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
o = m.iL.obj
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
else do
iRg = iRg + 1
m.iL.rng = iRg
m.o.rngI0 = -99
rTi = rTi + max(.001, m.iL.reTi)
end
m.rLnk.reoLnk = iL
rLnk = iL
end
end
else do /* Algorithmus 2: partition Ranges innerhalb TS reorg.
range Limitiert nach zeit und sortPlatz
Total ZeitLimite */
do while iLnk \== ''
iL = iLnk
iLnk = m.iL.impLnk
if m.iL.rng \== '' then
iterate
if m.iL.imp <= 0 then
m.iL.rng = 'i'
else if rTi > rTimax & m.iL.imp < 9 then
m.iL.rng = 's'
if m.iL.rng \== '' then do
m.rLnk.reoLnk = iL
rLnk = iL
iterate
end
o = m.iL.obj
liUn = if(m.o.I0ti <= 0, m.job.uncompDef, m.job.uncompI0)
liT0 = max(120, m.o.I0ti * m.o.raI0/100)
liTi = max(10, m.o.I0ti * m.o.raI0/100)
say '????liTi' liTi ', liT0' liT0
liPa = m.o.para
acTi = max(0, m.o.I0Ti)
acPa = 0
acUn = 0
if m.o.rngI0 == '' then do
if type == 'TS' ,
& m.iL.part > 0 & m.o.i0Pa > 0 then
m.o.rngI0 = ass('iRg', iRg + 1)
else
m.o.rngI0 = -99
end
iRg = iRg + 1
pL = iL /* do not reorg imp<0 | */
do while pL \== '' & m.pL.imp >= 0
if m.pL.obj = o then do
if m.pL.rng \== '' then
call err 'rng already set'
m.pL.rng = iRg
acPa = acPa + 1
if m.o.i0Ti > 0 then
acTi = acTi + max(0.1, m.pL.reTi - m.o.i0Ti)
else /*???wk tentative formula for paralellism */
acTi = max(acTi, m.pL.reTi),
+ max(0.1, 0.3 * min(acTi, m.pL.reTi))
acUn = acUn + max(m.pL.unco, 1)
m.rLnk.reoLnk = pL
rLnk = pL
if acPa >= liPa & acTi >= liTi then
leave
if acUn >= liUn then
leave
end
pL = m.pL.impLnk
end
rTi = rTi + acTi
end
end
m.rLnk.reoLnk = ''
return rTi
endProcedure makeRanges
/*--- report which paritions to reorg and which not ------------------*/
reportReo: procedure expose m.
parse arg lst, type, rTi
tt = if(type == 'TS', '(table', '(index')'Partitionen)'
if rTi <= 0 then
call reoTitSay 'nichts zu reorganisieren:' type
else
call reoTitSay type 'zu reorganisieren,' fmtTime(rTi),
'geschaetzte Step ReorgZeit', type
rL = m.lst.reoLnk
iRg = 0
do while rL \== '' & m.rL.rng \== 's'& m.rL.rng \== 'i'
if iRg \= m.rL.rng & iRg+1 \= m.rL.rng ,
& iRg+2 \= m.rL.rng then
call err 'bad range' m.rL.rng 'after' iRg
iRg = m.rL.rng
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' & m.rL.rng == 's' then
call reoTitSay 'auf spaeter verschobene' type 'Reorgs', type
do while rL \== '' & m.rL.rng == 's'
say reoFmt(rL)
rL = m.rL.reoLnk
end
if rL \== '' then do
if m.rL.rng \== 'i' then
call err 'at end but rL' rL 'rng' m.rL.rng
call reoTitSay type 'Reorganisation nicht noetig fuer'
do lx=1 to m.lst.0
pas = ''
paL = ''
do p=m.lst.lx.paFr to m.lst.lx.paTo
if m.lst.lx.p.rng == 'i' then do
if p-1 = paL then
paL = p
else do
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
paL = p
paF = p
end
end
end
if paL == '' then
iterate
if paL = paF then
pas = pas',' paL
else if paL \== '' then
pas = pas',' paF'-'paL
say m.lst.lx.nm':' substr(pas, 2)
end
end
say ''
m.sqlRetOk = ''
return 0
endProcedure reportReo
/*--- return the sql where condition
from the partition list in map lst ------------------*/
genWhere: procedure expose m.
parse arg lst
if m.lst.type = 'I' then
spFi = 'is'
else if m.lst.type = 'T' then
spFi = 'ts'
else
call err 'bad type in genWhere('lst')'
wh = ''
do dx=1 to m.lst.0
o = lst'.'dx
d1 = m.o.db
if db.d1 == 1 then
iterate
db.d1 = 1
fo = 0
do kx=dx to m.lst.0
o = lst'.'kx
if m.o.db \== d1 then
iterate
fo = fo + 1
if fo = 1 then
wh = wh "or (db = '"d1"' and" spFi "in("
wh = wh "'"m.o.sp"',"
end
if fo > 0 then
wh = left(wh, length(wh)-1)'))'
end
if wh = '' then
return ''
else
return substr(wh, 4)
endProcedure genWhere
/*--- format outputline for 1 part to reorg --------------------------*/
reoFmt: procedure expose m.
parse arg pa
f = 'e'
o = m.pa.obj
return left(m.o.nm, 21 - length(m.pa.part)) m.pa.part ,
right(if(m.pa.rng < 0, '', m.pa.rng), 5) ,
fmtTime(m.pa.reTi) fmtTime(m.o.i0Ti) strip(m.pa.imRe)
endProcedure reoFmt
/*--- title for reorg part lines -------------------------------------*/
reoTitSay: procedure expose m.
parse arg tit, withHead
say ''
say left(tit' ', 70, '*')
if withHead \== '' then
say left(if(m.ty == 'TS', 'db.tablespace', 'creator.index'),17),
right('part', 4) right('range', 5) ,
right('reoTi', 5) right('i0Ti', 5) 'i reason'
return
endProcedure reoTit
/*--- generate utiltity ctrl cards for run
ddOut: output dd spec to write ctrl to
ctl: input ctl with link to lists
genType: TS or IX ---------------------------------*/
genCtl: procedure expose m.
parse arg ddOut, ctl, genType
if genType = 'TS' then
ldType = 'TABLESPACE'
else if genType = 'IX' then
ldType = 'INDEXSPACE'
else
call err 'bad type' genType
m.out.1 = ' -- reoCheck' date('s') time()
m.out.0 = 1
do cx = 1 to m.ctl.0
c1 = ctl'.'cx
lst = m.c1.list
if lst == '' | m.lst.isGen == 1 then
iterate
m.lst.isGen = 1
liNa = m.lst.name
rL = m.lst.reoLnk
if rL == '' | m.rL.rng == 'i' | m.rL.rng == 's' then do
call debug 'nothing to reorg in' m.lst.name
iterate
end
dx = 0
acRg = ''
do while rL \== '' & m.rL.rng \== 's' & m.rL.rng \== 'i'
o = m.rL.obj
if m.rL.rng \= acRg then do
if dx == 0 | (genType == 'TS' ,
& wordPos(m.o.nm, acNms) > 0) then do
dx = dx + 1
acNms = ''
call mAdd out, 'LISTDEF' liNa'#'dx
end
acRg = m.rL.rng
acNms = acNms m.o.nm
end
pNo = m.rL.part
call mAdd out, ' INCLUDE' ldType m.o.dbSp,
if(pNo=0,'', 'PARTLEVEL('pNo')')
rL = m.rL.reoLnk
end
do dy=1 to dx
call genCtlUtil out, ctl, lst, 'LIST' liNa'#'dy
end
end
call writeDsn ddOut, 'M.'out'.', ,1
return
endProcedure genCtl
/*--- generate utility ctl for all utitlity for one list -------------*/
genCtlUtil: procedure expose m.
parse arg o, ctl, lst, what
do ux=1 to m.ctl.0 /* each utility for this list */
c1 = ctl'.'ux
if m.c1.list \== lst then
iterate
call mAdd o, ' -- utility' ux 'of' what
l1 = m.ctl.ux.1
lx = wordPos('LIST', l1)
if lx < 2 | word(l1, lx+1) <> m.lst.Name then
call err 'bad reorg list' lst':' l1
call mAdd o, subWord(l1, 1, lx-1) what subWord(l1, lx+2)
do cx=2 to m.c1.0
call mAdd o, strip(m.c1.cx, 't')
end
end
return
endProcedure genCtlUtil
/*--- insert statistics into tReoRun* tables ------------------------*/
insertStats: procedure expose m.
parse arg all, type
call sqlCommit
staLev = pos(m.job.stats, 'njps')
if staLev < 2 then
return
do try=1
call sqlPushRetOk -803
res = sqlPreAllCl(1, "select tst from final table (",
"insert into" m.ruJob ,
"(tst, job, TY, TYINP, STA)",
"values(current timestamp, '"m.job"',",
"'"type"', '"m.tyInp"', '"m.jobSta"') )",
, st , ':m.tst')
call sqlPopRetOk
if res = 1 then
leave
else if try > 5 then
call err 'to many retries ('try') for insert' m.ruJob
else if res \== -803 then
call err 'bad res' res 'insert' m.ruJob
say 'duplicate for insert' m.ruJob 'retry' try
call sqlExec 'rollback'
call sleep 1
end
call debug 'insertStats' m.tst m..0
if staLev < 3 then
return
do try=1
call sqlPrepare 22, "insert into" m.ruPart "(",
"tst, rng, part, paVon, paBis," ,
"rngI0, dbId, spId, ty, sta, reason, db, sp" ,
")values('"m.tst"', ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?)"
ty = if(type == 'TS', 't', 'i')
r0.0 = 1
pCnt = 0
do kx = 1 to m.all.0
lst = m.all.kx
if m.lst.rts \== 1 then
iterate
laRa = 0
rL = m.lst.reoLnk
do while rL \== '' & m.rL.rng \== 'i'
o = m.rL.obj
r0 = m.o.rngI0
ra = m.rL.rng
raTy = ra
if wordPos(raTy, 'i s') < 1 then
raTy = 'r'
if raTy == 'r' & r0 >= laRa then do
if r0 \= laRa + 1 then
call err 'bad r0' r0 'after' laRa
laRa = r0
call sqlExecute 22, r0, 0, 0, 0,
, -99, m.o.dbid, m.o.spId,
, ty, '0', 'i0 Indexe', m.o.db, m.o.sp
call debug sqlerrd.3 'i0 parts inserted r0' r0
pCnt = pCnt + 1
end
if raTy \== 'r' then do
ra = max(32000001, laRa+1)
laRa = ra
r0 = -99
rFr = m.rL.part
rTo = m.rL.part
end
else if ra \= laRa then do
if laRa + 1 \= ra then
call err 'bad range' ra 'after' laRa
laRa = ra
rFr = m.rL.part
rTo ='bad'
qL = rL
do qx=0 while ra = m.qL.rng
rTo = m.qL.part
qL = m.qL.reoLnk
end
if qx < 1 | (rFr = rTo) <> (qx = 1) then
call err 'bad from to'
end
call debug m.o.nm':'m.rL.part 'in range' ra,
'with' qx 'parts from' rFr 'to' rTo
call sqlExecute 22, ra, m.rL.part, rFr, rTo,
, r0, m.o.dbid, m.o.spId,
, ty, raTy, left(m.rL.imRe, 50), m.o.db, m.o.sp
pCnt = pCnt + 1
rL = m.rL.reoLnk
end
end
say pCnt 'runParts inserted into' m.ruPart
if staLev < 4 then
return
parse var m.tsStats rTC '.' rTT
parse var m.ixStats rIC '.' rIT
if ty == 't' then do
call sqlExec "insert into" m.ruTsSt,
"(tst, rng," tbCols(rTC, rTT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," ,
m.tsStats "r",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and p.part = r.partition", 100
say sqlerrd.3 'tsStats inserted into' m.ruTsSt
call sqlExec "insert into" m.ruIxSt ,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r" ,
", sysibm.sysTables t, sysibm.sysIndexes i",
"where p.tst = '"m.tst"' and p.ty = 't'",
"and p.dbid = r.dbid and p.spId = r.psId" ,
"and t.dbName = p.db and t.tsName = p.sp" ,
"and i.tbCreator = t.creator and i.tbName=t.name",
"and r.dbId = i.dbId and r.isoBid = i.isoBid",
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
else if ty == 'i' then do
call sqlExec "insert into" m.ruIxSt,
"(tst, rng," tbCols(rIC, rIT)")",
"select tst, rng, r.*",
"from" m.ruPart "p," m.ixStats "r",
"where p.tst = '"m.tst"' and p.ty = 'i'",
"and p.dbid = r.dbid and p.spId = r.isoBid" ,
"and p.part = r.partition", 100
say sqlerrd.3 'ixStats inserted into' m.ruIxSt
end
call sqlCommit
return
endProcedure insertStats
tbCols: procedure expose m.
parse upper arg cr, tb
sql = "select name from sysibm.sysColumns",
"where tbCreator = '"cr"' and tbName = '"tb"'" ,
"order by colNo asc"
call sqlPreOpen 1, sql
res = ''
do while sqlFetchInto(1, ':c1')
res = res',' c1
end
call sqlClose 1
return substr(res, 3)
endProcedure tbCols
/*--- debug a listDef ------------------------------------------------*/
debugCtl: procedure expose m.
parse arg ctl, tit
if m.debug ^== 1 then
return
call debug tit
do kx=1 to m.ctl.0
cc = ctl'.'kx
call debug 'ctl' kx cc 'for list' m.cc.listName
do s1=1 to m.cc.0
call debug ' ' strip(m.cc.s1, t)
end
end
return
endProcedure debugCtl
/*--- debug a list ---------------------------------------------------*/
debugLst: procedure expose m.
parse arg lst, tit
if m.debug \== 1 then
return
call debug tit
do lx=1 to m.lst.0
call debug 'list' lst'.'lx m.lst.lx.name m.lst.lx.type ,
'db' m.lst.lx.db
do kx=1 to m.lst.lx.0
k2 = lst'.'lx'.'kx
call debug ' ' k2 '->' ,
'db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
end
return
endProcedure debugLst
/*--- debug a map ----------------------------------------------------*/
debugMap: procedure expose m.
parse arg mp, pr
if m.debug ^== 1 then
return
do kx=1 to m.kk.0
k2 = mapGet(mp, m.kk.kx)
call debug pr m.kk.kx '->' k2
call debug pr ' db' m.k2.db 'sp' m.k2.sp 'parts' m.k2.parts
end
return
endProcedure debugMap
/*--- 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 sleep begin ***************************************************/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/* copy sleep end *****************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
parse arg opt
if m.sql.ini == 1 & opt \== 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sqlRetOK.0 = 0
m.sqlMsgCa = 0
m.sqlMsgDsntiar = 1
m.sqlMsgCodeT = 0
call sqlPushRetOk
m.sql.ini = 1
m.sql.connected = ''
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'
res = sqlExec('prepare s'cx s 'from :src')
if res < 0 then
return res
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
res = sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
else
m.sql.cx.i.sqlD = 0
return res
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPrepare(cx, src, descOut, descInp)
if res >= 0 then
return sqlExec('declare c'cx 'cursor for s'cx)
return res
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
res = sqlPreDeclare(cx, src, descOut, descInp)
if res >= 0 then
return sqlOpen(cx)
return res
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
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
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 */
ggRes = sqlExec('fetch c'ggCx 'into' ggVars, 100 m.sqlRetOk)
if ggRes == 0 then
return 1
if ggRes == 100 then
return 0
return ggRes
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
/*--- 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
ggRes = sqlOpen(ggCx)
if ggRes < 0 then
return ggRes
do sx = 1 until ggRes \== 1
ggRes = sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
if ggRes == 0 then
return m.st.0
return ggRes
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)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
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
ggRes = sqlPreDeclare(ggCx, ggSrc)
if ggRes >= 0 then
return sqlOpAllCl(ggCx, st, ggVars)
return ggRes
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx ggRetOk /* no , for ggRetOk, arg(2) is used already| */
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, ggRetOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
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, ggRetOk, 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
if ggRetOk = '' then
ggRetOk = m.sqlRetOk
if wordPos(rc, '1 -1') < 0 then
call err 'dsnRexx rc' rc sqlmsg()
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
say 'sqlError' sqlmsg()
return sqlCode
end
else if rc < 0 then
call err sqlmsg()
else if sqlCode <> 0 | (pos('w',ggRetOk)<1 & sqlWarn.0^==' ') then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 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
if sys = '-' then
return 0
res = sqlExec("connect" sys, retOk ,1)
if res >= 0 then
m.sql.connected = sys
return res
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql.connected = ''
return sqlExec("disconnect ", retOk, 1)
endProcedure sqlDisconnect
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConDis: procedure expose m.
parse upper arg sys, retOk
if sys \== '' then
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
else
call err 'no default subsys for' sysvar(sysnode)
call sqlIni
if sys == m.sql.connected then
return 0
if m.sql.connected \== '' then
call sqlDisconnect
if sys = '-' then
return 0
return sqlConnect(sys, retOk)
endProcedure sqlConDis
/*--- push and pop currently accepted sqlCodes -----------------------*/
sqlPushRetOk: procedure expose m.
parse arg rr
nx = m.sqlRetOk.0 + 1
m.sqlRetOk.0 = nx
m.sqlRetOk.nx = rr
m.sqlRetOk = rr
return
endProcedure sqlPushRetOk
sqlPopRetOk: procedure expose m.
nx = m.sqlRetOk.0 - 1
if nx < 1 then
call err 'sqlPopRetOk with .0' m.sqlRetOk.0
m.sqlRetOk = m.sqlRetOk.nx
m.sqlRetOk.0 = nx
return
endProcedure sqlPopRetOk
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
ggRes = ''
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlMsgCa()
end
else do
signal on syntax name sqlMsgOnSyntax
if m.sqlMsgCodeT == 1 then
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 = sqlMsgCa(),
'\n<<rexx sqlCodeT not found or syntax>>'
end
signal off syntax
if m.sqlMsgDsnTiar == 1 then do
ggRes = ggRes || sqlDsntiar()
ggWa = sqlMsgWarn(sqlWarn)
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
end
if m.sqlMsgCa == 1 then
ggRes = ggRes'\n'sqlMsgCa()
end
ggSqlSp = ' ,:+-*/&%?|()[]'
ggXX = pos(':', ggSqlStmt)+1
do ggSqlVx=1 to 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ggSqlSp, 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggSqlVa.ggSqlVx = substr(ggSqlStmt, ggXX, ggYY - ggXX)
do ggQQ = ggXX-2 by -1 to 1 ,
while substr(ggSqlStmt, ggQQ, 1) == ' '
end
do ggRR = ggQQ by -1 to 1 ,
while pos(substr(ggSqlStmt, ggRR, 1), ggSqlSp) < 1
end
if ggRR < ggQQ & ggRR > 0 then
ggSqlVb.ggSqlVx = substr(ggSqlStmt, ggRR+1, ggQQ-ggRR)
else
ggSqlVb.ggSqlVx = ''
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
ggSqlVa.0 = ggSqlVx-1
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW2 = translate(word(ggSqlStmt, 2))
ggW3 = translate(word(ggSqlStmt, 3))
if ggW2 == 'PREPARE' then
ggRes = ggRes || sqlMsgSrF('FROM')
else if ggW2 ggW3 == 'EXECUTE IMMEDIATE' then
ggRes = ggRes || sqlMsgSrF(1)
else
ggRes = ggRes || sqlMsgSrF()
end
ggRes = ggRes'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
do ggXX=1 to ggSqlVa.0
ggRes = ggRes || ggPref ggSqlVb.ggXX ':'ggSqlVa.ggXX ,
'=' value(ggSqlVa.ggXX)
ggPref = '\n '
end
if abbrev(ggRes, '\n') then
return substr(ggRes, 3)
return ggRes
endSubroutine sqlMsg
sqlMsgSrF:
parse arg ggF
if ggF \== '' & \ datatype(ggF, 'n') then do
do ggSqlVx=1 to ggSqlVa.0
if translate(ggSqlVb.ggSqlVx) = ggF then
return sqlMsgSrc(value(ggSqlVa.ggSqlVx), sqlErrd.5)
end
end
if datatype(ggF, 'n') & ggF <= ggSqlVa.0 then
return sqlMsgSrc(value(ggSqlVa.ggF), sqlErrd.5)
return sqlMsgSrc(ggSqlStmt , sqlErrd.5)
endSubroutine sqlMsgSrF
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar:
sqlWarn = sqlWarn.0 || sqlWarn.1 || sqlWarn.2 || sqlWarn.3,
|| sqlWarn.4 || sqlWarn.5 || sqlWarn.6 || sqlWarn.7,
|| sqlWarn.8 || sqlWarn.9 || sqlWarn.10
if sqlCode = -438 then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState,
'and DIAGNOSTIC TEXT:' sqlErrMc
if digits() < 10 then
numeric digits 10
sqlCa = d2c(sqlCode, 4) ,
|| d2c(max(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarn || sqlState
if length(sqlCa) <> 124 then
call err 'sqlDa length' length(sqlCa) 'not 124' ,
'\nsqlCa=' sqlMsgCa()
return sqlDsnTiarCall(sqlCa)
/*--- call dsnTiar o translate sql Info to error text ----------------*/
sqlDsnTiarCall: procedure expose m.
parse arg ca
liLe = 78
msLe = liLe * 10
if length(ca) <> 124 then
call err 'sqlDa length' length(ca) 'not 124:' ca', hex='c2x(ca)
ca = 'SQLCA ' || d2c(136, 4) || ca
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg LEN"
if rc <> 0 then
call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = ''
do c=3 by liLe to msLe
if c = 3 then do
l1 = strip(substr(msg, c+10, 68))
cx = pos(', ERROR: ', l1)
if cx > 0 then
l1 = left(l1, cx-1)':' strip(substr(l1, cx+9))
res = res'\n'l1
end
else if substr(msg, c, 10) = '' then
res = res'\n 'strip(substr(msg, c+10, 68))
else
leave
end
return res
endProcedure sqlDsnTiarCall
sqlMsgCa:
ggWarn = ''
do ggX=0 to 10
if sqlWarn.ggX \== ' ' then
ggWarn = ggWarn ggx'='sqlWarn.ggx
end
if ggWarn = '' then
ggWarn = 'none'
return 'sqlCode' sqlCode 'sqlState='sqlState,
'\n errMC='translate(sqlErrMc, ',', 'ff'x),
'\n warnings='ggWarn 'erP='sqlErrP,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlMsgCa
/*--- make the text for sqlWarnings
input warn.0..warn.10 as a 11 character string ------------*/
sqlMsgWarn: procedure expose m.
parse arg w0 2 wAll
if w0 = '' & wAll = '' then
return ''
if length(wAll) \= 10 | ((w0 = '') <> (wAll = '')) then
return 'bad warn' w0':'wAll
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = substr(wAll, wx, 1)
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx < 1 then
r = r wx'='w '?,'
else
r = r substr(text, cx+1, ex-cx)
end
return strip(r, 't', ',')
endProcedure sqlMsgWarn
sqlMsgSrc: procedure expose m.
parse arg src, pos, opt
if 0 then do /* old version, before and after txt */
tLe = 150
t1 = space(left(src, pos), 1)
if length(t1) > tLe then
t1 = '...'right(t1, tLe-3)
t2 = space(substr(src, pos+1), 1)
if length(t2) > tLe then
t2 = left(t2, tLe-3)'...'
res = '\nsource' t1 '<<<error>>>' t2
end
liLe = 68
liCn = 3
afLe = 25
if translate(word(src, 1)) == 'EXECSQL' then
src = substr(src, wordIndex(src, 2))
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedur sqlMsgSrc
/*--- 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
address tso 'DSN SYSTEM('sys')'
rr = rc
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 fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
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 == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
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, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
fmtTime: procedure expose m.
parse arg s, signed
return fmtUnits(s, 't', signed==1)
endProcedure fmtTime
fmtDec: procedure expose m.
parse arg s, signed
return fmtUnits(s, 'd', signed==1)
endProcedure fmtDec
fmtUnits: procedure expose m.
parse arg s, scale, signed
if s >= 0 then
res = fmtUnitsNN(s, scale, wi)
else
res = '-'fmtUnitsNN(abs(s), scale, wi)
len = m.fmt.units.scale.f.length + signed
if length(res) <= len then
return right(res, len)
if \ abbrev(res, '-') then
return right(right(res, 1), len, '+')
if length(res) = len+1 & datatype(right(res, 1), 'n') then
return left(res, len)
return right(right(res, 1), len, '-')
endProcedure fmtUnits
fmtUnitsNN: procedure expose m.
parse arg s, scale
sf = 'FMT.UNITS.'scale'.F'
sp = 'FMT.UNITS.'scale'.P'
if m.sf \== 1 then do
call fmtIni
if m.sf \== 1 then
call err 'fmtUnitsNN bad scale' scale
end
do q=3 to m.sp.0 while s >= m.sp.q
end
do forever
qb = q-2
qu = q-1
r = format(s / m.sp.qb, ,0)
if q > m.sf.0 then
return r || substr(m.sf.units, qb, 1)
if r < m.sf.q * m.sf.qu then
return (r % m.sf.qu) || substr(m.sf.units, qu, 1) ,
|| right(r //m.sf.qu, m.sf.width, 0)
/* overflow because of rounding, thus 1u000: loop back */
q = q + 1
end
endProcedure fmtUnitsNN
fmtIni: procedure expose m.
if m.fmt.ini == 1 then
return
m.fmt.ini = 1
call fmtIniUnits 't', '?smhd', 0 100 60 60 24 100, 0.01, 2
call fmtIniUnits 'd', '?.kMGTPE', 0 copies('1000 ',8), 0.001, 3
return
endProcedure fmtIni
fmtIniUnits: procedure expose m.
parse arg sc, us, fact, prod, wi
sf = 'FMT.UNITS.'sc'.F'
sp = 'FMT.UNITS.'sc'.P'
m.sf.0 = words(fact)
if length(us) + 1 <> m.sf.0 then
call err 'fmtIniUnits mismatch' us '<==>' fact
m.sf.1 = word(fact, 1)
m.sp.1 = prod
do wx=2 to m.sf.0
wx1 = wx-1
m.sf.wx = word(fact, wx)
m.sp.wx = m.sp.wx1 * m.sf.wx
end
m.sp.0 = m.sf.0
m.sf.units = us
m.sf.width = wi
m.sf.length= 2 * wi + 1
m.sf = 1
return
endProcedure fmtIniUnits
/* copy fmt 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
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
m.map.inlineSearch = 1
call mapReset map.inlineName, map.inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map.inlineName, pName) then do
im = mapGet(map.inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map.inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'MAP.INLINE.' || (m.map.inline.0+1)
call mapAdd map.inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map.inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map.inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
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, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- 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 if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
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
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* 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
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr, newCd, freeCd
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
m.a.newCode = newCd
m.a.freeCode = freeCd
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mBasicNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mBasicNew
mNew: procedure expose m.
labelMNew:
parse arg name, arg, arg2, arg3
m = mBasicNew(name)
interpret m.ggArea.newCode
return m
endProcedure mNew
mReset: procedure expose m.
parse arg a, name
ggArea = m.m.n2a.name
m = a
interpret m.ggArea.newCode
return m
endProcedure mReset
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
if m.area.freeCode \== '' then
interpret m.area.freeCode
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- 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
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- 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 mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- 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 || '.'
m.m.area.0 = 0
call mNewArea
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 expose m.
parse upper 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 expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
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 expose m.
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 expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
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 expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
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 expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
call dsnAlloc 'dd('m.m.dd')' m.m.dsn
call readDDBegin m.m.dd
return m
endProcedure readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
ix = m.m.cx + 1
m.m.cx = ix
if m.m.cx <= m.m.0 then
return m'.'ix
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readnxPos: procedure expose m.
parse arg m, le
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call readDDEnd m.m.dd
call tsoFree m.m.dd
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
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
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- 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, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
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 di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
return al
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
if abbrev(atts, ':') then do
parse var atts a1 atts
bl = 32760
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(a1, 2, 1) 'b'
end
if forCsm then
atts = atts "recfm("space(recfm, 0)") lrecl("rl")",
"blkSize("bl")"
else
atts = atts "recfm("recfm") lrecl("rl") block("bl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
atts = atts 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
atts = atts 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
if forCsm then
atts = atts 'space(10, 1000) cylinder'
else
atts = atts 'space(10, 1000) cyl'
if dsn == '' then
return atts
return "dataset('"dsnSetMbr(dsn)"')" atts
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
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso 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 errOS() \== 'LINUX' 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
/*--- error routine: user message cleanup exit -----------------------*/
errEx:
parse arg ggTxt
call errIni
call outPush
call errSay ggTxt
call errCleanup
exit 8
endProcedure errEx
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
/*--- 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 ax=1 to arg()
say ' ' arg(ax)
end
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
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
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 *****************************************************/
/* copy ut begin *****************************************************/
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement only if NotNull:
assign the second argument to the variable with name in first arg
if the second arg is not null, return new value ---------------*/
assIf:
if arg(2) == '' then
return value(arg(1))
call value arg(1), arg(2)
return arg(2)
/*--- return first nonNull argument ---------------------------------*/
nn:
if arg(1) \== '' then
return arg(1)
if arg(2) \== '' then
return arg(2)
call err 'nn() both args empty'
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- 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
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- elongate inp with spaces up to given len -----------------------*/
elong: procedure expose m.
parse arg inp, len
if length(inp) >= len then
return inp
return left(inp, len)
endProcedure elong
/*--- 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
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/* copy ut end ********************************************************/