zOs/REXX.O08/DB2COARC
/* rexx ****************************************************************
Synopsis Db2CoArc <subsys> <phase>
Db2CoArc hat zwei Phasen
gen bestimmt die zu archvierenden Copies,
seit dem letzten abgeschlossenen VorgaengerJob (TADM62A1)
schreibt den Input für IDCAMS und Statistik
check überprüft den Output von IDCAMS (auf Anzahl Alter)
ExtraFunktion
dist distribution statistics
Input Phase gen
dd TST: aktueller Timestamp, Managment class,
creator und Name der Statistik Tabelle Tadm62a1
dd COPIES: DsnTiaul Ouput von SysCopy (full + increm Copies)
sortiert nach db, ts, part, timestamp DESC
TADM62A1: Timestamp des letzten abgeschlossenen VorgaengerJobs
Output Phase gen
dd ALTER: Alter Management Class statements für IDCAMS
TADM62A1: insert mit aktuellem Timestamp, Status=G und Statistik
Input Phase gen
dd TST: wie oben
dd ALOUT: Sysprint von IDCAMS
dd DIST : Distripbution DCAMS
TADM62A1: in Input Phase erzeugtes Tupel
Output Phase gen
TADM62A1: update Status=E (falls ok, sonst Fehlermeldung)
Input dist
dd TST: aktueller Timestamp, Managment class,
creator und Name der Statistik Tabelle Tadm62a1
dd COPIES: DsnTiaul Ouput von SysCopy, sortiert
Output dist
dsn DSN.QMW1000.DIST(Dmmddhhj) -- monat tag stunde Minute (1.St.)
enthält die kumulierten copies pro db
und die Verteilung nach Stunde des vorherigen Copies
************************************************************************
22.05.08 W.Keller, job output redigiert v1.03
*/ /* end of help
22.05.08 W.Keller, dist ergaenzt mit Jobs die zuSchnellArchivieren v1.02
16.05.08 W.Keller, zusaetzlich Kommentare v1.01
17.03.08 W.Keller, kiut 23 neu v1.00
************************************************************************
Hinweise
UnterModule: sind mit copy <modul> begin
und copy <modul> end
eingerahmt, und beginnen meist einen Ueberblick Kommentar
Memory Modell (m.) see comment at 'copy m begin'
Statistik Tabelle Tadm62A1
wir benutzen timestamp als primary key ( = curr) und
status (G nach gen, E nach check)
die restlichen Felder fuellt gen mit Statistik-Werten:
LABEL ON OA1T.TADM62A1
(OLDSIZE IS 'size(B) old copies',
OLDCOUNT IS 'count old copies',
ALTSIZE IS 'size(B) new copies',
ALTCOUNT IS 'count alter copies',
NEWSIZE IS 'size(B) alter copies',
NEWCOUNT IS 'count new copies',
STATUS IS 'Generiert, Erledigt',
TIMESTAMP IS 'timestamp of run');
***********************************************************************/
/*-- main code -------------------------------------------------------*/
parse upper arg subsys phase m.opt
ddTst = '-TST'
ddCop = '-COPIES'
ddALT = '-ALTER'
ddAOU = '-ALOUT'
if subsys = '' then do
/* für online tests ==> auf if 0 then ändern */
if 1 then
call errHelp 'keine Argumente mitgegeben'
parse upper value 'dbTf gen 2008-04-20' with subsys phase m.opt
/* für online tests ==> private Datasets benutzen */
ddTst = DSN.QMW1900.DBTF.TST
ddCOP = DSN.QMW1900.DBTF.COPIES
ddAlt = '~tmp.text(db2CoArc)'
ddAOU = DSN.QMW1000.DBAF.ALOUT
say '*** test test benutze test inputs/outputs ***'
end
say myTime() 'Db2CoArc version 1.03 db2Subsys' subsys 'phase' phase
call errReset 'h' /* initialize modules */
call mapIni
curr = readTimestamp(ddTst) /* timestamp dieses Jobs einlesen */
call sqlConnect subsys
if phase = 'GEN' then do
last = selectLast(curr)
call genAlter curr, last, ddCop, ddAlt
call insertStatistics curr, last
end
else if phase = 'CHECK' then do
call selectStats curr
if ^ checkAlterOutput(ddAOu) then
call err 'AlterOuput hat Fehler'
call updateStats curr, 'E'
end
else if phase = 'DIST' then do
ddDist= 'DSN.QMW1000.'subsys'.DIST(D' ,
|| substr(date(s), 5)translate(124, time(), 1234)') ::V'
call genDistribution curr, subsys, ddCop, ddDist, m.opt
end
else do
call errHelp 'ungueltige Phase' phase 'in args' arg(1)
end
call sqlDisconnect
exit
/*--- timestamp und managment Class aus inputfile lesen --------------*/
readTimestamp: procedure expose m.
parse arg ddTst
call readDsn ddTst, i.
if i.0 <> 1 then
call err 'tst input hat' i.0 'records statt 1'
parse var i.1 tst m.mgmtClas m.crTb o
m.opt = m.opt o
return tst
endProcedure readTimestamp
/*--- letzten fertigen Job aus %.TADM62A1 selektieren ---------------*/
selectLast: procedure expose m.
parse arg curr
call sqlPreOpen 1, 'select timestamp , status',
'from' m.crTb,
'order by 1 desc', '*'
do while sqlFetchInto(1, ':tst, :sta') & sta <> 'E'
say 'ueberspringe nicht abgeschlossenen VorgaengerJob von' tst ,
', status' sta
end
call sqlClose 1
if sta = 'E' then do
say 'letzter abgeschlossener VorgaengerJob' tst
return tst
end
else do
say 'keinen abgeschlossenen VorgaengerJob gefunden'
if sqlPreAllCl(1, "select timestamp('"curr"') - 2 days la",
'from sysibm.sysDummy1', st, ':tst') <> 1 then
call err 'could not select (timestamp curr' curr') - 2 days'
say 'letzter Zeitpunkt gewählt' tst
return tst
end
endProcedure selectLast
/*--- aktuellen Job aus %.TADM62A1 selektieren ----------------------*/
selectStats: procedure expose m.
parse arg curr
if sqlPreAllCl(1, 'select timestamp tst, status, altCount' ,
'from' m.crTb ,
"where timestamp = '"curr"'",
, st, ':m.s.tst, :m.s.status, :m.s.altCount') <> 1 then
call err m.st.0 'statistics found for' curr
say 'Statistik gefunden' m.s.tst', status' m.s.status ,
|| ', alters' m.s.altCount
if m.s.status <> 'G' then
call err 'status muss G sein, nicht' m.s.status
return
endProcedure selectStats
/*--- Status in %.TADM62A1 updaten -----------------------------------*/
updateStats: procedure expose m.
parse arg curr, sta
call sqlExImm "update" m.crTb ,
"set status = '"sta"'" ,
"where timestamp = '"curr"'"
call sqlCommit
return
endProcedure updateStats
/*--- die alter managementClass generieren -----------------------------
curr: timestamp des aktuellen Jobs,
alle neueren SysCopy Eintraege ignorieren
last: timestamp des letzten VorgaengerJobs
ddCop: Spez des input Files mit DsnTiaul output
ddAlt: Spez des output Files für Alter Statements --------------*/
genAlter: procedure expose m.
parse arg curr, last, ddCop, ddAlt
say myTime() 'generiere alter fuer'
say ' aktuell ' curr '* neuere SysCopies ignorieren'
say ' Vorgaenger ' last '* SysCopies ignorieren, die von diesem'
say left('', 39) '* oder frueheren Jobs geAlterT wurden'
say left(' mgmtClas ' m.mgmtClas, 39) '* auf diese class alterN'
ddaa = dsnAlloc(ddCop)
dd = word(ddaa, 1) /* der ddName sitzt im ersten Wort */
call readDDBegin dd /* lesen initialisieren */
outAl = dsnAlloc(ddAlt)
out = word(outAl, 1)
call writeDDBegin out
call mCut o, 0
z = 0
cDb = 0
cTs = 0
cPa = 0
old = ''
keys = 'NN WN WW ON OW OO TOT'
/*--------------------------------------------------------------
hier finden wir heraus, welche copies geAltert werden sollen
1) es gibt eine neuere fullcopy
2) die VorgaengerJob haben es noch nicht geAltert
wir lesen die Syscopies gruppiert nach TS-Partition ein
und timestamp Desc ein
also können mit einer kleine StateMachine arbeiten:
the states of the state machine
NN WN WW ON OW OO
the state consists of two characters
staT time:
N = new timestamp > curr
W = window curr >= timestamp > last
O = old last >= timestamp
staM migration: when was the next fullCopy found
N = new tst fullC > curr ==> on disk
W = window curr >= tst fullC > last ==> migrate
O = old last >= tst fullC ==> archived
--------------------------------------------------------------*/
staTxt.n = 'keines'
staTxt.W = 'nach VorgaengerJob'
staTxt.O = 'vor VorgaengerJob'
do kx=1 to words(keys)
ky = word(keys, kx)
m.s.ky.f.By = 0 /* full bytes */
m.s.ky.f.cn = 0 /* full count */
m.s.ky.i.By = 0 /* incremental bytes */
m.s.ky.i.cn = 0 /* incremental count */
end
do while readDD(dd, i., 1000) /* einen Block lesen */
do y=1 to i.0 /* jede Zeile des Blocks */
z = z + 1
if wordPos(length(i.y), 116 124) < 1 then /* bad input */
call err 'inp len' length(i.y) '<> 116,124:' z i.y
/* hin und wieder zeigen, dass wir noch arbeiten */
if z // 10000 = 0 then
say 'gelesen:' z 'copies,' cDb 'db,' cTs 'ts,' ,
cPa 'pa:' db'.'ts':'pa
/* Gruppenbrueche */
if old ^== left(i.y, 20) then do /* new partition */
if old ^== '' & staM ^== 'O' then
say 'warnung' db'.'ts':'pa,
'letzes copy' staTxt.staT',' ,
'letzes FULLcopy' staTxt.staM
if left(old, 8) ^== left(i.y, 8) then do
cDb = cDb+1
db = strip(left(i.y, 8))
end
if left(old, 16) ^== left(i.y, 16) then do
cTs = cTs+1
ts = strip(substr(i.y, 9, 8))
end
cPa = cPa + 1
pa = c2d(substr(i.y, 17, 4))
old = left(i.y, 20)
staM = 'N'
lastTst = '9999-99'
end
parse var i.y 21 tst 47 tp 48 dsn . 92 bytes .
if tst >> lastTst then
call err 'timestamp >> last' lastTst':' z i.y
if tst <= last then
staT = 'O'
else if tst <= curr then
staT = 'W'
else
staT = 'N'
if staM == 'W' then
call mAdd o, ' ALTER' dsn 'MGMTCLAS('m.mgmtClas')'
sta = staT || staM
/* say sta tp tst dsn */
m.s.sta.tp.cn = m.s.sta.tp.cn + 1
m.s.sta.tp.by = m.s.sta.tp.by + bytes
if tp = 'F' then
staM = staT
end /* jede Zeile des Blocks */
if m.o.0 > 1000 then do /* output schreiben */
call writeDD out, 'M.O.'
call mCut o, 0
end
end /* einen Block lesen */
call mAdd o, ' IF MAXCC > 4 -' ,
, ' THEN IF MAXCC <= 12 -' ,
, ' THEN SET MAXCC=4'
if m.o.0 > 00 then
call writeDD out, 'M.O.'
call writeDDend out
interpret subWord(outAl, 2)
call readDDEnd dd
interpret subWord(ddAa, 2)
say ''
say myTime() 'gelesen:' z 'copies,' cDb 'db,' cTs 'ts,' cPa 'pa'
return
endProcedure genAlter
/*--- print statistics and insert it into %.TADM62A1 ----------------*/
insertStatistics: procedure expose m.
parse arg curr, last
alCn = m.s.WW.f.cn + m.s.WW.i.cn + m.s.OW.f.cn + m.s.OW.i.cn
alBy = m.s.WW.f.by + m.s.WW.i.by + m.s.OW.f.by + m.s.OW.i.by
say 'Alter generiert fuer' alCn 'copies mit' alBy 'bytes'
call statsFmt 'auf Disk > ' curr, NN
call statsFmt 'auf Disk' , WN
call statsFmt 'Alter ' , WW
call statsFmt 'auf Disk <=' last, ON
call statsFmt 'Alter <=' last, OW
call statsFmt 'archiviert <=' last, OO
call sqlExImm "insert into" m.crTb,
"(TIMESTAMP, STATUS, newCount, newSize," ,
"altCount, altSize, oldCount, oldSize)",
"values('"curr"', 'G',",
(m.s.WN.f.cn + m.s.WN.i.cn + m.s.ON.f.cn + m.s.ON.i.cn) ",",
(m.s.WN.f.by + m.s.WN.i.by + m.s.ON.f.by + m.s.ON.i.by) ",",
alCn"," alBy ",",
(m.s.OO.f.cn + m.s.OO.i.cn ) ",",
(m.s.OO.f.by + m.s.OO.i.by ) ,
")"
call sqlCommit
return
endProcedure insertStatistics
/*--- print, format one statistics line, sum it up -------------------*/
statsFmt:
parse arg tit, ky
if m.s.title ^== 1 then do
say ''
say left('', 40) left('full.copies', 9+1+8, '.') ,
left('incremental.copies', 9+1+8, '.')
say left('', 40) right('Anzahl', 9) right('Bytes', 8) ,
right('Anzahl', 9) right('Bytes', 8)
m.s.title = 1
end
say left(tit, 40) right(m.s.ky.f.cn, 9),
format(m.s.ky.f.by, 1, 2, 2, 0),
right(m.s.ky.i.cn, 9) ,
format(m.s.ky.i.by, 1, 2, 2, 0)
if ky <> 'TOT' then do
m.s.tot.f.cn = m.s.tot.f.cn + m.s.ky.f.cn
m.s.tot.f.by = m.s.tot.f.by + m.s.ky.f.by
m.s.tot.i.cn = m.s.tot.i.cn + m.s.ky.i.cn
m.s.tot.i.by = m.s.tot.i.by + m.s.ky.i.by
end
return
endProcedure statsFmt
/*-- count the alters in the ouput and compare to statistics ---------*/
checkAlterOutput: procedure expose m.
parse arg ddOut
inpAA = dsnAlloc(ddOut)
dd = word(inpAA, 1)
call readDDBegin dd
cAlt = 0
do while readDD(dd, i.)
do x= 1 to i.0
cAlt = cAlt + (word(substr(i.x, 2), 1) = 'ALTER')
end
end
call readDDEnd dd
interpret subword(inpAA, 2)
say cAlt 'Alter gefunden in AlterOutput'
if cAlt <> m.s.altCount then
call err 'Alter' cAlt 'in AlterOuput <>' ,
m.s.altCount 'in Statistik Table'
return 1
endProcedure checkAlterOutput
/*-- distribution ermitteln:--------------------------------------------
analog wie in genAlter lesen wir den sql Ouput und bestimmen
welche Copies archiviert werden dürfen,
das vergleichen wir mit aktuellen Zustand des Copies
indem wir im MVS Catalog abfragen, ob das Copy
auf Disk, archiviert, auf Tape oder verschwunden ist
Die generierte Statistik gruppiert die copies
nach der Stunde des vorherigen full copies
und zeigt was da auf disk, archiviert, auf tape
oder nicht vorhanden ist
Vorher geben wir bei jedem Datenbankwechsel
die kumulierten Groessen pro Managmentklasse aus
----------------------------------------------------------------------*/
genDistribution: procedure expose m.
parse arg curr, subSys, ddCop, ddDist, jobAfter .
parse var curr y '-' m '-' d '-' h '.'
futu = left(curr, 13)
if m > 1 then
strt = overlay(right(m-1, 2, 0), futu, 6)
else
strt = overlay((y-1)'-12', futu)
futu = left(futu, 11)right(h+1, 2, 0)
drop y m d
say myTime() 'generiere distribution'
say ' future ' futu
say ' von ' curr
say ' nach ' strt
say ' managementClass' m.mgmtClas
ddaa = dsnAlloc(ddCop)
dd = word(ddaa, 1)
call readDDBegin dd
call mapReset claC, 'K'
call mapReset claB
call mapReset jobs, 'K'
m.o.0 = 0
call mAdd o, futu 'future'
call mAdd o, curr 'current'
call mAdd o, strt 'start'
call mAdd o, date(s)'-'time() 'runtime'
call mAdd o, '-- kumulierte Groessen pro MgmtClas nach jeder DB'
call mAdd o, claSum()
laDb = ''
z = 0
cTs = 0
cPa = 0
old = ''
cBef = 0
cIn = 0
cAft = 0
cFNC = 0
cFMi = 0
/* sql output lesen */
do while readDD(dd, i., 1000) /* einen block lesen */
do y=1 to i.0 /* jeder record des Blocks */
if wordPos(length(i.y), 116 124) < 1 then /* bad input */
call err 'inp len' length(i.y) '<> 116,124:' z i.y
if z // 1000 = 0 then
call distCountSay
z = z + 1
if old ^== left(i.y, 20) then do /* new partition */
if left(i.y, 16) ^== laTs then do /* new ts */
drop csi.
laTs = left(i.y, 16)
cTs = cTs + 1
/* Optimierung: CSI Abfrage für alle
copies dieses TS mit standard namen */
csiPref = subsys'.'strip(left(i.y, 8)),
|| '.'strip(substr(i.y, 9, 8))'.'
call csiOpen cc, csiPref'**',
, 'volSer mgmtClas devTyp'
do while csiNext(cc, c)
coNa = strip(m.c.dsn)
csi.coNa = csiArcTape(m.c.volser, m.c.mgmtClas,
, m.c.devTyp, m.c.dsn)
end
end
if left(i.y, 8) ^== laDb then do /* new db */
if laDb <> '' then /* mgmtClas total schreiben */
call mAdd o, claSum(laDb)
laDb = left(i.y, 8)
end
laFu = futu
cPa = cPa + 1
old = left(i.y, 20)
end
parse var i.y 21 tst 47 tp 48 coNa . 92 bytes . 117 job .
if abbrev(coNa, csiPref) then do
/* csi Abfrage für standard Namen schon gemacht */
if symbol('csi.coNa') = 'VAR' then
cl = csi.coNa
else
cl = 'no'
end
else do
/* Namen nicht standard: csi Abfrage */
call csiOpen cc, coNa, 'volSer mgmtClas devTyp'
if ^ csiNext(cc, c) then
cl = 'no'
else if coNa <> m.c.dsn then
call err 'coNa' coNa '<> dsn' m.c.dsn
else
cl = csiArcTape(m.c.volser, m.c.mgmtClas,
, m.c.devTyp, m.c.dsn)
end
if tst >> curr then do
cAft = cAft + 1
say z cAft 'after' tst coNa
iterate
end
if wordPos(cl, 'arcive tape no') > 0 then
fu = translate(left(cl, 1))
else if wordPos(cl, m.mgmtClas 'A000Y001 SUB#ADB1') > 0 then
fu = 'M'
else
fu = 'D'
if tst << strt then do
cBef = cBef + 1
end
else do
cIn = cIn + 1
IF laFu ^== futu then do
END
else if fu == 'N' then do
say 'future not in catalog' job coNa
cFNC = cFNC + 1
end
else if fu == 'M' then do
cFMi = cFMi + 1
end
end
if symbol('dist.laFu.fu.c') ^== 'VAR' then
call distZero laFu
/* kumulieren unter lastFullCopy und copy zustand */
dist.laFu.fu.c = dist.laFu.fu.c + 1
dist.laFu.fu.b = dist.laFu.fu.b + bytes
/* kumulieren unter Management class */
if ^ mapHasKey(claC, cl) then do
call mapPut claC, cl, 1
call mapPut claB, cl, bytes
end
else do
call mapPut claC, cl, 1 + mapGet(claC, cl)
call mapPut claB, cl, bytes + mapGet(claB, cl)
end
/* falls fullCopy wird er zum neuen LastFullCopy */
if laFu = futu & fu <> 'D' & tst >>= jobAfter then do
jj = job'.'cl
if mapHasKey(jobs, jj) then
call mapPut jobs, jj, bytes + mapGet(jobs, jj)
else
call mapPut jobs, jj, bytes
end
if tp = 'F' then do
laFu = left(tst, 13)
if laFu << strt then
laFu = strt
end
end /* jeder record des Blocks */
end /* einen block lesen */
if laDb <> '' then
call mAdd o, claSum(laDb)
call distCountSay
call mAdd o, '-- Syscopies (Anahl Bytes)',
'gruppiert nach letztem FullCopy Zeitpunkt'
call mAdd o, distFmt() /* titel */
hh = futu
call distZero tot
do while hh >= strt
if symbol('dist.hh.d.c') == 'VAR' then do
call mAdd o, distFmt(hh) /* stats line ausgeben */
end
/* eine Stunde zurück rechnen */
if substr(hh, 12) > 0 then
hh = left(hh, 11)right(substr(hh, 12) - 1, 2, 0)
else if substr(hh, 9, 2) > 1 then
hh = left(hh, 8)right(substr(hh, 9, 2) - 1, 2, 0)'-24'
else if substr(hh, 6, 2) > 1 then
hh = left(hh, 5)right(substr(hh, 6, 2) - 1, 2, 0)'-31-24'
else
hh = (left(hh, 4) - 1)'-12-31-23'
end
call mAdd o, distFmt(tot) /* total ausgeben */
say distFmt()
say distFmt(tot)
call jobSum jobAfter
call writeDsn ddDist, 'M.'o'.', ,1
call readDDend dd
interpret subWord(ddAa, 2)
call distCountSay
return
endProcedure genDistribution
/*--- kumulierte Zahlen pro MgmtClass in eine Zeile konkatinieren ----*/
claSum: procedure expose m.
parse arg db
if db = '' then
return '-- DB mgmtClass count bytes ...'
w = 8
t = left(db, 8)
kk = mapKeys(claC)
do kx=1 to m.kk.0
c = m.kk.kx
t = t left(c, 8) right(mapGet(claC, c), w) ,
format(mapGet(claB, c), 1, 2, 2, 0)
end
return t
endProcedure claSum
/*--- laufende Kumulationen anzeigen,
damit das warten auf das Programmende unterhaltsamer wird ------*/
distCountSay:
say myTime() 'copies' z', ts' cTs', pa' cPa csiPref
say right('before', 24) cBef', in' cIn', after' cAft,
|| ', futNoCat' cFNC', futToMig' cFMi
return
end distCountSay
jobSum: procedure expose m.
parse arg jobAfter
call mAdd o, "-- jobs nach '"jobAfter"'" ,
"mit zuschnell archivierenden mgmtClasses"
call mAdd o, '-- job bytes mgmtclasses'
cc = mapKeys(claC)
jj = mapKeys(jobs)
do jx=1 to m.jj.0
joCl = m.jj.jx
parse var joCl jo '.' cl
if done.jo = 1 then
iterate
done.jo = 1
m = ''
by = 0
do cx=1 to m.cc.0
if mapHasKey(jobs, jo'.'m.cc.cx) then do
by = by + mapGet(jobs, jo'.'m.cc.cx)
m = m m.cc.cx
end
end
call mAdd o, left(jo, 9) format(by, 1, 4, 2, 0) m
end
return
endProcedure jobSum
/*--- print, format one statistics line, sum it up -------------------*/
distFmt:
parse arg ky
w = 8
v = w + 9
if ky = '' then
return left('-- lastFullCopy', 17) left('onDiskOrig', v) ,
left('onDiskToArc', v) left('archived', v) ,
left('tape', v) left('notinCat', v)
if ky ^== tot then
do tx=1 to words(dist.keys)
tt = word(dist.keys, tx)
dist.tot.tt.C = dist.tot.tt.C + dist.ky.tt.C
dist.tot.tt.B = dist.tot.tt.B + dist.ky.tt.B
end
return left(ky, 13) ,
right(dist.ky.d.c, w) format(dist.ky.d.b, 1, 2, 2, 0) ,
right(dist.ky.m.c, w) format(dist.ky.m.b, 1, 2, 2, 0) ,
right(dist.ky.a.c, w) format(dist.ky.a.b, 1, 2, 2, 0) ,
right(dist.ky.t.c, w) format(dist.ky.t.b, 1, 2, 2, 0) ,
right(dist.ky.n.c, w) format(dist.ky.n.b, 1, 2, 2, 0)
endProcedure distFmt
/*--- Statistik Eintrag auf Null setzen -----------------------------*/
distZero: procedure expose m. dist.
parse arg ky
dist.keys = 'D M A T N'
do tx=1 to words(dist.keys)
tt = word(dist.keys, tx)
dist.ky.tt.C = 0
dist.ky.tt.B = 0
end
return
endProcedure distZero
myTime: procedure
return time()
/* Programm Ende
ab hier kommen nur noch allgemeine Unterfunktionen ************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o.dsn and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) ^== 'Y' then do
m.m.pos = px
m.o.dsn = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o.dsn = substr(m.m.work, px+2, 44)
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o.dsn 'flag' c2x(flag) */
if eType == '0' then do
if flag ^== '00'x & flag ^== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o.dsn
px = px + 50 /* length of catalog entry */
iterate
end
else do
if ^ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o.dsn,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o.dsn
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') ^= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') ^= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') ^= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm: procedure expose m.
parse arg src
call sqlExec 'execute immediate :src'
return
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure
parse arg ggSys, ggRetCon
call sqlIni
if adrTSO("SUBCOM DSNREXX", '*') <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
call sqlExec "connect" ggSys, ggRetCon ,1
return
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure
parse arg ggRet
call sqlExec "disconnect ", ggRet, 1
return
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()[]', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
rr = adrTso('DSN SYSTEM('sys')', '*')
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure
parse arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx ^== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le ^== '') || sp ,
|| left('.', ri ^== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use ="dd
if dd = '' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 to 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
leave
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
return atts 'mgmtclas(s005y000) space(10, 1000) cyl'
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = ''
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
if abbrev(a, 'MAP.') then do
do kx=1 to m.map.loKy.a.0
drop m.map.loKy.a.kx m.map.loVa.a.kx
end
m.map.loKy.a.0 = 0
end
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
if mapValAdr(a, ky) ^== '' then
call err 'duplicate key in mAdd('a',' ky',' val')'
if length(ky) < 200 then do
m.a.ky = val
end
else do
kx = mInc('MAP.LOKY.'a'.0')
m.map.loKy.a.kx = ky
m.map.loVa.a.kx = val
end
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky)
if vv ^== '' then
m.vv = val
else
call mapAdd a, ky, val
return val
endProcedure mapPut
/*--- return the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg a, ky
if length(ky) < 200 then do
if symbol('m.a.ky') == 'VAR' then
return a'.'ky
end
else if ^ abbrev(a, 'MAP.') then do
call err 'key too long mapValAdr('a',' ky')'
end
else do
do kx=1 to m.map.loKy.a.0
if m.map.loKy.a.kx == ky then
return 'MAP.LOVA.'a'.'kx
end
end
return ''
endProcedure mapValAdr
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if abbrev(vv, 'MAP.LOVA.') then
call err 'not implemented mapRemove('a',' ky')'
drop m.a.ky
return val
endProcedure mapRemove
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a,
fail if it does not exist ----------------------------------*/
mapGet: procedure expose m.
parse arg a, ky, noKey
vv = mapValAdr(a, ky)
if vv == '' then
call err 'missing key in mapGet('a',' ky')'
return m.vv
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy m begin ********************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddAt
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/*--- cat all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if ^ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/