zOs/REXX.O08/DBX
/* rexx ****************************************************************
synopsis: DBX fun args
edit macro fuer CS Nutzung von DB2 AdminTool 7.2
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
a,aw,ac pr naechste AuftragsId suchen fuer praefix pr
a: anzueigen, aw, ac entsprechendes Member editieren
n, nt neuen Auftrag erstellen (nt = test)
q subSys? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* ergaenzt scope Zeile mit infos, z.B tb -> ts
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren,
sonst werden alle expandiert
* funktioniert nicht nur in Auftrag
falls SubSys angegeben wird da gesucht sonst DBAF/DBOF
c opt? compare source gegen target
i subSys nct changes in Db2Subsystem subSys importieren
subSys: DBAF (im RZ1); RR2.DBOF (im PTA); *, RZ4.*;
RZ8.DB0G,DC0G; *.* (alle in RZ1,RR2,RZ2, RZ8)
nct: Nachtraege:
leer: noch nicht in dieses SubSys importierte
= : vom letzten import plus neue
89A : Nachtraege 8, 9 und A
v opt? version files erstellen für altes Verfahren
sw rz? WSL ins RZ rz schicken und clonen, ohne rz mulitclone
do cmd for auftraege: batchfunktion cmd fuer jeden auftrag
opt? Optionale Optionen =, -f, -=f etc. (fuer c, v, st)
= statt aktuelle source aus Db2 extrahieren
letzte extrahierte Version als Source brauchen
-f force: ignoriere QualitaetsVerletzungen
cloneWsl dbaMulti Funktionalitaet ist hier implementiert
Variabeln im Auftrag (expandiert werden $varName imd ${varName}
varName ist case sensitive|)
srcNm NamensKonvention compare source (z.B. DBAF)
trgNm NamensKonvention compare target (z.B. DBAF)
impNm NamensKonvention import Ziel (z.B. DBOF)
subsys Db2 Subsystem (source, target, import, je nachdem)
************************************************************************
18.12.2008 p. kuhn neues Delta Merge Verfahren im import fuer DQ0G
18.12.2008 p. kuhn SW fuer DVBP im RZ2 (frueher im RZ4)
*/ /* end of help
10.12.2008 p. kuhn Timeout vom Sendjob von 30 auf 600 Sek. erhoeht.
28.11.2008 w. keller v9 Fehler bei leerer Selektion
24.09.2008 p. kuhn v9 checks
15.09.2008 p. kuhn beim ersten import wird cdl dbaCheck't und editiert
09.09.2008 w. keller target mit RZ (job holt ddl, version aus RZ), opt =
08.08.2008 w. keller import mit wildcards
24.07.2008 w. keller overwrite ausgebaut +25.7
24.06.2008 w. keller fix spezialFall für DB +18.7
19.05.2008 w. keller qualitaetsKontolle in c,v und st und -f Option
13.05.2008 w. keller rw, rs, sw, st und do ... for ... eingebaut
25.02.2008 w. keller subSys argument für dbx q
22.11.2007 w. keller fun v für ObjectCompare Verfahren inkl db ddl save
dq0g mit eigenen Libraries
12.11.2007 w. keller DSN für neuen Wartungsstand
05.06.2007 w. keller neu
***********************************************************************/
/* Ideen, Wünsche ******************************************************
AuftragsId aus Prototyp bestimmen
translate scopes
import produktion/pta inkl. filetransfer
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw.
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
**** alte Funktion (braucht es nicht mehr) *****************************
sw rz? WSL aus RZ rz holen und clonen, ohne rz mulitclone
rs rz source ddl und version aus RZ rz holen
st opt? rz target ddl und version extrahieren und ins rz schicken
***********************************************************************/
m.debug = 0
call errReset h
if sysvar(sysispf) = 'ACTIVE' then
call adrIsp 'Control errors return'
call mapIni
parse upper arg oArgs
m.auftrag.dataset = ''
m.editMacro = 0
m.editProc = 0
if oArgs = '' then do
if adrEdit('macro (oArgs) NOPROCESS', '*') <> 0 then
call errHelp('keine Argumente und kein editMacro rc =' rc)
m.editMacro = 1
call adrEdit 'caps off'
call adrEdit '(x) = member'
m.auftrag.member = x
m.edit.member = x
call adrEdit '(x) = dataset'
m.auftrag.dataset = x
m.edit.dataset = x
end
else do
oArgs = 'BATCH' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
m.uId = strip(userid())
if m.uId = 'A540769' then
m.uNa = 'Walter'
else if m.uId = 'A914227' then
m.uNa = 'Gerrit'
else if m.uId = 'A918249' then
m.uNa = 'Petra'
else if m.uId = 'A828386' then
m.uNa = 'Reni'
else if m.uId = 'A234579' then
m.uNa = 'Marc'
else if m.uId = 'A666308' then
m.uNa = 'Frank'
else if m.uId = ' ' then
m.uNa = 'Claudia'
else
m.uNa = m.uId
m.zuegelSchub = '20081114 ??:00'
m.scopeTypes = 'DB TS TB VW IX AL'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
call work oArgs
exit
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse upper arg fun args
call mapReset e, 'K'
if m.auftrag.dataset = 'A540769.DBX.AUFTRAG' then do
m.libSkels = 'A540769.wk.skels(dbx'
m.libPre = 'A540769.DBX'
end
else if m.auftrag.dataset = 'DSN.DBQ.AUFTRAG' then do
m.libSkels = 'ORG.U0009.B0106.KIUT23.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'ORG.U0009.B0106.KIUT23.SKELS(dbx'
end
if 0 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
else if userid() = 'A918249' then
m.libSkels = 'a918249.tso.skels(dbx'
else
m.libSkels = 'DSN.DBX.TEST(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
m.sysRz = sysvar('SYSNODE')
call configureRZ m.sysRz
call db2Rel '910'
call mapPut e, 'rexxLib', 'ORG.U0009.B0106.KIUT23.EXEC'
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if wordPos(fun, 'A AC AW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if fun = 'BATCH' then
return batch(args)
else if wordPos(fun, 'ADATASET DO') > 0 then
return batch(fun args)
else if fun = 'COPYDUMMY' then
return copyDummy(args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
call memberOpt
if wordPos(fun, 'N NT') > 0 then
call neuerAuftrag (fun = 'NT'), args, m.auftrag.member
else if fun = 'C' | fun = 'V' | fun = 'ST' then
call compare fun, args
else if fun = 'I' then
call import args
else if fun = 'N' then
call neuerNachtrag args
else if fun = 'RS' then
call receiveSource args
else if fun = 'RW' then
call receiveWSL args
else if fun = 'SW' then
call sendWSL args
else
call errHelp 'bad fun' fun 'in args' args, , ' '
if m.auftrag.orig = m.auftrag.0 | m.auftrag.0 = '' then do
end
else do
if abbrev(m.auftrag.orig, 'rmQu') then do
/* alte | Zeilen loeschen */
oldOr = word(m.auftrag.orig, 2)
ox = 0
do ix = 1 to m.auftrag.0
if abbrev(word(m.auftrag.ix, 1), '|') & ix <= oldOr then
iterate
ox = ox + 1
m.auftrag.ox = m.auftrag.ix
end
m.auftrag.0 = ox
m.auftrag.orig = 'rep'
end
if m.editMacro & m.auftrag.dataset = m.edit.dataset ,
& m.auftrag.member = m.edit.member then do
if m.auftrag.orig = 'rep' then do
call adrEdit 'delete .zf .zl'
m.auftrag.orig = 0
end
do lx = m.auftrag.orig+1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
call adrEdit "line_after .zl = (li)"
end
call adrEdit 'save', 4
end
else do
call writeDsn dsnSetMbr(m.auftrag.dataset,
,m.auftrag.member), m.auftrag.,,1
end
end
return
endProcedure work
/*--- batch funktionen -----------------------------------------------*/
batch: procedure expose m.
parse upper arg args
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
wx = 1
do forever
w1 = word(args, wx)
if w1 = '' then
return 0
if w1 = 'ADATASET' then do
m.auftrag.dataset = word(args, wx+1)
wx = wx+2
end
else if w1 = 'DO' then do
fx = wordPos('FOR', args, wx)
if fx < 1 then
call err 'DO ohne FOR in' args
cmd = subWord(args, wx+1, fx-wx-1)
do wx=fx+1
ww = word(args, wx)
if ww = '' then
leave
m.auftrag.member = ww
say 'batch do' cmd 'for' ww '...'
call work cmd
end
end
else do
call work subword(args, wx)
return 0
end
end
return 0
endProcedure batch
/*--- create the necessary dbx libries in the specified rz -----------*/
copyDummy: procedure expose m.
parse arg rz
call copyDummy1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.AUTO(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.CDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
/* call copyDummy1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call copyDummy1 rz, 'DSN.DBX.JCL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.MASK'
/* call copyDummy1 rz, 'DSN.DBX.OVRCAT(DUMMY)' */
call copyDummy1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call copyDummy1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
return 0
endProcedure copyDummy
copyDummy1: procedure expose m.
parse arg sys, dsn
if sysDsn("'"dsn"'") <> 'OK' then
call writeDsn dsn, x, 0, 1
call csmCopy dsn, sys'/'dsn
return
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg m.myRz
m.jobCard = 'jobCa'
call mapPut e, 'toolPref', 'DSN.TOOLS'
if m.myRz = 'RZ1' then do
m.allSubs = 'DBAF DBTF DBZF DBLF'
if m.libPre = 'DSN.DBQ' then do
m.allSubs = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPref', 'DSN.ADB72'
end
end
else if m.myRz = 'RZ2' | m.myRZ = 'RR2' then do
m.allSubs = 'DBOF DVBP'
/* call mapPut e, 'toolPref', 'DSN.ADB72' --> nicht mehr 25.7.08 */
end
else if m.myRz = 'RZ4' | m.myRZ = 'RR4' then do
m.allSubs = 'DBOL DVBP'
end
else if m.myRz = 'RZ8' then do
m.allSubs = 'DM0G DB0G DC0G DD0G DE0G'
end
else if m.myRz = 'RZ0T' | m.myRz = 'RZ0' then do
m.allSubs = 'DBIA'
m.myRz = 'RZ0'
end
m.mySub = word(m.allSubs, 1)
call mapPut e, 'rz', m.myRz
call mapPut e, 'zz', overlay('Z', m.myRz, 2)
return
endProcedure configureRZ
/*--- die Konfiguration fuer einen DB2 Release -----------------------*/
db2Rel: procedure expose m.
parse arg rel, px
if px = '' then
px = 'P0'
call mapPut e, 'db2rel', rel
call mapPut e, 'dsnload', px'.DSNLOAD'
return
endProcedure db2Rel
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'dbx sollte' m.libPre'.AUFTRAG editieren, nicht' ,
m.auftrag.dataset
m8 = substr(m.auftrag.member, 8, 1)
if pos(m8, 'CW') < 1 then
call err 'Member muss 8 stellig sein und mit C oder W enden',
'nicht' m.auftrag.member
m.optOvr = 0 /* (m8 == 'W') & (m.libPre ^== 'DSN.DBQ') */
m.optAuto = 1
call readAuftrag '', m.auftrag.dataset, m.auftrag.member
return
endProcedure memberOpt
/*--- Auftrag einlesen -----------------------------------------------*/
readAuftrag: procedure expose m.
parse arg sys, pds, mbr
editingAuftrag = 0
if sys = '' & m.editMacro then do
call adrEdit '(em) = member'
call adrEdit '(ed) = dataset'
editingAuftrag = ed = pds & em = mbr
end
if editingAuftrag then do
if adrEdit('(zl) = lineNum .zl', 4) = 4 then
zl = 0
m.auftrag.0 = zl
do lx=1 to zl
call adrEdit "(li) = line" lx
m.auftrag.lx = li
end
end
else do
dsn = dsnSetMbr(m.auftrag.dataset, m.auftrag.member)
if sys = '' then
if sysDsn("'"dsn"'") <> 'OK' then
call err 'auftrag' dsn 'existiert nicht:' sysDsn("'"dsn"'")
call readDsn sys'/'dsn, m.auftrag.
end
m.auftrag.orig = m.auftrag.0
return
endProcedure readAuftrag
/*--- naechste AuftragsNummer suchen ---------------------------------*/
nextAuftrag: procedure expose m.
parse arg pre, make, rz
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ1' then
call err 'Auftrag für RZ' rz 'muss aus RZ1 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft, 'DSN.DBA.CLON.WSL'
max = pre
do nx=1 to m.na.0
lmm = lmmBegin(dsnSetMbr(m.na.nx, pre'*'))
mb = lmmNext(lmm)
fi = mb
la = ''
do cnt=2 by 1 while mb <> ''
la = mb
mb = lmmNext(lmm)
end
call lmmEnd lmm
say left(fi, 8) '-' left(la, 8)right(cnt-2, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if la >> max then
max = la
end
nn = left(max, 7, '0')
do cx=7 by-1 to length(pre)+1,
while pos(substr(nn, cx, 1), '0123456789') > 0
end
if cx >= 7 then
nn = ''
else do
pp = 1 + substr(nn, cx+1)
if length(pp) > 7-cx then
nn = ''
else
nn = left(nn, cx) || right(pp, 7-cx, 0)
end
if length(nn) <> 7 then do
say 'max Auftrag' max 'kein naechster bestimmbar'
end
else if make = '' then do
say 'max Auftrag' max 'naechster' nn'?'
end
else do
nn = nn || make
say 'max Auftrag' max 'naechster' nn
m.auftrag.0 = 0
call neuerAuftrag 0, rz, nn
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if rz = 'RZ1' then
call adrIsp "edit dataset('"dsnNN"')"
else
call writeDsn rz'/'dsnNN, m.auftrag.
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
comMask = m.libPre'.MASK('maPr'PROT)'
impMask = m.libPre'.MASK('maPr'$subsys)'
end
else do
ow = 'S100447'
comMask = m.libPre'.MASK(PROT$trgNm)'
impMask = m.libPre'.MASK($trgNm$impNm)'
end
comIgno = m.libPre'.MASK(IGNORE)'
impIgno = ''
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' m.zuegelSchub ,
, ' Besteller pid name tel' ,
, ' comMask ' comMask ,
, ' comIgno ' comIgno ,
, ' impMask ' impMask ,
, ' impIgno ' impIgno ,
, 'source' m.mySub ,
, ' ts dgdb0___.A%' ,
, 'target' m.myRz'.'m.mySub
return
endProcedure neuerAuftrag
neuerNachtrag: procedure expose m.
parse upper arg opt
call analyseAuftrag
call addNachtrag
return
endProcedure neuerNachtrag
nextNachtrag: procedure expose m.
parse arg nt
nx = pos(nt, m.nachtragChars) + 1
if nx > length(m.nachtragChars) then
call err 'kein Nachtrag char mehr nach' nt
return substr(m.nachtragChars, nx, 1)
m.e.nachtrag = nt
return nt
endProcedure nextNachtrag
/*--- compare: Funktionen c, v und st --------------------------------*/
compare: procedure expose m.
parse upper arg fun, sendToRz
opts = ''
do forever
if abbrev(sendToRz, '=') then do
sendToRz = strip(substr(sendToRz, 2))
opts = opts'='
end
else if abbrev(sendToRz, '-') then do
opts = opts || substr(word(sendToRz, 1), 2)
sendToRz = subword(sendToRz, 2)
end
else
leave
end
cmpLast = pos('=', opts) > 0
if fun = 'C' then
function = 'compare'
else if fun = 'ST' then do
if sendToRz = '' | sendToRz = '*' then
call errHelp 'ST without sendToRz'
call mapPut e, 'toRz', sendToRz
function = 'sendTarget' sendToRz
end
else if fun = 'V' then
function = 'version'
else
call err 'bad fun' fun
call analyseAuftrag
if m.scopeSrc.rz = m.sysRz then do
if qualityCheck(getDb2Catalog('SRC')) then
if pos('F', opts) < 1 then
return
else
say 'wegen Option -f Verarbeitung',
'trotz Qualitaetsfehlern'
end
nacLast = m.e.nachtrag
if nacLast = '?' & cmpLast then
call err 'c = oder v = ohne vorangaengiges c oder v'
if nacLast = '?' | m.nacImp then
m.e.nachtrag = nextNachtrag(nacLast)
call mapPut e, 'mbrNac', left(m.e.auftrag, 7)m.e.nachtrag
m.o.0 = 0
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.subsys, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapExpAll e, o, i
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.comMask))
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast left(m.e.auftrag, 7)nacLast
call extractSrcTrg o, '', cmpLast left(m.e.auftrag, 7)nacLast
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call readDsn m.libSkels'Ovr)', m.ovr.
call mapExpAll e, o, ovr
call mapPut e, 'src', 'OVR'
end
call readDsn m.libSkels'Comp)', m.cmp.
call mapExpAll e, o, cmp
end
if fun = 'ST' then do
call readDsn m.libSkels'ST)', m.st.
call mapExpAll e, o, st
end
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeTrg.rz'.'m.scopeTrg.subSys ,
mapExp(e, "'${libPre}.srcCAT($mbrNac)'"))
return
endProcedure compare
/*--- find the naming convention for a rz and subsystem --------------*/
namingConv: procedure expose m.
parse arg rz, subsys, var
if rz = '.' then
if pos('.', subSys) > 0 then
parse var subsys rz '.' subsys
else
rz = m.sysRz
if strip(rz) = 'RZ1' then
t = strip(subsys)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
/*--- write jcl and submit it ----------------------------------------*/
writeSub: procedure expose m.
parse arg o, rz, noWri
userSubmits = 0 /* edit jcl and user submits it */
if noWri <> 1 then do
jcl = m.libPre'.JCL('m.e.auftrag')'
call mStrip o, 't'
do ox=1 to m.o.0
if length(m.o.ox) > 70 then
call debug 'o.'ox 'len' length(m.o.ox)':' m.o.ox
end
call writeDsn jcl, m.o., ,1
if userSubmits then /* edit dataset and user may submit it */
call adrIsp "edit dataset('"jcl"')", 4
end
if (noWri <> 1) & (rz = '' | rz = m.sysRz) then do
if ^ userSubmits then
call adrTso "sub '"jcl"'"
end
else do /* submit jcl in another rz */
sysl = csmSysDsn(rz'/')
if sysl = '*/' then
sysl = ''
iral = dsnAlloc(sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)')
call writeDDBegin ir
call writeDD ir, m.o.
call writeDDend 'IR'
interpret subword(irAl, 2)
end
return
endProcedure writeSub
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn
if dsn = '' then
return 'DUMMY'
else
return 'DISP=SHR,DSN='translate(dsn)
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg rzSubSysList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if words(m.targets) > 1 then
call err 'i=import mit mehreren targets muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzSubSysList m.e.nachtrag
if ^ m.nacImp then do
cdl = cdlDsnCheck(m.e.nachtrag)
call adrIsp "edit dataset('"cdl"') macro(dbacheck)", 4
end
trgNm = namingConv(m.targets)
call readDsn m.libSkels || m.jobCard')', m.jc.
call readDsn m.libSkels'imp)', m.ic.
restList = space(rzSubSysList, 0)
impCnt = 0
rz = '?'
do forever
parse var restList r1 ',' restList
if r1 = '' & restList <> '' then
iterate
if r1 = '**' | r1 = '*.*' then do
restList = 'RZ1.*,RR2.*,RZ2.*,RZ8.*' estList
iterate
end
if pos('.', r1) < 1 then
r1 = m.myRz'.'r1
parse var r1 r '.' subsys
if r <> rz | subsys = '' then do
if impCnt <> 0 then do
if rz <> m.sysRz then
call csmCopy m.libPre'.CDL('left(m.e.auftrag,7)'*)',
, rz'/'m.libPre'.CDL'
call writeSub job, rz
end
if subsys = '' then
return
rz = r
call configureRz rz
impCnt = 0
m.job.0 = 0
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', 'import' rz
call mapPut e, 'subsys'
/* call mapPut e, 'mask', shrDummy(mapExp(e, m.e.impMask))
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.impIgno))
*/ call mapExpAll e, job, jc
end
if subsys = '*' then do
do wx=words(m.allSubs) by -1 to 1
restList = rz'.'word(m.allSubs,wx)','restList
end
iterate
end
if length(subsys) <> 4 then
call err 'ungueltiges db2SubSys' subsys 'im import' rz
call mapPut e, 'subsys', subsys
if rz = m.sysRz then
impCnt = impCnt + importAdd(job, subsys, opt, ic)
else if m.sysRz == 'RZ1' then
impCnt = impCnt + importAdd(job, rz'.'subsys, opt, ic)
else
call err 'cannot import into' rz 'from' m.sysRz
end
endProcedure import
/*--- add a single import to jcl in o --------------------------------*/
importAdd: procedure expose m.
parse upper arg o, rzSubSys, opt, ic
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ begin */
deltaNew = pos('DQ0G', rzSubSys) > 0
if deltaNew then do /* neues delta merge verfahren */
inDdn = 'DCHG'
call mapPut e, 'cType', "''''T''''"
end
else do /* altes delta merge verfahren */
inDdn = 'SRCDDN2'
call mapPut e, 'cType', "''''C''''"
end
call mapPut e, 'inDdn', inDdn
/* Uebergang altes auf neue Delta Merge Verfahren ++++++++ end */
if opt ^= '' & opt ^= '=' then do
nachAll = opt
end
else if symbol('m.imp.rzSubSys.nachtrag') ^== 'VAR' then do
nachAll = m.compares
end
else do
if opt = '=' then
la = left(m.imp.rzSubSys.nachtrag, 1)
else
la = right(m.imp.rzSubSys.nachtrag, 1)
cx = pos(la, m.compares)
if cx < 1 then
call err 'nachtrag' la 'von' rzSubSys m.rzSubSys.change ,
'nicht in Compare Liste' m.compares
nachAll = substr(m.compares, cx + (opt ^= '='))
end
if nachAll = ' ' then do
say 'alle Nachtraege schon importiert fuer' rzSubSys
return 0
end
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
trgNm = ''
do nx=1 to m.nachtrag.0
if pos(m.nachtrag.nx, nachAll) < 1 then
iterate
act = namingConv('.', m.nachtrag.nx.trg)
if trgNm = '' then
trgNm = act
else if trgNm <> act then
call err 'targetNaming' trgNm 'wechselt zu' act ,
'fuer nachtrag' m.nachtrag.nx 'auf' m.nachtrag.nx.trg
end
m.imp.seq = m.imp.seq + 1
if length(m.imp.seq) > 3 then
call err 'import Sequenz Ueberlauf' m.imp.seq
m.imp.seq = right(m.imp.seq, 3, 0)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
call mapPut e, 'change', chaPre'.'m.e.zuegelSchub'.IMP'
call mapPut e, 'change', chaPre'.IMP'
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzSubSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.subsys, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'mask', shrDummy(mapExp(e, m.e.impMask))
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.impIgno))
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
sto = mapExpAllAt(e, o, ic, 1, 1)
do while sto ^= ''
parse var sto lx cx
w = word(substr(m.ic.lx, cx), 1)
if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else if deltaNew then do
do ix=1 to length(nachAll)
call mAdd o, left('//'inDdn || right(ix,3,0), 13) ,
|| 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
end
end
else do
le = left('//'inDdn, 13)
do ix=1 to length(nachAll)
call mAdd o, le || 'DD DISP=SHR,DSN=',
|| cdlDsnCheck(substr(nachAll, ix, 1))
le = left('//', 13)
end
end
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call mAdd auftrag,
, addDateUs("import" rzSubsys nachAll chaPre".IMP")
return 1
endProcedure importAdd
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.CDL('left(m.e.auftrag, 7) || nt')'
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.subSys = m.mySub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.subSys = m.mySub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
m.nacImp = 0
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER COMMASK' ,
'COMIGNO IMPMASK IMPIGNO'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = m.auftrag.lx
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
w2 = translate(word(li, 2))
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'subSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.subsys = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.subsys
end
else if wordPos(w1, m.scopeTypes) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = mInc(nachtrag.0)
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | pos('.', w3) < 1 then
t1 = m.myRz'.'m.mySub
else
t1 = w3
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . subsys nachAll chg .
if chgAuf <> m.e.auftrag then
if right(nachAll, 1) <> m.e.nachtrag then
call err 'aktueller Nachtrag' m.e.nachtrag ,
'aber import' nachAll 'in Zeile' lx li
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
if chgAuf <> m.e.auftrag then
call err 'Auftrag mismatch in Zeile' lx li
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
if chgImp ^== 'IMP' then
call err '.IMP mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call fehl 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.subSys.nachtrag = nachAll
m.imp.subSys.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
/* nachtrae durchgehen und kumulieren */
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
do nx=1 to m.nachtrag.0
m.cmpLast = m.cmpLast | m.nachtrag.nx.last
if wordPos(m.nachtrag.nx.trg, m.targets) < 1 then
m.targets = m.targets m.nachtrag.nx.trg
if m.nachtrag.nx.fun = 'C' then
m.compares = m.compares || m.nachtrag.nx
if m.nachtrag.nx.fun = 'V' then
m.versions = m.versions || m.nachtrag.nx
call debug 'nachtrag' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg,
'all' m.targets 'fun' ,
m.nachtrag.nx.fun 'com' m.compares 'ver' m.versions,
'cmpLast' m.cmpLast
end
if 1 & abbrev(m.scopeSrc.subSys, 'DQ0') then
call db2Rel '910', 'P0'
if 0 then do
say 'auftrag ' m.e.auftrag m.e.nachtrag mapGet(e, 'chgOwn')
say ' comMask ' m.e.comMask
say ' comIgno ' m.e.comIgno
say ' impMask ' m.e.impMask
say ' impIgno ' m.e.impIgno
scp = 'SCOPESRC'
drop subsys
say ' scope ' m.scp.0 m.scp.subsys ,
' target ' m.scopeTrg.0 m.scopeTrg.subsys
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
return
endProcedure analyseAuftrag
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeTypes) < 1 then
return '?'
cx = pos('.', w1)
if cx < 1 then do
qu = w1
end
else do
qu =strip(left(w1, cx-1))
rest = substr(w1, cx) rest
end
if qu = '' then
return '? leerer Qualifier'
if ty = 'DB' then
return ty qu
if left(rest, 1) = '.' then
rest = substr(rest, 2)
nm = word(rest, 1)
if nm = '' then
return '? leerer Name'
return ty nm qu
endProcedure analyseScope
/*--- jcl generieren um Src und Trg Version und DDL zu extrahieren ---*/
extractSrcTrg: procedure expose m.
parse arg o, xx, oldSrc mbrLast
call readDsn m.libSkels'ExVe)', m.exVe.
call mapPut e, 'subsys', m.scopeSrc.subsys
call mapPut e, 'auto', xx'AUTO'
call mapPut e, 'src', xx'SRC'
call mapPut e, 'trg', xx'TRG'
mbrNac = mapGet(e, 'mbrNac')
call mapPut e, 'what', xx'SRC'
if ^ oldSrc then do
call extractScopeVersion o, exVe, xx, 'SRC'
end
else if mbrNac <> mbrLast then do
pr = m.libPre'.'xx'SRC'
call copyDsn pr'DDL('mbrLast')', pr'DDL('mbrNac')', 1
call copyDsn pr'CAT('mbrLast')', pr'CAT('mbrNac')', 1
end
call mapPut e, 'subsys', m.scopeTrg.subsys
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call readDsn m.libSkels'AutMa)', m.autoMap.
call readDsn m.libSkels'AutEx)', m.autoExt.
call mapExpAll e, o, autoMap
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, autoExt
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
autD = mapExp(e, '${libPre}.$auto($mbrNac)')
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scopeTrg.rz, 'RECTRG',
, 'send' autD ,
, 'job -ddJob 600//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, autoExt
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, exVe, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, i, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'RECSRC',
, 'job -ddJob 30//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, i, ty, what
call sendJob2 o, sndIn, cf mark
end
return
endProcedure extractScopeVersion
/*--- einen Step um Version + DDL zu extrahieren ---------------------*/
extractVersionStep: procedure expose m.
parse arg o, i, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
sto = mapExpAllAt(e, o, i, 1, 1)
do while sto ^== ''
parse var sto lx cx
w = word(substr(m.i.lx, cx), 1)
if w == '$@scope' then do
if ty == '' then do
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call mAdd o, t
end
end
else if ty == 'DB' then do
c = getDb2Catalog(what)
do x=1 to m.c.0
d1 = m.c.x.db
if db.d1 == 1 then
iterate
db.d1 = 1
call mAdd o, " TYPE = 'DB,' NAME = '"d1"';"
end
end
else
call err 'extractVersionStep bad ty' ty
end
else do
call err 'implement stop' sto 'word' w 'in line' lx m.i.lx
end
sto = mapExpAllAt(e, o, i, lx, cx + length(w))
end
return
endProcedure extractVersionStep
/*--- add jcl to stem o to send a job to rz toRz with stepname step
and add the remaining arguments as sendJob statements
afterwards the caller must add the jcl and call sendJob2 ----*/
sendJob1: procedure expose m.
parse arg o, toRz, step
oldRz = m.myRz
call configureRz toRz
call readDsn m.libSkels'SendJ)', m.sendJob.
call mapPut e, 'step', step
call mapExpAll e, o, sendJob
do ax=4 to arg()
call debug 'sendJob1 le' length(arg(ax)) arg(ax)'|'
call mAdd o, arg(ax) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call readDsn m.libSkels || m.jobCard')', m.i.
call mapPut e, 'jobName', 'Y'left(m.e.auftrag, 7)
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, i
return oldRz stReX
endProcedure sendJob1
/*--- add the mark step to the job, translate leading // to ??
and switch back to original rz -----------------------------*/
sendJob2: procedure expose m.
parse arg o, oldRz stReX, cfMark
if cfMark ^= '' then do
call mAdd o, '// IF NOT ABEND' ,
'AND RC >= 0 AND RC <= 4 THEN'
call mapPut e, 'step', 'MARKOK'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, sendJob
call mAdd o, 'mark' cfMark 'badRcOrAbend'
call mAdd o, '// ENDIF'
end
do ox = stReX to m.o.0
if abbrev(m.o.ox, '//') then
m.o.ox = overlay('??', m.o.ox)
end
call configureRz oldRz
return
endProcedure sendJob2
/*--- return Stem fuer die CatalogInfo für Src oder Trg
falls noetig aus Db2Catalog einlesen -----------------------*/
getDb2Catalog: procedure expose m.
parse arg wh
st = 'CAT'wh
if datatype(m.st.0, n) then
return st
else if m.st.0 ^== '' then
call err 'getDb2Catalog('wh') bad value m.'st'.0' m.st.0
scp = 'SCOPE'wh
call sqlConnect m.scp.subSys
call queryDb2Catalog st, wh
m.v9.0 = 0
if m.scp.subSys = 'DBAF' then
call queryDb2V9 st, 'V9'
call sqlDisconnect
return st
endProcedure getDb2Catalog
/*--- Information aus Db2Catalog fuer einen Scope einlesen -----------*/
queryDb2Catalog: procedure expose m.
parse arg st, what
scp = 'SCOPE'what
/* m.scopeTypes = 'DB TS TB VW IX AL' */
ts = ''
tb = ''
ix = ''
unQueried = 0
do sx=1 to m.scp.0
sn = scp'.'sx
t = " TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"';"
call debug 'queryDb2Catalog' sx t
if m.sn.type = 'DB' then
ts = ts 'or s.dbName' sqlClause(m.sn.name)
else if m.sn.Type = 'TS' then
ts = ts 'or (s.dbName' sqlClause(m.sn.qual) ,
'and s.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'TB' then
tb = tb 'or (t.creator' sqlClause(m.sn.qual) ,
'and t.name' sqlClause(m.sn.name)')'
else if m.sn.Type = 'IX' then
ix = ix 'or (x.creator' sqlClause(m.sn.qual) ,
'and x.name' sqlClause(m.sn.name)')'
else if wordPos(m.sn.type, 'AL VW') > 0 then
unQueried = unQueried + 1
else
call err 'not implemented'
end
sel = 'select s.dbName, s.name, s.type, s.partitions, s.segSize,' ,
't.creator, t.name, t.status, t.tableStatus',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
vFlds = 'db ts type partitions segSize',
'cr tb tbSta tbTbSta'
wh = "where s.dbName = t.dbName and s.name = t.tsName",
"and t.type = 'T'"
sql = ''
if ts <> '' then
sql = sql 'union' sel wh 'and ('substr(ts, 5)')'
call debug 'ts sql' sql
if tb <> '' then
sql = sql 'union' sel wh 'and ('substr(tb, 5)')'
call debug 'tb sql' sql
if ix <> '' then
sql = sql 'union' sel ', SYSIBM.SYSINDEXES X',
wh 'and t.creator=x.tbCreator and t.name=x.tbName',
'and ('substr(ix, 5)')'
call debug 'ix sql' sql
if sql = '' then do
m.st.0 = 0
if unQueried < 1 then
say 'nothing specified in source scope'
return 0
end
drop db ts cr tb type
call sqlPreAllCl 1, substr(sql, 8), st, sqlVars('M.st.sx', vFlds)
if m.debug == 1 then do
say m.st.0
do sx = 1 to m.st.0
say strip(m.st.sx.db)'.'strip(m.st.sx.ts) m.st.sx.type ,
m.st.sx.partitions m.st.sx.segSize
end
end
return m.st.0
endProcedure queryDb2Catalog
/*--- haben wir schon DB2 V9 Objekte ? -------------------------------*/
queryDb2V9: procedure expose m.
parse arg sc, vv
m.vv.0 = 0
wh =''
do x = 1 to m.sc.0
wh = wh "or (cr='"m.sc.x.cr"' and tb='"m.sc.x.tb"')"
end
if wh == '' then
return 0
sql = "select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl"
call sqlPreAllCl 1, sql, vv, ":m.st.sx.tp,:m.st.sx.nm,:m.st.sx.v9"
return m.vv.0
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
qualityCheck: procedure expose m.
parse arg c
if m.libPre <> 'DSN.DBQ' then
call maskIni
o = 'AUFTRAG'
m.o.orig = 'rmQu' m.o.orig
m.spezialFall.done = ''
aufOld = m.o.0
do x=1 to m.c.0
vDb = strip(m.c.x.db)
n = '|| db' vDb
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
end
n = '|| ts' vDb'.'strip(m.c.x.ts)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.partitions > 0 then
nop
else if m.c.x.segSize = 0 then
call mAdd o, n 'simple TS'
end
n = '|| tb' strip(m.c.x.cr)'.'strip(m.c.x.tb)
if d.n ^== 1 then do
d.n = 1
call spezialfall vDb, substr(n, 4)
if m.c.x.tbTbSta = 'L' then
call mAdd o, n 'auxilary index oder table fehlt'
else if m.c.x.tbTbSta = 'P' then
call mAdd o, n 'primary index fehlt'
else if m.c.x.tbTbSta = 'R' then
call mAdd o, n 'index auf Row ID fehlt'
else if m.c.x.tbTbSta = 'U' then
call mAdd o, n 'index auf unique key fehlt'
else if m.c.x.tbTbSta = 'V' then
call mAdd o, n 'Regenerierung interne ViewDarstellung'
else if m.c.x.tbTbSta ^= '' then
call mAdd o, n 'TableStatus' m.c.x.tbTbSta 'unbekannt'
end
end
do vx=1 to m.v9.0
call mAdd o, '|| V9' m.v9.vx.tp left(m.v9.vx.nm, 30) ,
left(m.v9.vx.v9, 30)
end
return aufOld < m.o.0
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
spezialFall: procedure expose m.
parse upper arg db, typ qua '.' nam
if m.libPre = 'DSN.DBQ' then
return
pDb = mask2prod('DBNAME', db)
if (typ = 'DB' | typ = 'TS') & db <> qua then
call err 'db mismatch spezialFall('db',' typ qua'.'nam')'
if typ = 'DB' then
srch = typ pDb'.'
else if typ = 'TS' then
srch = typ pDb'.'mask2prod('TSNAME', nam)
else if typ = 'TB' then
srch = typ mask2prod('TBOWNER', qua)'.'mask2prod('TBNAME', nam)
else
call err 'bad typ' typ
st = spezialFall'.'pDb
if symbol('m.st.0') <> 'VAR' then do
dsn = m.libSpezial"("pDb")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.SPEZIALFALL.'pDB'.'
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if wordPos(t, 'DB TS TB') < 1 then
call err 'spezialFall' pDb 'line' sx 'ungueltig:' m.st.sx
found = match(srch, t strip(q)'.'strip(n)) ,
& ^ (wordPos(pDb'.'sx, m.spezialFall.done) > 0)
if found then
m.spezialFall.done = m.spezialFall.done pDb'.'sx
end
if found then
call mAdd auftrag, '|-'left(m.st.sx, 78)
end
return
endProcedure spezialFall
/*--- mask handling initialise ---------------------------------------*/
maskIni: procedure expose m.
call maskHierarchy
call maskRead mask.prot, m.libPre'.MASK(PROTDBAF)'
call maskRead mask.dbof, m.libPre'.MASK(DBAFDBOF)'
return
endProcedure maskIni
/*--- mask test functions --------------------------------------------*/
testMask: procedure expose m.
call maskIni
call maskTT OWNER, GDB9998
call maskTT DBNAME, DGDB9998
call maskTT DBNAME, DGDB0287
call maskTT OWNER, GDB0301
call maskTT TSNAME, AGRFX12A2
call maskTT OWNER, SYS123EF
return 0
endProcedure testMask
maskTT: procedure expose m.
parse arg ty, na
say 'maskTrans(prot,' ty',' na') =' maskTrans(mask.prot, ty, na) ,
' -> DBOF' maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))
return
/*--- translate a prototype object to DBOF naming -------------------*/
mask2Prod: procedure expose m.
parse arg ty, na
return translate(strip(,
maskTrans(mask.dbof, ty, maskTrans(mask.prot,ty,na))))
/*--- translate an object of type ty and name na
by the masking file in st --------------------------------*/
maskTrans: procedure expose m.
parse arg st, ty, na
if symbol('m.mask.hier.ty') <> 'VAR' then
call err 'bad type' ty
types = m.mask.hier.ty
do sx=1 to m.st.0
if wordPos(m.st.sx.typ, types) < 1 then
iterate
if match(na, m.st.sx.in, vv) then
return matchTrans(m.st.sx.out, vv)
end
return na
endProcedure maskTrans
/*--- read and analyse the masking file dsn into stem st ------------*/
maskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE'
call readDsn dsn, i.
j = 0
do i=1 to i.0
parse var i.i t ':' s ',' d
t = strip(t)
if symbol('m.mask.hier.t') == 'VAR' then
nop
else if wordPos(t, maskIgno) > 0 then
iterate
else
call err 'bad typ' t 'in maskline' i':' i.i
j = j+1
m.st.j.typ = t
m.st.j.in = strip(s)
m.st.j.out = word(d, 1)
end
m.st.0 = j
return
drop typ in out
do wx=1 to m.st.0
say wx m.st.wx.typ':' m.st.wx.in'==>'m.st.wx.out'|'
end
endProcedure maskRead
/*--- initialise the type hierarchy of masking
as input use the msgLines of the mask editor --------------*/
maskHierarchy: procedure expose m.
/* copy der hierarch aus masking template */
call mAdd mCut('T', 0) ,
, 'COLNAME ' ,
, 'NAME ' ,
, ' DBNAME,TSNAME,TBNAME,IXNAME,UDFNAME, ' ,
, ' UDTNAME,COLLNAME,PKGNAME,PGMNAME,PLNNAME ' ,
, ' DBRMNAME,STPNAME,SFNAME,TGNAME,GRPNAME, ' ,
, ' VCATNAME,GBPNAME ' ,
, ' BPNAME ' ,
, ' TSBPNAME,IXBPNAME ' ,
, ' SGNAME ' ,
, ' TSSGNAME,IXSGNAME ' ,
, 'AUTHID ' ,
, ' SQLID,SCHEMA ' ,
, ' OWNER ' ,
, ' DBOWNER,TSOWNER,TBOWNER,IXOWNER ' ,
, ' GRANTID ' ,
, ' GRANTOR,GRANTEE '
qx = 0
lOff = -1
m.mask.hier = ''
do x=1 to m.t.0
of = verify(m.t.x, ' ', 'n')
li = translate(m.t.x, ' ', ',')
do while qx > 0 & word(q.qx, 1) >= of
qx = qx -1
end
px = qx - 1
if (qx = 0 | of > word(q.qx, 1)) & words(li) = 1 then do
px = qx
qx = qx + 1
if qx = 1 then
q.qx = of word(li, 1)
else
q.qx = of word(li, 1) subword(q.px, 2)
end
do wx=1 to words(li)
w1 = word(li, wx)
m.mask.hier = m.mask.hier w1
if wordPos(w1, subWord(q.qx, 2)) < 1 then
m.mask.hier.w1 = w1 subWord(q.qx, 2)
else
m.mask.hier.w1 = subWord(q.qx, 2)
end
end
return
endProcedure maskHierarchy
/*--- Funktion q: scope Zeilen pruefen -------------------------------*/
queryScope: procedure expose m.
parse arg subSys
if subSys = '' then
subSys = m.mySub
call sqlConnect subSys
rf = 1
if adrEdit('(rl) = lineNum .zl', 4) = 4 then
rl = 0
if ^ m.editMacro then
call err 'q nicht als Macro'
if ^ m.editProc then do
if adrEdit('PROCESS RANGE Q', 0 4) = 0 then do
call adrEdit '(rf) = lineNum .zfrange'
call adrEdit '(rl) = lineNum .zlrange'
end
m.editProc = 1
end
do rx = rf by 1 while rx <= rl
call adrEdit '(li) = line' rx
parse value analyseScope(li) with ty nm qu
if ty = '?' then do
if nm <> '' then
say nm qu 'in line' rx':' strip(li)
iterate
end
call expandScope mCut(qq, 0), ty, qu, nm
neu = m.qq.1
if adrEdit("line" rx "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
do qx=2 to m.qq.0
neu = m.qq.qx
if adrEdit("line_after" rx "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
rx = rx+1
rl = rl+1
end
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
c = 'ni'
if ty = 'IX' then do
sql = 'select creator, name, tbCreator, tbName' ,
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
call sqlPreOpen 1, sql
do c=0 by 1 while sqlFetchInto(1, ':cr, :ix, :tc, :tb')
call mAdd o, ty lefA(strip(cr)'.'strip(ix), 30) ,
'tb' strip(tc)'.'strip(tb)
end
call sqlClose 1
end
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then do
if ty = 'AL' then
sql = 'location, tbCreator, tbName'
else
sql = "'', dbName, tsName"
sql = 'select creator, name,' sql,
'from sysibm.systables' ,
'where type =' quote(left(ty, 1), "'"),
'and creator' sqlClause(qu),
'and name' sqlClause(nm)
call sqlPreOpen 1, sql
do c=0 by 1 while sqlFetchInto(1, ':cr, :tb, :lo, :db, :ts')
info = strip(db)'.'strip(ts)
if lo <> '' then
info = strip(lo) || '.' || info
if ty = 'AL' then
info = 'for' info
else
info = 'ts' info
call mAdd o, ty lefA(strip(cr)'.'strip(tb), 30) info
end
call sqlClose 1
end
else if ty = 'TS' then do
sql = 'select creator, name, dbName, tsName' ,
'from sysibm.systables' ,
'where type = ''T'' and dbName' sqlClause(qu),
'and tsName' sqlClause(nm)
call sqlPreOpen 1, sql
do c=0 by 1 while sqlFetchInto(1, ':cr, :tb, :db, :ts')
call mAdd o, ty lefA(strip(db)'.'strip(ts), 30) ,
'tb' strip(cr)'.'strip(tb)
end
call sqlClose 1
end
if c = 0 then
call mAdd o, ty lefA(strip(qu)'.'strip(nm), 30) ,
'* nicht gefunden'
else if c = 'ni' then
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
else if m.o.0 < 1 then
call err 'no expand for' ty qu'.'nm
return
endProcedure expandScope
/*--- return sql condition (= String oder like String) ---------------*/
sqlClause: procedure expose m.
parse arg val
val = translate(val, '%_', '*?')
if verify(val, '%_', 'm') > 0 then
return 'like' quote(val, "'")
else
return '=' quote(val, "'")
endProcedure sqlClause
lefA: procedure expose m.
parse arg s, len
if length(s) < len then
return left(s, len)
else
return s
endProcedure lefA
/*--- copy srcDdl und srcCat aus anderem rz --------------------------*/
receiveSource: procedure expose m.
parse arg rz
if rz = '' | rz = '*' | rz = m.myRz then
call err 'rs receiveSource mit ungueltigem rz' rz
call readAuftrag rz, m.auftrag.dataset, m.e.auftrag
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'keine Version in Auftrag' m.e.auftrag 'im' rz
nacMbr = left(m.e.auftrag, 7) || m.e.nachtrag
call csmCopy rz'/'m.libPre'.srcDdl('nacMbr')', m.libPre'.'rz'DDL'
call csmCopy rz'/'m.libPre'.srcCat('nacMbr')', m.libPre'.'rz'Cat'
call readAuftrag , m.auftrag.dataset, m.auftrag
call mAdd auftrag, addDateUs('receiveSource' rz,
m.libPre'.'rz'Cat('nacMbr')')
return
endProcedure receiveSource
/*--- copy wsl aus anderem rz ----------------------------------------*/
receiveWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if rz <> '' then do
call csmCopy rz'/'sWsl, sWsl
if adrCsm("dslist SYSTEM("rz") DSNMASK('"sIff"') SHORT", 4) = 0,
& stemSize = 1 then
call csmCopy rz'/'sIff, sIff
else
say 'iff existiert nicht im' rz
end
call cloneWsl '', m.e.auftrag, 1
call mAdd auftrag, addDateUs('receiveWSL' rz)
return
endProcedure receiveWSL
/*--- send wsl to the argument rz ------------------------------------*/
sendWSL: procedure expose m.
parse arg rz
if rz = m.myRz then
rz = ''
call analyseAuftrag
if m.versions = '' | m.compares <> '' then
call warn 'sendWSL ohne versions oder mit compares'
sWsl = 'dsn.dba.clon.wsl('left(m.e.auftrag, 7)'Q)'
sIff = 'dsn.dba.'left(m.e.auftrag, 7)'Q.IFF'
if sysDsn("'"sWsl"'") <> 'OK' then
call err 'source wsl fehlt:' sWsl sysDsn("'"sWsl"'")
if rz <> '' then do
call csmCopy sWsl, rz'/'sWsl
if sysDsn("'"sIff"'") <> 'OK' then
say 'iff existiert nicht' sIff sysDsn("'"sIff"'")
else
call csmCopy sIff, rz'/'sIff
end
call cloneWsl rz, m.e.auftrag, 1
call mAdd auftrag, addDateUs('sendWSL' rz)
return
endProcedure sendWSL
/*--- clone a wsl mbr in the rz sys,
if doRemove=1 remove old members first ---------------------*/
cloneWsl: procedure expose m.
parse arg sys, mbr, doRemove
/* copy multi clone jcl from target rz */
jcl = csmSysDsn(sys'/DSN.DBA.MULTI.CLONE'right(mbr, 1)'.JCL', 0)
CALL READdsn jcl, m.jj.
/* modify the jcl */
do jx=1 to m.jj.0
if word(m.jj.jx, 2) == '=' then do
if word(m.jj.jx, 1) = 'SRCWSLST' then
m.jj.jx = 'SRCWSLST =' left(mbr, 7)'Q'
else if word(m.jj.jx, 1) = 'CLNWSLST' then
m.jj.jx = 'CLNWSLST =' mbr
end
else if space(subword(m.jj.jx, 1, 2) ,1) ,
== '//DELMBRIF IF' then do
m.jj.jx = '//DELMBRIF IF RC =' (7 *(^doRemove)) 'THEN'
end
else if word(m.jj.jx, 1) == 'DELETE' then do
nm = word(m.jj.jx, 2)
cx = pos('(', nm)
if right(nm, 1) = ')' & cx > 0 then
m.jj.jx = ' DELETE' left(nm, cx)mbr')'
else
call err 'bad delete' jx m.jj.jx
end
end
call writeSub jj, sys, 1
return 0
endProcedure cloneWsl
warn:
say '*** warning:' arg(1)
return
endSubroutine warn
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) ^== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask ^== wert then
return 0
m.st.0 = sx
return 1
end
if ^ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse upper arg dd, disp, dsn, rest, nn, retRc
sys = ''
al = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if abbrev(disp, 'SYSOUT(') then
al = al disp
else
al = al "DISP("disp")"
if dsn <> '' then do
al = al "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
al = al 'MEMBER('mbr')'
end
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 to 1
alRc = adrCsm(al rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 then,
leave
say 'csmAlloc rc' alRc 'for' al rest '...trying to create'
call adrCsm 'allocate' left(al, length(al)-4)'CAT)' ,
dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
call err 'cmsAlloc rc' alRc 'for' al rest
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm 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 expose m.
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
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
rr = adrTso('DSN SYSTEM('sys')', '*')
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/* copy sql end **************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = ''
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
drop m.a.k m.st.kx
end
m.st.0 = 0
if abbrev(a, 'MAP.') then do
do kx=1 to m.map.loKy.a.0
drop m.map.loKy.a.kx m.map.loVa.a.kx
end
m.map.loKy.a.0 = 0
end
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
if mapValAdr(a, ky) ^== '' then
call err 'duplicate key in mAdd('a',' ky',' val')'
if length(ky) < 200 then do
m.a.ky = val
end
else do
kx = mInc('MAP.LOKY.'a'.0')
m.map.loKy.a.kx = ky
m.map.loVa.a.kx = val
end
if m.map.keys.a ^== '' then
return mAdd(m.map.keys.a, ky)
return
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky)
if vv ^== '' then
m.vv = val
else
call mapAdd a, ky, val
return val
endProcedure mapPut
/*--- return the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg a, ky
if length(ky) < 200 then do
if symbol('m.a.ky') == 'VAR' then
return a'.'ky
end
else if ^ abbrev(a, 'MAP.') then do
call err 'key too long mapValAdr('a',' ky')'
end
else do
do kx=1 to m.map.loKy.a.0
if m.map.loKy.a.kx == ky then
return 'MAP.LOVA.'a'.'kx
end
end
return ''
endProcedure mapValAdr
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
val = m.a.ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if abbrev(vv, 'MAP.LOVA.') then
call err 'not implemented mapRemove('a',' ky')'
drop m.a.ky
return val
endProcedure mapRemove
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) ^== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a,
fail if it does not exist ----------------------------------*/
mapGet: procedure expose m.
parse arg a, ky, noKey
vv = mapValAdr(a, ky)
if vv == '' then
call err 'missing key in mapGet('a',' ky')'
return m.vv
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy 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 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(s005y000) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"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
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 *****************************************************/