zOs/REXX/REPA
/***********************************************************************
synopsis: repa optDsn? fun opts
optDsn gibt den DSN der Optionen an, als Editmacro ist das nicht
nötig, da wird der aktuelle editierte DSN genommen
fun n neue Optionen(vorlage) erstellen. Membername max 4 Zeichen.
Table(spaces), DSN's usw. in Variabeln fuellen.
Die Optionen werden als Rexx interpretiert.
m Map Member erstellen zur Zuordnung der alten zu neuen
Partitionen.
Optionen: pN? pO? O
falls pN und pA fehlen wird map aus old und new DDL
abgeleitet. Sie enthält als Info alle Keys.
pN Anzahl neue partitionen
pO Anzahl alte partitionen, Default pN
pN und pO repartitieren linear
O die Option 'O' erzeugt eine Map mit Overlaps,
wenn ein neuer Key = einem alten ist
0 unload limit 0 Job erzeugen. Sie submitten ihn, um das
Punchfile zu erzeugen
j restliche Jobs erstellen
unlo unload alte table
unl2 zweiter Unload als KatastrophenSicherung
load load neue table
reRu Runstats und Rebuild Index (parallel)
rebi Rebind
cnt Count alte Table
Ablauf Repartitionierung:
-sta ro sub unlo, back und cnt (parallel|) entladen, backup, count
drop und create TS ohne Indexe, Primary Key usw.
-sta ut sub load neuen TS laden
und ALLENFALLS gleichzeitig sub rebi (siehe Ausfall)
-sta rw create Indexe (mit DEFER), primary Key usw.
-sta ut sub reRu : Runstats TS und parallel Rebuild Indexe
Count neu (Runstats TB) mit alt (job ....Cnt) vergleichen
sub rebi: Rebind Packages
-sta rw
**** history ***********************************************************
8. 2.2013 W. Keller neue LImit Syntax, vergleich von Hex Werten
******************** end of help */ /***********************************
13. 4.2010 W. Keller Warnung wegen Ausfall
16. 2.2010 W. Keller ManagementClass COM#A011 + space comment
01.12.2008 W. Keller fix map new old
27.11.2008 W. Keller rewrite
***********************************************************************/
parse arg args
m.debug = 0
call errReset 'h'
em = args = ''
if em then
em = adrEdit('macro (args)', '*') = 0
if args = '' | pos('?', args) > 0 then
exit help()
if length(word(args, 1)) = 1 then do
optDsn = ''
funOpts = args
if ^em then
exit errHelp('either use REPA as editMacro or optDsn argument')
end
else do
parse upper var args optDsn funOpts
em = 0
end
/* now, do the work */
call mapIni
call mapReset v
if em then
call doInEditMacro funOpts
else
call doInTso dsn2Jcl(optDsn), funOpts
exit
/*--- do the work in an editMacro ------------------------------------*/
doInEditMacro: procedure expose m.
parse upper arg fun opts
call adrEdit '(zl) = lineNum .zl', 4
call adrEdit '(lib) = dataset'
call adrEdit '(mbr) = member'
if mbr ^== '' then
optDsn = lib'('mbr')'
if fun = 'N' then do
if zl <> 0 then
call err 'fun n only in empty edit'
call adrEdit 'caps off'
m.opt.0 = 0
end
else do
do lx = 1 to zl
call adrEdit '(line) = line' lx
m.opt.lx = strip(line, 't')
end
m.opt.0 = zl
end
call doWork optDsn, fun, opts
if m.opt.0 <> zl then do
do lx= zl+1 to m.opt.0
line = m.opt.lx
if lx = 1 then
call adrEdit 'line_after .zf = (line)'
else
call adrEdit 'line_after .zl = (line)'
end
end
return
endProcedur doInEditMacro
/*--- do the work in tso ---------------------------------------------*/
doInTso: procedure expose m.
parse upper arg optDsn, fun opts
if fun = 'N' then
m.opt.0 = 0
else
call readDsn optDsn, 'M.OPT.'
zl = m.opt.0
call doWork optDsn, fun, opts
if zl ^== m.opt.0 then
call writeDsn optDsn, 'M.OPT.'
return
endProcedure doInTso
/*--- interpret the opts member and do the work ----------------------*/
doWork: procedure expose m.
parse arg optDsn, fun, opts
call setDefaults optDsn
if fun = 'N' then do
if dsnGetMbr(optDsn) = '' then
call err 'edit rsp. optionDsn must be a',
'library member not' optDsn
call newOpt optDsn
return
end
call interStem opt /* interpret options */
m.jobPref = left(space(m.jobPref, 0)'REPA', 4)
call mapPut v, 'pref', m.dsnPref /* prefix for gen. datasets */
if fun = 'M' then do
parse var opts nPa oPa over /* analyse map options */
if nPa = '' then do
end
else if ^datatype(nPa, n) then do
over = nPa
nPa = ''
end
else if ^datatype(oPa, n) then do
over = oPa
oPa = nPa
end
m.prt.0 = 0
if nPa = '' then do /* analyse ddl and merge keys */
m.partKeyType = ''
call partKey m.old.ddl, ok
call partKey m.new.ddl, nk
call merge prt, nk, ok, over
end
else do /* linear map */
call makeParts prt, nPa, oPa, over
end
call writeEdit m.partMap, prt
end
else if fun = 0 then do
call uLi0Job mCut(u0, 0), old
call writeEdit m.uli0Job, u0
end
else if fun = 'J' then do
/* punch file from unload limit 0 job */
call anaPunch pu, new, m.dsnPref'.'m.old.ts'.PUNLIM0'
call readMap mCut(paMa, 0), m.partMap
call unloJob m.unloJob, old, m.paMa.oldFi, m.paMa.oldLa, 'UNLOA'
call mapPut v, 'pref', m.old.sub'.REPABACK'
call unloJob m.backJob, old, m.paMa.oldFi, m.paMa.oldLa, 'BACKU'
call mapPut v, 'pref', m.dsnPref
call loadJob m.loadJob, new, old, pu, paMa
call reRuJob m.reRuJob, new
call rebiJob m.rebiJob, new
call cntJob m.cntJob, old
end
else do
call err 'fun' fun 'not implemented'
end
return
endProcedure doWork
/*--- write dsn from stem st and, if we are in foreground edit it ----*/
writeEdit: procedure expose m.
parse arg dsn, st
doEd = sysVar('sysEnv') == 'FORE' & sysVar('sysIspf') == 'ACTIVE'
if st ^== '' then do
call mStrip st, 't'
call writeDsn dsn, 'M.'st'.', , ^ doEd
end
if doEd then
call adrIsp "Edit dataset('"dsn"')", 4
return
endProcedure writeEdit
/*--- set the defaults value for optDsn ------------------------------*/
setDefaults: procedure expose m.
parse arg optDsn
pref = dsnSetMbr(optDsn)'('strip(left(dsnGetMbr(optDsn), 4))
m.new.sub = 'DB??' /* db2 subsys for new */
m.new.tb = 'OA1?.????' /* new creator.table */
m.new.ts = '????A1?.A???A' /* new db.tablespace */
m.old.sub = m.new.sub /* db2 subsys for old */
m.old.tb = m.new.tb /* old creator.table */
m.old.ts = m.new.ts /* old db.ts */
m.new.ddl = pref'DNEW)' /*ddl new partition keys*/
m.old.ddl = pref'DOLD)' /*ddl old partition keys*/
m.partMap = pref'MAP)' /* load new */
m.uli0Job = pref'ULI0)' /* unload lim0 old */
m.unloJob = pref'UNLO)' /* unload old */
m.backJob = pref'BACK)' /* unload old */
m.loadJob = pref'LOAD)' /* load new */
m.reRuJob = pref'ReRu)' /* rebuild runstats */
m.rebiJob = pref'Rebi)' /* rebind job */
m.cntJob = pref'Cnt)' /* Count job */
m.jobPref = 'YRPA'
m.jobs = 32
m.skels = 'ORG.U0009.B0106.KIDI63.SKELS' /* skeleton library */
m.dsnPref = 'DSN.REPA'
return
endProcedure setDefaults
/*--- write a new opt dsn --------------------------------------------*/
newOpt: procedure expose m.
parse arg optDsn
s1 = left('',9)
s2 = s1 '* '
s3 = s2 ' '
call mAdd opt,
, s1 left('/* option member for REPA repartitionierung ',
, 60,'*'),
, s2 'use REPA ? for help',
, s2 ,
, s1 'Achtung wegen Space Overflow, allenfalls',
, s3 'mgmtClass=COM#A011 (archive heute) auf',
, s3 'mgmtClass=COM#A013 (archive nach 2 Tagen) aendern' ,
, s2 'mit TES oder StorageManagement absprechen,',
, s3 'und falls nötig selber wieder loeschen',
, s2 ,
, s1 'Ausfall von Programmen minimieren,',
, s3 'falls Packages betroffen, die häufig gebraucht werden,' ,
, s3 'aber nur selten auf unsere Tabellen zugreifen:',
, s2 'rebind zusätzlich nach -sta ut und vor sub load',
, s1 right('*/', 60, '*') ,
, ''
call setDefaults optDsn
call newOpt1 new.sub, 'db2 subsystem for new table'
call newOpt1 new.tb, 'new creator.table'
call newOpt1 new.ts, 'new db.tablespace'
call newOpt1 old.sub 'M.NEW.SUB', 'db2 subsystem for old table'
call newOpt1 old.tb 'M.NEW.TB' , 'old creator.table'
call newOpt1 old.ts 'M.NEW.TS' , 'old db.tablespace'
call newOpt1 new.ddl, 'ddl for new partition keys'
call newOpt1 old.ddl, 'ddl for old partition keys'
call mAdd opt, ''
call newOpt1 partMap, 'map old partitions to new'
call mAdd opt, ''
call newOpt1 uli0Job, 'jobName unload limit 0 old'
call newOpt1 unloJob, 'jobName unloads old'
call newOpt1 backJob, 'jobName backup unloads old'
call newOpt1 cntJob, 'jobName count old table'
call newOpt1 loadJob, 'jobName loads new'
call newOpt1 reRuJob, 'jobName rebuild runStats'
call newOpt1 rebiJob, 'jobName rebind packages'
call mAdd opt, ''
call newOpt1 jobPref, 'jobprefix, max 4 characters'
call newOpt1 jobs , 'number of jobs'
return
endProcedure newOpt
/*--- write one opt line for variable name
with value val rsp. m.name and comment com -----------------*/
newOpt1: procedure expose m.
parse arg name val, com
cx = 40
le = 72
li = left('M.'name, 10) '='
if val <> '' then do
li = li val
end
else do
val = m.name
if datatype(val, n) then
li = li val
else
li = li quote(val, "'")
end
if com <> '' then do
com = '/*' com '*/'
if length(li) < cx & length(com) + cx - 1 <= le then
li = left(li, cx-1)com
else if length(li) + length(com) < le then
li = li com
else if length(li) + length(com) <= le then
li = li || com
else if length(com) + cx - 1 <= le then
call mAdd opt, left('', cx-1)com
else
call mAdd opt, right(com, le)
end
call mAdd opt, li
return
endProcedure newOpt1
/*--- create a map for linear repartition ----------------------------*/
makeParts: procedure expose m.
parse arg o, newP, oldP, over
msg = 'linear repartition into' newP 'new from' oldP 'old parts'
if over = 'O' then
msg = msg 'with overlap'
else if over <> '' then
call err 'bad makeParts overlap' over
say msg
call mAdd o, '*' msg
oldX = 1
do newX=1 to newP
li = newX ':' min(oldX, oldP)
do while newX*oldP > oldX*newP
oldX = oldX + 1
end
equal = newX*oldP = oldX*newP
call mAdd o, li '-' min(oldX+(equal & over = 'O'), oldP)
oldX = oldX + (equal & over = '')
end
return
endProcedure makeParts
/*--- interpret the given dsn as rexx --------------------------------*/
interDsn: procedure expose m.
parse arg dsn
call debug 'interpreting' dsn
call readDsn dsn, m.interDsn.
call interStem interDsn
call debug 'interpreted' dsn
return
endProcedure interDsn
/*--- interpret the lines of stem st as rexx -------------------------*/
interStem: procedure expose m.
parse arg st
s = ''
do x=1 to m.st.0
l = strip(m.st.x)
if right(l, 1) == ',' then /* rexx continuation */
s = s left(l, length(l) - 1)
else
s = s l';' /* separate statements */
end
interpret 'drop st s x l;' s
return
endProcedure interStem
/*--- extract partition keys from ddl to stem o ----------------------*/
partKey: procedure expose m.
parse arg ddl, o
call readDsn ddl, ii.
nrLast = 0
do l=1 to ii.0
line = translate(ii.l)
pc = pos('PART', line)
if pc < 1 then
iterate
if pc > 1 then
if pos(substr(ii.l, pc-1, 1), ' ,(') < 1 then
iterate
ly = l + 1
rest = substr(ii.l, pc) ii.ly
if \ abbrev('PARTITION', word(rest, 1)) then
iterate
val = word(rest, 1)
nrAct = word(rest, 2)
if translate(val) = 'USING' | translate(nrAct) = 'BY' then
iterate
bx = wordIndex(rest, 3)
if bx < 1 then
call err 'rest of partition expected' l':' ii.l
kx = pos('(', rest, bx)
if kx <= bx then
call err '( expected' l':' ii.l
ww = space(translate(substr(rest, bx, kx-bx)), 1)
if ww \== 'VALUES' & ww \== 'ENDING AT' then
call err 'USING or ENDING AT expected' l':' ii.l
if nrAct <> nrLast + 1 then
call err 'partition' (nrLast + 1) 'expected not:' line
val = strip(substr(rest, kx+1))
do while pos(right(val, 1), ",)") > 0
val = strip(left(val, length(val)-1))
end
/* we only handle first key | */
ty = left(val, 1)
if datatype(ty, 'n') then
ty = 9
if ty == "'" & substr(val, 12, 1) == "'" ,
& substr(val, 4, 1) == "." ,
& substr(val, 7, 1) == "." ,
& verify(substr(val,2,2)substr(val,5,2)substr(val,8,4),
, '0123456789') == 0 then do
ty = 'd'
val = substr(val,8,4)'-'substr(val,5,2)'-'substr(val,2,2),
|| substr(val, 13)
end
if m.partKeyType == '' then do
m.partKeyType = ty
if ty = 9 then
say 'Achtung numerische Limitkeys funktionieren nur' ,
'wenn alle dieselbe Stellenzahl haben' ,
copies('|', 160)
end
else if m.partKeyType ^== ty then
call err 'partKey start changed from' m.o.nrLast 'to' val
if nrLast > 0 then
if leq(val, m.o.nrLast) then
call err 'limit key' nrAct val,
'not greater than' m.o.nrLast
m.o.nrAct = val
nrLast = nrAct
end
m.o.0 = nrLast
say m.o.0 'keys in ddl' ddl
if 0 then
do x=1 to m.o.0
say right(x,4) m.o.x
end
return
endProcedure partKey
leq: procedure expose m.
parse arg le, ri
lx = abbrev(translate(le), "X'")
if lx <> abbrev(translate(ri), "X'") then
call err 'leq incompatible le='le', ri='ri
if lx then
return x2c(substr(le, 3, length(le)-3)) ,
<<= x2c(substr(ri, 3, length(ri)-3))
else
return le <<= ri then
endProcedure leq
/*--- merge two set of keys,
show all keys (new and old) as comment --------------------*/
merge: procedure expose m.
parse arg out, n, o, over
msg = 'Repa merge Repartionierung'
o1 = over == 'O'
if o1 then
msg = msg 'with overlap'
else if over ^== '' then
call err 'bad merge overlap' over
say msg
call mAdd out, '* ' msg,
, '* new old',
, '* ' right(m.n.0, 5)right(m.o.0,5) 'number of parts',
, '***'
ox = 1
nx = 1
fBeg = 1
do forever
if nx > m.n.0 then do
if ox > m.o.0 then
leave
call mAdd out, '* ' right('', 5)right(ox, 5) m.o.ox
ox = ox + 1
end
else if ox > m.o.0 | \ leq(m.o.ox, m.n.nx) then do
call mAdd out, '* ' right(nx, 5)right('', 5) m.n.nx
if nx < m.n.0 then do
call mAdd out, right(nx, 8) ':' fBeg '-' min(ox, m.o.0)
fBeg = min(ox, m.o.0)
end
nx = nx + 1
end
else if m.o.ox == m.n.nx then do
call mAdd out, '* ' right(nx, 5)right(ox, 5) m.n.nx
if nx < m.n.0 then do
call mAdd out,right(nx,8) ':' fBeg '-' min(ox+o1,m.o.0)
fBeg = min(ox+1-o1, m.o.0)
end
nx = nx + 1
ox = ox + 1
end
else do
call mAdd out, '* ' right('', 5)right(ox, 5) m.o.ox
ox = ox + 1
end
end
call mAdd out, right(m.n.0, 8) ':' fBeg '-' m.o.0
return
endProcedure merge
/*--- read the map in dsn and write it to stem o
for each new partition one entry x
m.o.x : m.o.x.beg m.o.x.end ----------------------------*/
readMap: procedure expose m.
parse arg o, dsn
call readDsn dsn, i.
ox = m.o.0
fi = 999999
la = -1
do ix=1 to i.0
parse var i.ix an ':' vo '-' bi
if bi = '' | abbrev(strip(an), '*') then
iterate
ox = ox + 1
m.o.ox = an + 0
m.o.ox.beg = vo + 0
m.o.ox.end = bi + 0
fi = min(fi, vo, bi)
la = max(la, vo, bi)
end
m.o.0 = ox
m.o.oldFi = fi
m.o.oldLa = la
return
endProcedure readMap
/*--- analyze a punch file generate by unload ------------------------*/
anaPunch: procedure expose m.
parse arg lod, nk, punch
call readDsn punch, pun.
m.lod.1 = 'LOAD DATA LOG NO EBCDIC CCSID(00500,00000,00000)'
m.lod.1 = ' ----------------- part --------------------' /* ??? */
do px=1 by 1 to pun.0 while left(pun.px, 12) ^== ' INTO TABLE '
end
if px > pun.0 | left(pun.px, 12) ^== ' INTO TABLE ' then
call err 'into table not found in punch' punch
m.lod.2 = ' INTO TABLE' m.nk.tb 'PART '
m.lod.3 = ' RESUME NO REPLACE COPYDDN(TCOPYS) INDDN REC'
do px=px by 1 to pun.0 while left(pun.px, 6) ^== ' WHEN('
end
if px > pun.0 then
call err 'when not found in punch' punch
do lx = 4 by 1 while px <= pun.0
m.lod.lx = strip(pun.px, 't')
if pun.px = ' )' then
leave
px = px + 1
end
m.lod.0 = lx
if px > pun.0 then
call err ') ending ) not found in punch' punch
return
endProcedure anaPunch
/*--- generate the unload limit 0 job --------------------------------*/
uli0Job: procedure expose m.
parse arg o, ok
call mapPut v, 'dbSub', m.ok.sub /* db2 subSystem */
call mapPut v, 'tb', m.ok.tb
call mapPut v, 'ts', m.ok.ts
call jobCards mCut(o, 0), 'ULI0'
call expSkel rePaUli0, o
return
endProcedure uli0Job
/*--- generate jobCards and put var jobName --------------------------*/
jobCards: procedure expose m.
parse arg o, jobSuf
call mapPut v, 'jobName', m.jobPref || jobSuf
call expSkel rePaJC, o
return
endProcedure jobCards
/*--- generate unloads -----------------------------------------------*/
unloJob: procedure expose m.
parse arg unloJob, ok, fi, la, jobMid
call mapPut v, 'dbSub', m.ok.sub
call mapPut v, 'tb', m.ok.tb
call mapPut v, 'ts', m.ok.ts
call mCut o, 0
jMax = min(la+1-fi, m.jobs)
pLast = fi-1
do jx=1 to jMax
px = pLast + 1
pLast = trunc(0.5 + (la+1-fi) * jx / jMax)
partNo = right(px, 3, '0')
if px = pLast then
partLast = ''
else
partLast = ':'right(pLast, 3, '0')
/* call mapPut v, 'jobNo', right(jx, 3, '0') */
call mapPut v, 'partNo', partNo
call mapPut v, 'partLast', partLast
call jobCards o, left(jobMid, 1)right(jx, 3, '0')
call expSkel rePaUnlo, o
end /* each job */
call mStrip o, 't'
call writeDsn unloJob, m.o., ,1
return
endProcedure unloJob
/*--- generate loads -------------------------------------------------*/
loadJob: procedure expose m.
parse arg loadJob, new, old, pun, paMa
call mapPut v, 'dbSub', m.new.sub
call mapPut v, 'oldTs', m.old.ts
call mapPut v, 'newTb', m.new.ts
call mCut o, 0
jMax = min(m.paMa.0, m.jobs)
pLast = 0
do jx=1 to jMax
pFirst = pLast + 1
pLast = trunc(0.5 + m.paMa.0*jx/jMax)
call jobCards o, 'L'right(jx, 3, '0')
call expSkel rePaLoJo, o
do px=pFirst to pLast /* for each partition of job */
partNo = right(m.paMa.px, 3, '0')
li = '//REC'partNo
do qx=m.paMa.px.beg to m.paMa.px.end
call mAdd o, left(li,14)'DD DISP=SHR,',
|| 'DSN=&OLDPREF.'right(qx,3,0)'&OLDSUF'
li = '//'
end /* each old partition */
end /* for each partition of job */
call expSkel rePaLoPu, o
do px=pFirst to pLast /* for each partition of job */
partNo = right(m.paMa.px, 3, '0')
qq = m.o.0 + 2
call mAddSt o, pun
m.o.qq = m.o.qq || partNo
qq=qq+1
m.o.qq = m.o.qq || partNo
end /* for each partition of job */
end /* each job */
call mStrip o, 't'
call writeDsn loadJob, m.o., ,1
return
endProcedure loadJob
/*--- generate rebuild and runstats ----------------------------------*/
reRuJob: procedure expose m.
parse arg reRuJob, nd
call mapPut v, 'dbSub', m.new.sub
call mapPut v, 'ts', m.nd.ts
call jobCards mCut(o, 0), 'REBU'
call expSkel rePaRebu, o
call jobCards o, 'RUNS'
call expSkel rePaRuns, o
call mStrip o, 't'
call writeDsn reRuJob, m.o., ,1
return
endProcedure loadJob
/*--- generate rebinds -----------------------------------------------*/
rebiJob: procedure expose m.
parse arg rebiJob, nd
call mapPut v, 'dbSub', m.nd.sub
call jobCards mCut(o, 0), 'REBI'
call expSkel repaRebi, o
parse var m.nd.tb cr '.' nm
call sqlConnect m.nd.sub
call rebindStmts o, strip(cr), strip(nm)
call sqlDisconnect
call mStrip o, 't'
call writeDsn rebiJob, m.o., ,1
return
endProcedure loadJob
/*--- generate count job ---------------------------------------------*/
cntJob: procedure expose m.
parse arg cntJob, nd
call mapPut v, 'dbSub', m.nd.sub
call mapPut v, 'tb', m.nd.tb
call jobCards mCut(o, 0), 'CNT'
call expSkel repaCnt, o
call mStrip o, 't'
call writeDsn cntJob, m.o., ,1
return
endProcedure loadJob
/*--- expand the variables in one skeleton, result to stem o --------*/
expSkel: procedure expose m.
parse arg skl, o
upper skl
if symbol('m.expSkel.skl') <> 'VAR' then
call readDsn m.skels'('skl')', 'M.EXPSKEL.'skl'.'
call mapExpAll v, o, expSkel.skl
return
endProcedure expSkel
/*--- all rebinds ----------------------------------------------------*/
rebindStmts: procedure expose m.
parse arg o, cr, tb
sel = bQualifier '=' quote(cr, "'") and bName '=' quote(tb, "'")
call debug 'sel =' sel
p = ':m.pk.sx.'
call sqlPreOpen 8,
, "select distinct dCollid, dName, dContoken, version, p.type,",
"p.bindTime, p.valid, p.operative",
"from sysibm.sysPackDep d, sysibm.sysPackage p" ,
"where bType in ('T')" ,
"and d.dLocation = p.location" ,
"and d.dCollid = p.collid" ,
"and d.dName = p.name" ,
"and d.dConToken = p.conToken" ,
"and ("sel")" ,
"order by 2, 4, 1"
do sx=1 while sqlFetchInto(8, ':col, :nam, :cTo, :ver, :typ,' ,
':bTi, :val, :ope')
call debug sx col nam c2x(cTo) ver typ bTi 'vo' val ope
st = 'PACKAGE('strip(col)'.'strip(nam)
if typ = 'T' then
st = 'REBIND TRIGGER' st')'
else
st = 'REBIND' st'.('strip(ver)'))'
call mAdd o, st '-'
call mAdd o, ' /* valid='val', op='ope', lastBind='bTi '*/'
end
call sqlClose 8
return sx-1
endProcedure rebindStmts
/* 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:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
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 expose m.
parse arg ggSys, ggRetCon
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 ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
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
call 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 mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') ^== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') ^== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.mAlfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt ^== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li ^= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp 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
return
endProcedure mapIni
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('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
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
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
/*--- 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() >= 3 then
return arg(3)
else
call 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 ^== '' then
call err 'not implemented mapRemove('a',' ky')'
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
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 pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') ^== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') ^== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA ^== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a ^== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
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
***********************************************************************/
/*--- 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 adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if ^ readDD(ggGrp, ggSt) then
return 0
if withVolume ^== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call jOut q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call jOut m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* 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 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.
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 arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
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 expose m.
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 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
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
endProcedure tsoAlloc
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':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(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A011) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A011) 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
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
***********************************************************************/
/* 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 expose m.
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 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
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 expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
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 *****************************************************/