zOs/REXX/DBXBB
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.1
13.01.16
edit macro fuer CS Nutzung von CA RCM
(die a* Funktionen gehen auch mit tso dbx ...)
? diese Hilfe
aa,aw,ac pr us naechsten Auftrag ab Tabelle erstellen
aa: anzueigen, aw, ac entsprechendes Member editieren
n,na,nc,nt neuen Auftrag erstellen (nt = test)
q dbSy? query und expandiert Scope Zeilen vom Db2Catalog
* fuegt alle bestehenden Objekte ein
* UNDO um Expansion rueckgaengig zu machen
* mit q, qq, etc. Zeile selekieren, sonst Alle
* funktioniert nicht nur in Auftrag
* dbSy hier wird gesucht sonst in source
c op1? create ddl from source
i | ia | ie subs nct changes in Db2Systeme importier(+ana+exe)
subs = sub(,sub)*: Liste von Stufen/rzDbSys
sub: RR2/DBOF (im PTA), RZY(betr. dbSy)
X, Y, Z, Q, R, P, UT, ST, SIT, IT Abkuerzungen
==> sucht im PromotionPath
nct: Nachtrag: leer=noch nicht importiert sonst angegeb
8: Nachtrag 8, *: neuster, =: wie letztes Mal
v* ! e* rzDb? nt?: view/edit ana,cdl,ddl,exe etc. locally or remote
* ist der llq oder Abkuerzung: a->ana, a1->an1
rzDb gibt rz und dbsys: rzz/de0g, ze, z, etc
nt Nachtrag, sucht neuest Import mit diesen Bedingunen
ren dbSy rename DSNs der Execution der Analyse in DBSystem
z 18? fun args fuer alle Auftraege / 18:00 Auftraege des ZglSchubs
zStat Zuegelschub Statistik siehe wiki help
opt* Optionale Optionen
-f force: ignoriere QualitaetsVerletzungen
oder dbx c im QualitaetsMember
-aAuft oder Auft: AuftragsMember oder DSN
Typen fuer scope und dbx q (analog adminTool, grossOderKlein ist egal):
type DB TS TB VW AL IX UDT UDF TG SP SQ SY
1stelliges Kuerzel D S T V A X E F J O Q Y
Optionen im Auftrag: vPT VP*, keeptgt 0, qCheck 0, dbaCheck 0, ddlOnly 1
ca, bmc, ibm
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)
wiki help http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Dbx
************************************************************************
19.11.2015 Walter remote edit, anaPre .......
*/ /* end of help
8. 6.2015 Walter kidi63 ==> klem43
8. 9.2014 Walter warning falls ungueltiger ZS und kein update tadm70
29. 8.2014 Walter RQ2 rein, RZ1 raus
14. 7.2014 Walter zstat in rq2
26. 5.2014 Walter dbx q: auch TS mit History Tabellen anzeigen
17. 3.2014 Walter zstat: zuegelschub Datum korrigiert
18. 2.2014 Walter Integration in auftragsTable
23.12.2013 Walter dbx q findet tables mit type<>T, wieder csm.div
4.12.2013 Walter zStat macht nur Warnung wenn ana <> auftrag
25.10.2013 Walter move rz8 --> rzx
2.10.2013 Walter rename Analysis in ZielRz nicht RZ4 wegen Release
27. 9.2013 Walter move to rz4
26. 9.2013 Walter promotePaths UT,ST,SIT,x,y,z, nachtrag *
23. 9.2013 Walter vp0/1/2/3/4/16/17 + vp0=default
16. 9.2013 Walter Nachtraege in zSTat geflickt
2. 9.2013 Walter ueberall class=log (auch PTA|)
30. 8.2013 Walter vP17 fuer CA Tool Version 17
19. 8.2013 Walter zstat in rz4
9. 8.2013 Walter schenv pro rz in JobCard generiert
19. 7.2013 Walter qualityCheck fuer VW, kein Check wenn keine Objs
8. 7.2013 Walter zStat auch im RR2
28. 6.2013 Walter fix qualityCheck fuer Db
26. 6.2013 Walter dbx c in QualitaetsMember fuer Weiterarbeit ohne -f
25. 6.2013 Walter v2.4: zSta, Namen angepasst auf ca ...
11. 6.2013 W. Keller qualityCheck mit Verglich in RZ2 und vq
14. 5.2013 W. Keller VPT für tool Alias PT
07. 5.2013 W. Keller crLib with primary 1000 cyls (avoid alloc err)
03. 4.2013 W. Keller IA erstellt jetzt exeJcl in dsn.dbx<dbSys>.exe
07. 3.2013 W. Keller in neuem Auftrag: CA und VDPS Warnung
06. 2.2013 W. Keller ca scope fuer Triggers
31. 1.2013 W. Keller integration anaPost und start, variable auf7
24. 1.2013 W. Keller initial edit macro AC fuer CA Analysen
18. 1.2013 W. Keller caDdl->ddl, caGlbChg->glbChg ohne dbxRen.*
9. 1.2013 W. Keller ddlOnly fuer CA eingebaut
8.01.2013 W. Keller rename fuer CA eingebaut: dbx ni030121 ren dbaf
13.12.2012 W. Keller Fehler bei 1 stellig import (verwechslung nachtr)
7.12.2012 W. Keller .stry -> .ana, vy -> va etc.
5.12.2012 W. Keller ca implementation I
9.11.2012 W. Keller ey und vy für view/edit strategy
23. 8.2012 W. Keller v1015 für extract
13. 7.2012 W. Keller typo in query scope
18. 5.2012 W. Keller im neuen Auftrag source DX0G target DC0G/DCVG @rz8
PromotionPaths angepasst und vereinfacht
4. 4.2012 W. Keller sqlQuery via csm for dbx q and qualitycheck
4. 4.2012 W. Keller fix, import submits after last import empty, chroi
14. 2.2012 W. Keller ca prototype
23.12.2011 W. Keller bmc prototype
13.12.2011 W. Keller RZ0, ToolPrefix, csmCopy
3.11.2011 W. Keller Zuegeltermine 2012
6. 9.2011 W. Keller v10 RZ8 DE0G UND DM0G ausgebaut
29.08.2011 W. Keller v10 default mit p8 und p9 alias
24.06.2011 W. Keller v10 und v72
8.06.2011 W. Keller stored procedures editiert und version=%
26.05.2011 W. Keller qCheck 0 eingefügt
30.03.2011 W. Keller import et, it, .... , DD0G -> it, trg dc0g, i pa
24.12.2010 W. Keller plexZ (mit location CHROI00Z...)
10.12.2010 W. Keller db2 release 915, damit instead of trigger kommen
19.11.2010 W. Keller viewEdit macht jetzt view für v* statt immer edit
14.10.2010 W. Keller dp4g und dp2g in rz4.* bzw rz2.*, Zuegelsch 2012
24. 8.2010 W. Keller zusätzliche Typen für scope und dbx q
23. 8.2010 W. Keller dbzf ausgebaut
6. 8.2010 W. Keller vc vj vs vt ec ej es et nt? eingebaut
5. 8.2010 W. Keller stepName recTrg instead of recSrc for target
12. 7.2010 W. Keller sq=sequence für compare (fehlt noch in q)
18. 2.2010 W. Keller class=BS0 für PTA (wegen RR25 und RR26)
11. 2.2010 W. Keller dbaCheck mit ex0
9. 2.2010 W. Keller sendJob timeout 600 auch in extractScopeVersion
1.12.2009 W. Keller CSM.RZ1.P0.EXEC statt CMS.DIV...
12.11.2009 W. Keller Qualitätsfehler ohne -f stoppt wieder
25.10.2009 W. Keller DeltaNew überall, -a Optione, batch und do removed
28.09.2009 W. Keller Optionen keepTgt 0 und dbaCheck 0
10.09.2009 W. Keller mask ausschalten falls kein maskFile
07.09.2009 W. Keller fix error with dbaMulti
25.08.2009 W. Keller err statt fehl in line 1001
12.08.2009 W. Keller batch (ohne for) geflickt, ac pr -r: return new mbr
12.08.2009 W. Keller Zuegelschub wird nach Datum ausgesucht
19.05.2009 P. Kuhn DEFER im Masking ignorieren
05.03.2009 P. Kuhn Qualitaets-Check "ts not logged" eingebaut
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)
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
LCTL
sämtliche infos aus XLS
jedesmal Zwischenspeichern mit und restore Funktion
analyze generieren, falls möglich
batch Funktionen ganzen Zügelschub importieren usw. ==> mit wsh|
generierte Runs starten in richtiger Reihenfolge
mails an Entwickler schicken
Rückmeldung falls keine changes (leeres cdl)
Type Tabelle
char type Variabeln
fuer extract
db d DB
ts s TS
tb/vw/alias a v t - own name
ix x IX
userDefinedTy e - sch udt
function f - sch udf
trigger j TG qual name
storedProc o SP qual name
sequence q SQ qual name
synonym y SY qual name
**** 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 hi
/* call jIni ?????? */
parse upper arg oArgs
oArg1 = word(oArgs, 1)
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.aTb = 'oa1p.tAdm70A1'
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
if 1 & oArgs = '' then do
oArgs = 'count ~tmp.text(qx010011)'
say 'testing' oArgs
end
if oArgs = '' | pos('?', oArgs) > 0 then
exit help()
call dbxIni
m.exitValue = 0
call work oArgs
call sqlDisconnect
exit m.exitValue
/*--- hier wählen wir die wirklich Arbeit aus -----------------------*/
work: procedure expose m.
parse arg wArgs
parse upper var wArgs fun args
args = strip(args)
call mapReset e, 'K'
call mapPut e, 'dol', '$'
call stepGroup 1
m.auftrag.force = 0
m.e.toolAlias = 'P0'
do forever
r = substr(fun, 1 + 2*abbrev(fun, '-'))
if abbrev(fun, '-A') | length(fun) >= 8 then do
if verify(r, '.()', 'm') < 1 then do
m.auftrag.member = r
end
else do
m.auftrag.dataset = dsnSetMbr(r)
m.auftrag.member = dsnGetMbr(r)
end
end
else if abbrev(fun, '-F') then
m.auftrag.force = 1
else if abbrev(fun, '-') then
call err 'bad opt' fun 'in' wArgs
else
leave
parse var args fun args
if fun = '' then
return errHelp('fun missing in args:' wArgs)
end
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 = iiDS(org)'.SKELS(dbx'
m.libPre = 'DSN.DBQ'
end
else do
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
end
if 1 then do /* ??? testSkels */
if userid() = 'A540769' then
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test skels' m.libSkels '|||'
end
m.libSpezial = m.libPre'.spezial'
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ1 then
m.myDbSys = DBAF
else if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
call mapPut e, 'rexxLib', 'DSN.DB2.EXEC'
call mapPut e, 'libSkels', translate(m.libSkels)
call mapPut e, 'ovrDD', 'DISP=SHR,DSN='m.libPre'.MASK(OVERRIDE)'
call mapPut e, 'libPre', m.libPre
call mapPut e, 'tst', date('s') time()
if fun = 'Q' then /* macht process selber | */
return queryScope(args)
if fun == 'Z' then
return zglSchub(args)
if m.editMacro & ^ m.editProc then do
call adrEdit 'process'
m.editProc = 1
end
if fun = 'COUNT' then
return countAna(args)
if wordPos(fun, 'AA NC NW') > 0 then
return nextAuftrag(word(args, 1), substr(fun, 2), word(args, 2))
else if wordPos(fun, 'AC AW') > 0 then
return nextAuftragFromATb(word(args, 1),
, substr(fun, 2), word(args, 2))
else if fun = 'C' & m.editMacro,
& right(m.edit.dataset, 8) = '.QUALITY' then
return qualityOk(fun, args)
else if fun = 'CLONEWSL' then
return cloneWsl(word(args, 1), word(args, 2), 1==word(args, 3))
else if fun = 'CPDUM' then
return cpDum(args)
else if fun = 'CRLIB' then
return crLib(args)
else if fun = 'REN' then
return renExeDsns(m.auftrag.member, args)
else if fun = 'ZSTAT' then
return zStat(args)
call memberOpt
if m.sysRz <> 'RZ4' then
call err 'dbx laeuft nur noch im RZ4'
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 wordPos(fun, 'I IA IE') > 0 then
call import fun, 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 if abbrev(fun, 'E') | abbrev(fun, 'V') then
call viewEdit fun, 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
/*--- ini the CS config ----------------------------------------------*/
dbxIni: procedure expose m.
m.timeout = 600
m.uId = strip(userid())
if m.uId = 'A234579' then
ii = 'Marc ma'
else if m.uId = 'A390880' then
ii = 'Martin sm'
else if m.uId = 'A540769' then
ii = 'Walter wk'
else if m.uId = 'A754048' then
ii = 'Alessandro ac'
else if m.uId = 'A790472' then
ii = 'Agnes as'
else if m.uId = 'A828386' then
ii = 'Reni rs'
else if m.uId = 'A586114' then
ii = 'Stephan sz'
else
ii = m.uId '??'
parse var ii m.uNa m.uII
m.e.toolVers = ''
m.scopeTypes = 'DB TS TB VW AL IS IX UDT UDF TG SP SQ SY'
m.scopeType1 = 'D S T V A X E F J O Q Y'
m.nachtragChars = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ'
/* PromotionPaths neu */
m.promN = 'X Y Z Q R P'
m.promN_A = 'UT ST SI SIT ET IT PQ PA PR'
m.promN_T = 'X Y Z,Q Z,Q X Y,Z,Q Q R P'
m.promD.1 = 'RZX/DE0G RZY/DE0G RZZ/DE0G' ,
'RQ2/DBOF RR2/DBOF RZ2/DBOF'
m.promD.2 = 'RZX/DEVG RZY/DEVG RZZ/DEVG' ,
'RQ2/DVBP RR2/DVBP RZ2/DVBP'
m.promD.0 = 2
/* promI columns in auftragsTable aTb */
m.promI.0 = 0
call dbxI2 'UT RZX/DE0G DEVG UT_RZX_DE0G ID1'
call dbxI2 'ST RZY/DE0G DEVG ST_RZY_DE0G ID4'
call dbxI2 'SIT RZ1/DBTF DVTB SIT_RZ1_DBTF ID2'
call dbxI2 'SIT RZZ/DE0G DEVG SIT_RZZ_DE0G ID3'
call dbxI2 'PQA RQ2/DBOF DVBP PTA_RZQ_DBOF ID6'
call dbxI2 'PTA RR2/DBOF DVBP PTA_RR2_DBOF ID5'
call dbxI2 'PROD RZ2/DBOF DVBP PROD_RZ2_DBOF ID7'
m.lastSaidToolV = 'P0'
return
endProcedure dbxIni
dbxI2: procedure expose m.
px = m.promI.0 + 1
m.promI.0 = px
parse arg m.promI.px
parse arg e rzD1 d2 fDt fUs
m.promI.rzD1 = fDt fUs
rzD2 = left(rzD1, 4)d2
m.promI.rzD2 = fDt fUs
return
endProcedure dbxI2
/*--- create the necessary dbx libraries locally ---------------------*/
crLib: procedure expose m.
parse arg subs
rz = sysvar(sysnode)
call crLibCr 'DSN.DBX.AUFTRAG'
call crLibCr 'DSN.DBX.DDL'
call crLibCr 'DSN.DBX.GLBCHG'
call crLibCr 'DSN.DBX.JCL'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call crLibCr 'DSN.DBX's1'.ANA'
call crLibCr 'DSN.DBX's1'.AN1'
call crLibCr 'DSN.DBX's1'.DDL'
call crLibCr 'DSN.DBX's1'.DD1'
call crLibCr 'DSN.DBX's1'.DD2'
call crLibCr 'DSN.DBX's1'.EXE'
call crLibCr 'DSN.DBX's1'.REC'
call crLibCr 'DSN.DBX's1'.RE1'
call crLibCr 'DSN.DBX's1'.RDL'
call crLibCr 'DSN.DBX's1'.AOPT'
call crLibCr 'DSN.DBX's1'.QUICK'
end
return 0
endProcedure crLib
crLibCr: procedure expose m.
parse arg lib
call dsnAlloc lib'(DUMMY) dd(l1)' ,
'::f mgmtClas(COM#A076) space(1000, 1000) cyl'
call tsoFree l1
return 0
endProcedure crLibCr
crLibRe: procedure expose m.
parse arg lib, old
if sysDsn("'"old"'") <> "OK" then
return crLibCr(lib)
call adrTso "rename '"old"' '"lib"'"
return 0
endProcedure crLibRe
/*--- create the necessary dbx libries in the specified rz -----------*/
cpDum: procedure expose m.
parse arg rz subs
call cpDum1 rz, 'DSN.DBX.AUFTRAG(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.AUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.CDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBAUTO(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBSRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.DBTRGDDL(DUMMY)'
*/
call cpDum1 rz, 'DSN.DBX.JCL(DUMMY)'
/* call cpDum1 rz, 'DSN.DBX.MASK(DUMMY)'
call cpDum1 rz, 'DSN.DBX.OVRCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SENDCF(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SPEZIAL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.SRCDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGCAT(DUMMY)'
call cpDum1 rz, 'DSN.DBX.TRGDDL(DUMMY)'
*/call cpDum1 rz, 'DSN.DBX.DDL(DUMMY)'
if rz = 'RZ1' then
call cpDum1 rz, 'DSN.DBX.RENAMDDL(DUMMY)'
call cpDum1 rz, 'DSN.DBX.GLBCHG(DUMMY)'
do sx=1 to words(subs)
s1 = word(subs, sx)
if length(s1) \= 4 then
call err 'bad subsys' s1
call cpDum1 rz, 'DSN.DBX's1'.ANA(DUMMY)',
, 'DSN.DBXDBAF.ANA(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.REC(DUMMY)',
, 'DSN.DBXDBAF.REC(DUMMY)'
call cpDum1 rz, 'DSN.DBX's1'.DDL(DUMMY)',
, 'DSN.DBXDBAF.DDL(DUMMY)'
end
return 0
endProcedure cpDum
cpDum1: procedure expose m.
parse arg sys, dsn, fr
if fr == '' then
fr = dsn
say '???cpDum' sys dsn fr
if sysDsn("'"fr"'") <> 'OK' then
call writeDsn fr, x, 0, 1
call csmCopy fr, sys'/'dsn
return
endProcedure cpDum1
renExeDsns: procedure expose m.
parse arg ana, dbsy
if length(ana) <> 8 then
call errHelp 'bad analysis' ana 'for ren'
if length(dbsy) <> 4 then
call err 'bad dbSystem' dbSy 'for ren'
if ana = m.edit.member then do
call memberOpt
call analyseAuftrag
ana = overlay(m.e.nachtrag, ana, 8)
end
msk = 'DSN.?'dbsy'.'ana'.**'
call csiOpen csi, 'DSN.C'dbsy'.'ana'.**'
do dx=1 while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
call csiOpen csi, 'DSN.R'dbsy'.'ana'.**'
do dx=dx while csiNext(csi, 'CSI.'dx)
/* say dx m.csi.dx */
end
dx = dx - 1
last = 'ff'x
cA = 0
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
cA = cA + 1
else if ly << last then
last = ly
/*say 'y' ly 'l' last 'dsn' m.csi.cx */
end
if cA == 0 then
call err 'keine aktuellen DSNs in' msk'.A*'
if last == 'ff'x then do
nxt = 'Z'
end
else do
abc = m.ut.alfUC
ax = pos(last, abc)
if ax < 2 then
call err 'last' last 'keine rename moeglich'
nxt = substr(abc, ax-1, 1)
end
say 'renaming' ca 'DSNs from' msk'.A* to' msk'.'nxt'*'
do cx=1 to dx
lx = lastPos('.', m.csi.cx)
ly = substr(m.csi.cx, lx+1, 1)
if ly == 'A' then
call adrTso 'rename' ,
"'"m.csi.cx"'" "'"overlay(nxt, m.csi.cx, lx+1)"'"
end
return 0
endProcedure renExeDsns
/*--- die Konfiguration pro db2 dbSy -------------------------------*/
configureRZSub: procedure expose m.
parse arg rz, dbSy
call configureRZ rz
call configuredbSy rz, dbSy
return
endProcedure configureRZSub
configureDbSy: procedure expose m.
parse arg rz, dbSy
call mapPut e, 'subsys', dbSy
if rz = 'RZX' then
call mapPut e, 'location', 'CHROI00X'dbSy
else if rz = 'RZY' then
call mapPut e, 'location', 'CHROI00Y'dbSy
else if rz = 'RZZ' then
call mapPut e, 'location', 'CHROI00Z'dbSy
else
call mapPut e, 'location', 'CHSKA000'dbSy
return
endProcedure configureDBSy
/*--- die Konfiguration pro RZ ---------------------------------------*/
configureRZ: procedure expose m.
parse arg rz, rel px, toolV
if rz = 'RZ0T' then
rz = 'RZ0'
if rz = '' then
rz = m.myRz
else
m.myRz = rz
m.jobCard = 'jobCa'
call mapPut e, 'jobCla', 'LOG'
rx = pos(rz'/', m.promD.1)
if rx < 1 then
m.pr1Sub = '?noSubsys?'
else
m.pr1Sub = substr(m.promD.1, rx+4, 4)
call mapPut e, 'schenv', 'DB2ALL'
call mapPut e, 'rz', rz
zz = overlay('Z', rz, 2)
call mapPut e, 'zz', zz
if rz = m.myRz then
call mapPut e, 'csmDD'
else
call mapPut e, 'csmDD', ",(SUBSYS=(CSM,'SYSTEM="rz"'))"
if rel == '' then
rel = 1015
if px == '' then
px = if(rz\=='RZ0', 'P0', 'PB')
call mapPut e, 'db2rel', rel
call mapPut e, 'db2relAl', px
call mapPut e, 'dsnload', 'DB2@.'zz'.'px'.DSNLOAD'
if toolV \== '' then
m.e.toolVers = toolV
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
call mapPut e, 'toolPreP', 'DSN.TOOLS.'zz'.P0'
call mapPut e, 'toolPreC', 'DSN.TOOLS.'zz'.C0'
/* toolV = copies(m.e.toolVers, rz == 'RZ1') */
toolV = m.e.toolVers
toolRZAl = zz'.'if(toolV == '', 'P0', toolV)
if m.lastSaidToolV \== substr(toolRzAl, 5) then do
m.lastSaidToolV = substr(toolRzAl, 5)
say 'tool version unter Alias' toolRzAl,
if(substr(toolRzAl, 5) =='P0', '==> v16')
end
call mapPut e, 'capref', 'DSN.CADB2.'toolRzAl
call mapPut e, 'caload', 'DSN.CADB2.'toolRzAl'.CDBALOAD'
call mapPut e, 'cacr', DBX
if rz = 'RZ1' then do
if m.libPre = 'DSN.DBQ' then do
m.pr1Sub = 'DQ0G'
m.jobCard = 'jobCQ'
call mapPut e, 'toolPreP', 'DSN.ADB72.P0'
call mapPut e, 'toolPreC', 'DSN.ADB72.C0'
end
end
return
endProcedure configureRZ
/*--- Member Namen prüfen und Auftrag lesen---------------------------*/
memberOpt: procedure expose m.
if m.auftrag.dataset <> m.libPre'.AUFTRAG' then
call err 'e}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 'e}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 opt, ai
if abbrev(rz, '-') then do
opt = rz
rz = ''
end
opt = translate(opt)
if rz = '' | rz = '*' then
rz = m.myRz
if m.myRz <> 'RZ4' then
if m.myRz = 'RZ1' then
call err 'dbx wurde ins RZ4 gezuegelt'
else
call err 'Auftrag für RZ' rz 'muss aus RZ4 erstellt werden'
auft = m.libPre'.AUFTRAG'
call mAdd mCut(na, 0), auft
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 wordPos(make, 'C W') < 1 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, ai
dsnNN = dsnSetMbr(auft, nn)
call writeDsn dsnNN, m.auftrag.
if ai \== '' then do
call sqlUpdate 7, 'update' m.aTb "set workliste='"nn"'" ,
", chg='"make"'",
"where workliste='' and pid ='"m.ai.pid"'" ,
" and name ='"m.ai.name"'"
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
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')
cChgs = 'ALLLALLL'
iChgs = 'QZ91S2T'
end
else do
ow = 'S100447'
end
if m.auftrag.0 <> 0 then
call err 'fun n erstellt neuen Auftrag nur in leeres Member'
/* wahrscheinlichen Zügelschub bestimmen*/
if ai == '' then do
/* loops in 2015 and later ......
zglS = '20130208 20130510 20130809 20131108' ,
'20140214 20140509 20140808 20141114 2015????'
zi = date('s')
zi = overlay(right(substr(zi, 5, 2)+1, 2, 0), zi, 5)
do wx=1 while zi >> word(zglS, wx)
end
zglSchub = if(isTst, 'test', word(zglS, wx) '??:00')
*/ zglSchub = '---'
best = 'pid name tel'
end
else do
zglSchub = m.ai.einfuehrung m.ai.zuegelschub
best = strip(m.ai.pid) strip(m.ai.name)
end
call mAdd auftrag ,
, addDateUs('auftrag ' auftName ow) ,
, ' Zuegelschub' zglSchub ,
, ' Besteller ' best ,
, ' cChgs ' cChgs ,
, ' iChgs ' iChgs ,
, ' keepTgt 0 '
if abbrev(auftName, 'VV') | abbrev(auftName, 'VDPS') then
call mAdd auftrag ,
, ' * ---------- Achtung VDPS -------------------------|' ,
, ' * nach jeder Aenderung alle anderen aktuellen |' ,
, ' * VDPS Auftraege Comparen (= DDL akutalisieren) |'
call mAdd auftrag ,
, 'source RZX/DX0G' ,
, ' ts' left(auftName, 4)'A1P.A%'
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
/*--- naechsten Auftrag aus Auftragstabelle --------------------------*/
nextAuftragFromATb: procedure expose m.
parse arg pre, make, srch
srch = '%'translate(strip(srch))'%'
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where workliste = '' and pid not like 'ADMI%' and (" ,
"translate(pid) like '"srch"'" ,
"or translate(name) like '"srch"')" , ai
if m.ai.0 = 1 then
ax = 1
else if m.ai.0 < 1 then
call err 'e}kein Auftrag like' srch 'gefunden'
else do forever
say m.ai.0 'auftraege like' srch
do ax=1 to m.ai.0
say ax m.ai.ax.pid m.ai.ax.name m.ai.ax.einfuehrung ,
m.ai.ax.zuegelschub
end
say 'welcher Auftrag? 1..'m.ai.0 'oder - fuer keinen'
parse pull ax .
if strip(ax) == '-' then
return ''
if verify(ax, '0123456789') = 0 & ax > 0 & ax <= m.ai.0 ,
& symbol('m.ai.ax.zuegelschub') == 'VAR' then
leave
say 'ungueltige Wahl:' ax
end
return nextAuftrag(pre, make, , 'AI.'ax)
endProcedure nextAuftragFromATb
/*--- 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
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', m.e.auf7 || m.e.nachtrag
if m.e.qCheck == 0 then nop
else if m.sysRz \== 'RZ1' & m.sysRz \== 'RZ4' then
say 'no quality check from' m.sysRz
else do
qx = m.scopeSrc.rz'/'m.scopeSrc.dbSy
px = m.promPath
qy = word(m.promD.px, words(m.promD.px))
if qualityCheck(qx, qy) then do
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 0
call adrIsp 'vput' vAns 'shared'
ddlxP = substr(m.auftrag.member, 8, 1)
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
call adrIsp "view dataset('"qDsn"'),
macro(ddlX) parm(ddlxP)",4
call adrIsp 'vget' vAns 'shared'
if pos('F', opts) < 1 & \ m.auftrag.force ,
& value(vAns) \== 1 then
return
else
say 'Compare trotz Qualitaetsfehlern'
end
end
m.o.0 = 0
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', function opts
call namingConv m.scopeTrg.rz, m.scopeTrg.dbSy, 'trgNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapExpAll e, o, skelStem(m.jobCard)
call mapPut e, 'ignore', shrDummy(mapExp(e, m.e.comIgno))
call bmcVarsProf 0
if 0 then /* db ddl extrahieren ja / nein ???? */
call extractSrcTrg o, 'DB', cmpLast m.e.auf7 || nacLast
if m.e.tool == ibm then
call extractSrcTrg o, '', cmpLast m.e.auf7 || nacLast
else if m.e.tool == bmc then
call bmcSrcTrg cmpLast m.e.auftrag
else if m.e.tool == ca then do
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
end
if fun = 'C' then do
if m.optOvr then do
call mapPut e, 'ovr', 'OVR'
call mapExpAll e, o, skelStem('OVR')
call mapPut e, 'src', 'OVR'
end
call mapPut e, 'keepTgtV', copies('KEEPTGT,', m.e.keepTgt)
if m.e.tool == ca then
call caDDL o, scopeSrc, translate(mapExp(e, m.e.cChgs))
else
call mapExpAll e, o, skelStem('COMP')
end
if fun = 'ST' then
call mapExpAll e, o, skelStem('ST')
call writeSub o
call mAdd auftrag, addDateUs(function ,
left('===', 3*cmpLast)m.e.nachtrag,
m.scopeSrc.rz'/'m.scopeSrc.dbSy ,
mapExp(e, "'${libPre}." ,
|| if(m.e.tool=="IBM","srcCat","DDL") ,
|| "($mbrNac)'"))
return
endProcedure compare
/*--- in the qualityMember say dbx c
to continue processing without option -f ------------------*/
qualityOk: procedure expose m.
parse arg fun
vAns = 'dbx'm.err.screen'QuAn'
call value vAns, 1
call adrIsp 'vPut' vAns 'shared'
return 0
endProcedure qualityOk
/*--- find the naming convention for a rz and dbSystem --------------*/
namingConv: procedure expose m.
parse arg rz, dbSy, var
if rz = '.' then do
if pos('.', dbSy) > 0 then
call err 'namingConv old target' dbSy
if pos('/', dbSy) > 0 then
parse var dbSy rz '/' dbSy
else
rz = m.sysRz
end
if strip(rz) = 'RZ1' then
t = strip(dbSy)
else
t = 'DBOF'
if var ^== '' then
call mapPut e, var, t
return t
endProcedure namingConv
skelStem: procedure expose m.
parse upper arg nm
st = 'SKEL.'nm
if symbol('m.st.0') \== 'VAR' then
call readDsn m.libSkels || nm || ')', 'M.'st'.'
return st
endProcedur skelStem
/*--- 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 = ''
call writeDsn sysl 'SYSOUT(T) dd(ir) .WRITER(INTRDR)', m.o.
end
return
endProcedure writeSub
/*--- view or edit a member -----------------------------------------*/
viewEdit: procedure expose m.
parse upper arg fun 2 wh . , a1 a2
call analyseAuftrag
if length(wh) > 2 then do
llq = wh
end
else do /* abbrev: first or first and last character */
ll = ' ANA AN1 AOPT DDL DDI DD1 DD2 EXE EXO' ,
'JCL QUALITY QUICK REC RE1 RDL START'
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then do
d = '* .JCL' m.e.auftrag
end
else if llq == 'QUALITY' | LLQ == 'DDL' then do
d = '* .'llq m.e.auf7 || left(a1 || m.e.nachtrag, 1)
end
else if llq == 'EXO' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
msk = r2'/DSN.DBY'd2'.'m.e.auf7'*.**.EXE'
if dsnList(oo, msk, 0) < 1 then do
say 'no datasets like' msk
return
end
do ox=1 to m.oo.0
d1 = m.oo.ox
d2 = substr(d1, pos('.', d1, 19)+1)
if ox=1 | abbrev(d2, '##DT') ,
| (d2 > dMi2 & \ abbrev(dMi2, '##DT')) then do
dMax = d1
dMi2 = d2
end
end
d = r2 dMax
end
else if llq == 'START' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 'DSN.DBY'd2'.'m.e.auf7'.'llq
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
if llq == 'DDI' then
llR = 'DDL'
else
llR = llq
d = r2 d2'.'llR m.e.auf7 || n2
end
parse var d rz dsn mbr
if length(dsn) <= 20 then
dsn = m.libPre || dsn
eFun = word('Edit View', 1 + (fun \== 'E'))
if llq = 'QUALITY' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wordPos(llq, 'ANA AN1 REC RE1 EXO') > 0 then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"dsn ,
|| copies("("mbr")", mbr<>'')"')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"dsn"')",
copies("member("mbr")", mbr <> '') mac, 4
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call setIf jOut
call setIf jOut'.TWO'
call mapExpAll e, jOut, skelStem(m.jobCard) /* Jobcards */
call configureRZ m.sysRz
rzLast = ''
call stepGroup 1
j0 = m.jOut.0
list = a2rzDbSysProm(rzDbSyList)
done = ''
do lx = 1 to words(list)
rzDBSys = word(list, lx)
parse value word(list,lx) with r '/' dbSy
if opt == '*' then do
nachAll = m.compares
end
else if opt == '=' then do
if symbol('m.imp.rzDBSys.nachtrag') == 'VAR' then
nachAll = m.imp.rzDBSys.nachtrag
else
nachAll = ''
end
else if opt \== '' then do
nachAll = opt
end
else do
if symbol('m.imp.rzDBSys.nachtrag') \== 'VAR' then
nachAll = m.compares
else
nachAll = substr(m.compares,
, 1+pos(m.imp.rzDBSys.nachTop, m.compares))
end
if nachAll == '' then
iterate
if fun = 'IE' & (r == 'RZ2' ,
| (r == 'RZ4' & \ (abbrev(m.e.auftrag, 'Q') ,
|abbrev(m.e.auftrag, '@E') ,
|abbrev(m.e.auftrag, 'WK')))) then
call err 'ie fuer Prod nicht erlaubt:' r'/'dbSy
if m.e.tool = 'CA' then
nachAll = 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
if trgNm = '' then
call err 'compare not found for nachtrag' nachAll
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)
if length(nachAll) = 1 then
nachVB = nachAll
else
nachVB = left(nachAll, 1)'-'right(nachAll, 1)
chaPre = m.e.auftrag'.'nachVB'.'m.imp.seq
zs = translate(strip(right(m.e.zuegelN8, 6)))
if m.e.tool = 'IBM' then
call mapPut e, 'change',chaPre'.'zs
else
call mapPut e, 'change',m.e.auftrag':'nachAll'/' ,
|| m.imp.seq'_'zs
call mapPut e, 'change', chaPre'.'zs
call mapPut e, 'changeRem', 'zs' m.e.zuegelSchub ,
'auf' m.e.auftrag nachAll 'import DBX'
call mapPut e, 'deltaVers', chaPre'.DLT'
call namingConv '.', rzDBSys, 'impNm'
call namingConv m.scopeSrc.rz, m.scopeSrc.dbSy, 'srcNm'
call mapPut e, 'trgNm', trgNm
call mapPut e, 'fun', 'import'fu2 rzDbSys
call mapPut e, 'fu2', fu2
call mapPut e, 'mbrNac', m.e.auf7 || right(nachAll, 1)
done = done rzDbSys
if r <> m.myRz then do
call importToRZ jOut
call configureRZ r
end
call configureDbSy r, dbSy
if m.e.tool == 'CA' then
call caImport jOut, fun, nachAll,
, translate(mapExp(e, m.e.iChgs)),
, translate(mapExp(e, m.e.iMap)),
, translate(mapExp(e, m.e.iRule))
else
call ibmImport jOut, fun, r, dbSy, nachAll,
, translate(mapExp(e, m.e.impMask)),
, translate(mapExp(e, m.e.impIgno))
call mAdd auftrag, addDateUs("import" rzDBSys nachAll,
mapGet(e, 'change') fu2)
call stepGroup
end
call importToRz jOut
if m.jOut.0 <= j0 then
say 'nothing to import'
else do
call addJobError jOut
call writeSub jOut
sq = ''
if m.e.zuegelN8 \== '' then do
today = translate('78.56.1234', date('s'),'12345678')
do dx=1 to words(done)
d1 = word(done, dx)
if symbol('m.promI.d1') \== 'VAR' then
call warn 'no col for' d1 'in AuftragsTable' m.aTb
else
sq = sq"," word(m.promI.d1, 1) "= '"today"'," ,
word(m.promI.d1, 2) "= '"m.uII"'"
end
end
if sq == '' then do
call warn 'zuegelSchub='m.e.zuegelSchub ,
'kein update in AuftragsTabelle' m.aTb
end
else do
call sqlConnect m.myDbSys
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'"
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'not in table' m.aTb
else if m.sql.1.updateCount \== 1 then do
call sqlUpdate 99, 'rollback'
call err 'auftrag' m.e.auftrag 'got' ,
m.sql.1.updateCount 'updateCount'
end
call sqlCommit
call sqlDisconnect
end
end
return
endProcedure import
importToRZ: procedure expose m.
parse arg o
toRz = m.myRz
call mapPut e, 'toRz', toRz
if m.o.send.0 \== 0 & m.sysRz \== toRz then do
sAft = ''
do sx=1 to m.o.send.0
c1 = m.o.send.sx
if m.cdlSent.toRz.c1 \== 1 then do
m.cdlSent.toRz.c1 = 1
if sAft == '' then do
call mapPut e, 'cdl', dsnSetMbr(c1)
call addIf o
call mapExpAll e, o, skelStem('sCdl')
jx = m.o.0
sAft = m.o.jx
jx = jx - 1
sCx = pos('(', m.o.jx)
m.o.jx = left(m.o.jx, sCx) || dsnGetMbr(c1) '-'
m.o.0 = jx
end
else do
call mAdd o, right(',', sCx) || dsnGetMbr(c1) '-'
end
end
end
if sAft \== '' then do
call mAdd o, right(')', sCx) '-', sAft
call addIf o, 'end'
call setIf o, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
call addIf o
call mAddSt o, o'.TWO'
call addIf o, 'end'
m.o.ifLine = m.o.two.ifLine
end
else do
call addIf o
call mapExpAll e, o, skelStem('subRz')
la = m.o.0
la = m.o.la
m.o.0 = m.o.0 - 1
call mapExpAll e, o, skelStem(m.jobcard) /*Jobcards*/
call addJobError o'.TWO'
call mAddSt o, o'.TWO'
call mAdd o, la
call addIf o, 'end'
call setIf o, 'SUB'toRz
end
m.o.two.0 = 0
call setIf jOut'.TWO'
m.o.send.0 = 0
return
endProcedure importToRZ
ibmImport: procedure expose m.
parse arg o, fun, rz, dbSys, nachAll, msk, ign
call mapPut e, 'ignore', shrDummy(ign)
call mapPut e, 'mask', shrDummy(msk, 1)
if rz <> m.sysRz then do
do nx=1 to length(nachAll) /* send changes to rz */
c1 = cdlDsnCheck(substr(nachAll, nx, 1))
call mAdd o'.SEND', c1
end
end
call mapPut e, 'cType', "''''T''''"
call mapPut e, 'inDdn', 'DCHG'
cdlPds = m.libPre'.CDL'
call mapPut e, 'cdlPds', cdlPds
call ibmImportExpand o'.TWO', nachAll
return
endProcedure ibmImport
ibmImportExpand: procedure expose m.
parse arg o, nachAll, deltaNew
call addIf o
ic = skelStem('Imp')
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 == '$@maskDD' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, '//MSKDDN1 DD' mapGet(e, 'mask')
end
else if w == '$@maskII' then do
if mapGet(e, 'mask') \= '' then
call mAdd o, " MSKDDN='MSKDDN1',",
, " MSKOWN='DUMMY',",
, " MSKNAME='DUMMY',"
end
else if w == '$@bmcCdl' then do
le = left('//IMPORTIN', 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
else if w ^== '$@cdl' then do
call err 'unbekannte Anweisung' w 'in Zeile' cx m.ic.cx
end
else do
inDdn = mapGet(e, 'inDdn')
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
sto = mapExpAllAt(e, o, ic, lx, cx + length(w))
end
call addIf o, 'end'
call setIf o, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddC.1 = 1
ddC.2 = 2
ddC.3 = 'L'
ddlIx = 3 - (iChgs \== '') - m.e.anapost
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib|| ddC.ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddC.ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddlBB
end
call addIf o'.TWO'
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly == '') ,
copies('keepTgt0', m.e.keepTgt == 0) ,
copies('anaPost0', m.e.anaPost == 0)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AOPT'
call mapPut e, 'stry', nact
call addIf o'.TWO'
call stepGroup
ddlImp = ddlLib'L('nact')'
if m.e.anaPost then do
call mapPut e, 'ddlIn', ddlAA
call mapPut e, 'ddlOut', ddlImp
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'PRE'
call addIf o'.TWO'
end
call mapPut e, 'ddlin', ddlImp
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'AUTO'
if wordPos(fun, 'IA IE') > 0 then do /* analyse step */
call stepGroup
if m.e.tool = ibm then
call err 'fun' fun 'not implemented for' m.e.tool
if m.e.aUtil = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' m.e.aUtil' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
call addIf o'.TWO'
call mapExpAll e, o'.TWO', skelStem('CAna')
if m.e.anapost then do
call mapExpAll e, o'.TWO', skelStem('CPost')
call setIf o'.TWO', 'ANA', 0 4, 'POST'
end
else do
call setIf o'.TWO', 'ANA', 0 4
end
call addIf o'.TWO', 'end'
call addIf o'.TWO'
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
oldIf = m.o.two.ifLine
call setIf o'.TWO'
call mapPut e, 'fun', 'execute'
call mapExpAll e, o'.TWO', skelStem(m.jobcard)
call mAdd o'.TWO', '//* Zuegelschub' m.e.zuegelschub k,
, '//* analyse ' date(s) time() m.uNa ,
, '//* nachtrag ' m.e.nachtrag m.e.auf7 || m.e.nachtrag,
, '//* rename old unloads: TSO DBX' m.e.auf7||m.e.nachtrag,
"REN" mapGet(e, 'subsys')
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call mAdd o'.TWO', '}]'
call addIf o'.TWO', 'end'
m.o.two.ifLine = oldIf
call stepGroup old
call setIf o'.TWO', 'EXCP', 0 4
end
if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'EXE', 0 4
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIf o, 'end'
call setIf o, 'DDL', 0 4
call addIf o
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
call addIf o
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
if m.o.ifLine == ''then
call mapPut e, 'endIf', '//* no endIf'
else
call mapPut e, 'endIf', '// ENDIF'
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o,'// ENDIF' /* for if in skel dbxCRen */
call setIf o, 'RANA', 0 4
return
endProcedure caImpRename
stepGroup: procedure expose m.
parse arg f
old = m.e.stepNo
if f \== '' then
no = f
else
no = old + 1
m.e.stepNo = right(no, 3, 0)
m.e.stepGr = 'S'm.e.stepNo
call mapPut e, 'stp', m.e.stepGr
return old
endProcedure stepGroup
setIf: procedure expose m.
parse arg o, stp, codes
if stp == '' | m.e.tool = 'IBM' then
li = ''
else do
li = ''
do ax=2 by 2 to arg()
stp = arg(ax)
codes = arg(ax+1)
if length(stp) < 5 then
stp = m.e.stepGr || stp
li = li 'AND' stp'.RUN AND'
if codes == '' then
li = li stp'.RC=0'
else if words(codes) = 1 then
li = li stp'.RC='strip(codes)
else do
li = li '('stp'.RC='word(codes, 1)
do cx=2 to words(codes)
li = li 'OR' stp'.RC='word(codes,cx)
end
li = li')'
end
end
li = substr(li, 6)
end
m.o.ifLine = li
return
endProcedure setIf
addIf: procedure expose m.
parse arg o, opt, cond
if m.o.ifLine == '' & opt \== 1 then
return
else if opt == 'end' then
call mAdd o, '// ENDIF'
else do
pr = '// IF'
if cond == '' then
cond = m.o.ifLine
cond = space(cond, 1)
do while length(cond) > 53
ex = lastPos(' ', left(cond, 53))
call mAdd o, pr left(cond, ex-1)
cond = substr(cond, ex+1)
pr = left('//', length(pr))
end
call mAdd o, pr cond 'THEN'
end
return
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if cond = '' then
cond = 'RC=0'
call addIf o, 1, 'ABEND OR RC > 4 OR NOT (' cond ')'
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, '// ENDIF'
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
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.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.anaPost = 1
m.e.ddlOnly = 0
m.e.zuegelschub = ''
m.e.aOpt = ''
allImpSubs = ''
if m.auftrag.0 = 0 then
call err 'Auftrag ist leer'
vaWo = 'AUFTRAG'
varWo = 'ZUEGELSCHUB BESTELLER ICHGS IMPMASK IMAP IRULE IMPIGNO'
varWu = 'CCHGS COMMASK COMIGNO' ,
'AOPT AMODEL AUTIL VP0 VP1 VP2 VP3 VP4 VPT VP16 VP17' ,
'KEEPTGT DBACHECK QCHECK CA BMC IBM DDLONLY ANAPOST'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
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
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.auf7 = left(w2, 7)
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 abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA BMC IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
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 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 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 = m.nachtrag.0 + 1
m.nachtrag.0 = nx
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, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(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 . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
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
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.e.anaPost = m.e.anaPost == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
if m.e.ddlOnly == '' | m.e.ddlOnly == 1 then
m.e.ddlOnly = ''
else
m.e.ddlOnly = 'UNLOAD'
if m.e.cChgs == '' then
m.e.cChgs = 'PROT'm.e.prodDbSys
if m.e.iChgs == '' then
m.e.iChgs = dsnGetMbr(m.e.impMask)
else if m.e.impMask == '' then
m.e.impMask = m.libPre'.MASK('m.e.iChgs')'
if m.e.iRule == '' then
m.e.iRule = dsnGetMbr(m.e.impIgno)
else if m.e.impIgno == '' then
m.e.impIgno = m.libPre'.MASK('m.e.iRule')'
call mapPut e, 'aModel', m.e.aModel
zt = translate(m.e.zuegelschub, '000000000', '123456789')
if zt == '00.00.0000' then do
m.e.zuegelN8 = translate('67893401', m.e.zuegelSchub,
,'0123456789')
end
else if zt == '00000000' then do
m.e.zuegelN8 = m.e.zuegelSchub
m.e.zuegelschub = translate('78.56.1234', m.e.zuegelN8,
,'12345678')
end
else do
m.e.zuegelN8 = ''
end
m.targets = ''
m.compares = ''
m.versions = ''
drop cmpLast
m.cmpLast = 0
call mapPut e, 'tool', strip(m.e.tool m.e.toolVers)
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 0 & abbrev(m.scopeSrc.dbSy, 'DQ0') then
call configureRz , '915 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 dbSy
say ' scope ' m.scp.0 m.scp.dbSy ,
' target ' m.scopeTrg.0 m.scopeTrg.dbSy
do sx=1 to m.scp.0
say ' ' m.scp.sx.type m.scp.sx.qual'.'m.scp.sx.name
end
end
call bmcVars
return
endProcedure analyseAuftrag
sayImp: procedure expose m.
do ix=1 to m.imp.0
say 'imp' m.imp.ix.nachtrag 'to' m.imp.ix.rz'/'m.imp.ix.dbSys
end
/*--- eine Scope Zeile analysieren -----------------------------------*/
analyseScope: procedure expose m.
parse arg li
parse upper var li ty w1 rest
if wordPos(ty, m.scopeType1) > 0 then
ty = word(m.scopeTypes, wordPos(ty, m.scopeType1))
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 configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
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, 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 configureDbSy m.scopeTrg.rz, m.scopeTrg.dbSy
call mapPut e, 'what', xx'TRG'
if m.optAuto then do
call mapExpAll e, o, skelStem('AutMa')
if m.sysRz = m.scopeTrg.rz then do
call mapExpAll e, o, skelStem('AutEx')
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' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call mapExpAll e, o, skelStem('AutEx')
call sendJob2 o, sndIn, cf mark
end
end
else do
call extractScopeVersion o, xx, 'TRG'
end
return
endProcedure extractSrcTrg
/*--- Version + DDL zu extrahieren -----------------------------------*/
extractScopeVersion: procedure expose m.
parse arg o, ty, what
scp = 'SCOPE'what
/* say m.scp.rz 'scp' scp */
if m.sysRz = m.scp.rz then do
call extractVersionStep o, ty, what
end
else do
mbrN = mapGet(e, 'mbrNac')
mark = mbrN'@'time()
cf = mapExp(e, '${libPre}.SENDCF($mbrNac)')
sndIn = sendJob1(o, m.scp.rz, 'REC'what,
, 'job -ddJob' m.timeout'//??' cf mark ,
, 'receive' mapExp(e, '${libPre}.${what}DDL($mbrNac)') ,
, 'receive' mapExp(e, '${libPre}.${what}CAT($mbrNac)') )
call extractVersionStep o, 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, ty, what
scp = 'SCOPE'what
call mapPut e, 'what', ty || what
i = skelStem('ExVe')
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
if wordPos(m.sn.type, 'UDT UDF') > 0 then do
t = "SCH = '"m.sn.qual"', " ,
m.sn.type "= '"m.sn.name"';"
end
else do
t = "TYPE = '"m.sn.type"',"
if m.sn.type <> 'DB' then
t = t "QUAL = '"m.sn.qual"',"
t = t "NAME = '"m.sn.name"'"
if m.sn.type = 'SP' then
t = t", VERSION='%'"
t = t';'
end
if length(t) < 30 then do
call mAdd o, ' ' t
end
else do
cx = lastPos(',', t)
call mAdd o, ' ' left(t, cx),
, ' ' substr(t, cx+1)
end
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
/*--- create jcl to copy one member to rz toRz and library toLib -----*/
copyMbr: procedure expose m.
parse arg o, mbr, frLib, toRz, toLib
call mapPut e, 'mbr', mbr
call mapPut e, 'frLib', dsnSetMbr(frLib)
call mapPut e, 'toRz', toRz
call mapPut e, 'toLib', dsnSetMbr(toLib)
call addIf o
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIf o, 'end'
call setIf o, 'COPY', 0
return
endProcedure copyMbr
/*--- 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 mapPut e, 'step', step
call mapExpAll e, o, skelStem('SendJ')
do ax=4 to arg()
aa = arg(ax)
call debug 'sendJob1 le' length(aa) aa'|'
sx = 0
do forever
sy = sx
sx = pos(';', aa, sy+1)
if sx = 0 then
leave
call mAdd o, substr(aa,sy+1, sx-sy-1)
end
call mAdd o, substr(aa, sy+1) left('-', (ax < arg()))
end
call mAdd o, '//DDJOB DD *'
stReX = m.o.0+1
call mapPut e, 'jobName', 'Y'm.e.auf7
call mapPut e, 'fun', 'extract data from' toRz
call mapExpAll e, o, skelStem(m.jobCard)
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, skelStem('SendJ')
call mAdd o, 'mark' cfMark 'okRc0'
call mAdd o, '// ELSE'
call mapPut e, 'step', 'MARKERR'
call mapExpAll e, o, skelStem('SendJ')
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
if m.sysRz = m.scp.rz then
call sqlConnect m.scp.dbSy
else
call sqlConnect m.scp.rz'/'m.scp.dbSy
call queryDb2Catalog st, wh
m.v9.0 = 0
call queryDb2V9 st, 'V9'
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
unQueried = unQueried + 1
end
sel = 'select s.dbName db, s.name ts , s.type, ',
's.partitions, s.segSize, s.log, ',
't.creator cr, t.name tb,' ,
't.status tbSta, t.tableStatus tbTbSta',
'from sysibm.sysTableSpace S, sysibm.sysTables T'
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 sql2St substr(sql, 8), st
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.
trace ?r
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
return sql2st("select tp,nm,v9",
"from s100447.db2v9",
"where V9 <> '' and (" substr(wh, 5) ")",
"order by cr,tb,cl", vv)
endProcedure queryDb2V9
/*--- Qualitaets Pruefung fuer CatalogInfo Stem c --------------------*/
removeQualityCheck: 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.log <> 'Y' then
call mAdd o, n 'not logged'
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 removeQualityCheck
/*--- Qualitaets Pruefung mittels ddlCheck ---------------------------*/
qualityCheck: procedure expose m.
parse arg x, y
m.spezialFall.done = ''
lst = ''
scp = 'SCOPESRC'
o = 'AUFTRAG'
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then
f1 = 'db:'m.sn.name
else if m.sn.Type = 'TS' then
f1 = 'ts:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'TB' then
f1 = 't:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'VW' then
f1 = 'v:'m.sn.qual'.'m.sn.name
else if m.sn.Type = 'IX' then
f1 = 'i:'m.sn.qual'.'m.sn.name
else
iterate
f1 = space(f1, 0)
if wordPos(f1, lst) > 0 then
iterate
lst = lst f1
end
m.o.orig = 'rmQu' m.o.orig
if lst = '' then do
say 'qualitycheck no objects to check'
call mAdd o, '|| qualitycheck no objects to check'
return 0
end
qDsn = m.libPre'.QUALITY('mapGet(e, 'mbrNac')')'
cRes = ddlCheck('CHECK' qDsn x y lst)
call splitNl cr, cRes
cr1 = substr(m.cr.1, 4)','
if pos('\n', cRes) > 0 then
cr1 = left(cRes, pos('\n', cRes)-1)','
else
cr1 = cRes','
res = pos('q,', cr1) > 0 | pos('*sb,', cr1) > 0 ,
| pos('*p', cr1) > 0 | pos('*n,', cr1) > 0 ,
| pos('special', cr1) > 0 | pos('*-,', cr1) > 0
if \ res then do /* add new | lines to auftrag */
call mAdd o, '|| qualitycheck ok:' substr(m.cr.1, 4)
end
else do
call mAdd o, '|| qualitycheck:' substr(m.cr.1, 4)
call mAddSt o, cr, 2
end
return res
endProcedure qualityCheck
/*--- für jedes Objekt aus Source Scope Eintrage in der
Spezialfall Library suchen und falls vorhanden anzeigen --------*/
removeSspezialFall: procedure expose m. --> ddlCheck
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 removeSpezialFall
/*--- mask handling initialise ---------------------------------------*/
removemaskIni: 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 a whole scope --------------------------------------------*/
removemaskScope: procedure expose m.
parse arg mskDsn, fr, to
call maskRead masc, mskDsn
do fx=1 to m.fr.0
ty = m.fr.fx.type
m.to.fx.type = ty
if wordPos(ty, 'DB SG') > 0 then
m.to.fx.qual = ''
else if wordPos(ty, 'TS') > 0 then
m.to.fx.qual = maskTrans(masc, 'DBNAME', m.fr.fx.qual)
else
m.to.fx.qual = maskTrans(masc, 'SCHEMA', m.fr.fx.qual)
if wordPos(ty, 'DB') > 0 then
m.to.fx.name = maskTrans(masc, 'DBNAME', m.fr.fx.name)
else if wordPos(ty, 'TB VW AL') > 0 then
m.to.fx.name = maskTrans(masc, 'TBNAME', m.fr.fx.name)
else if wordPos(ty, 'SP') > 0 then
m.to.fx.name = maskTrans(masc, 'STPNAME', m.fr.fx.name)
else
m.to.fx.name = maskTrans(masc, ty'NAME', m.fr.fx.name)
end
m.to.0 = m.fr.0
return
endProcedure maskScope
/*--- mask test functions --------------------------------------------*/
removetestMask: 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
removeMaskTT: 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 -------------------*/
removemask2Prod: 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 --------------------------------*/
removemaskTrans: 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 ------------*/
removemaskRead: procedure expose m.
parse arg st, dsn
maskIgno = 'COMPRESS SEGSIZE DEFER DEFINE PRIQTY SECQTY'
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 --------------*/
removemaskHierarchy: 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 dbSy
subs2 = ''
rf = 1
isConn = 0
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)
if \ isConn & dbSy == '' then do
parse upper var li w1 w2 .
if wordpos(w1, 'SOURCE TARGET') > 0 then do
if length(w2) = 4 | ( length(w2) = 8 ,
& pos(substr(w2,4,1), './') > 0) then
subs2 = translate(w2, '/', '.')
end
end
iterate
end
if \ isConn then do
isConn = 1
if dbSy = '' then
dbSy = if(subs2 == '', m.pr1Sub, subs2)
dbSy = translate(dbSy, '/', '.')
if abbrev(dbSy, m.sysRz'/') then
dbSy = substr(dbSy, 5)
call sqlConnect dbSy
dbSy = translate(dbSy, m.ut.alfLC, m.ut.alfUC)
end
call expandScope mCut(qq, 0), ty, qu, nm
do qx=1 to m.qq.0
neu = m.qq.qx
if length(neu dbSy) < 70 then
neu = left(neu, 68 - length(dbSy)) '*'dbSy
else if length(neu dbSy) < 80 then
neu = neu '*'dbSy
liCm = if(qx=1, "line" rx, "line_after" (rx+qx-2))
if adrEdit(liCm "= (neu)", 4) = 4 then
say 'truncation line' rx':' neu
end
rx = rx + m.qq.0 - 1
rl = rl + m.qq.0 - 1
end
call sqlDisConnect
return 0
endProcedure queryScope
/*--- einen Scope Ausdruck expandieren -------------------------------*/
expandScope: procedure expose m.
parse arg o, ty, qu, nm
sql = ''
dec2s = "strip(case when abs(?) > 9223372036854775807",
"then char(real(?)) else char(bigint(?)) end)"
if ty = 'DB' then
sql = "select 'db', name, '' from sysibm.sysDatabase",
"where name" sqlClause(nm)
else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(name)," ,
"case when nTables <> 1",
"then 'ty=' || type" ,
"|| ', ' || nTables || ' tables||| '",
"else value( (select 'tb '" ,
"|| strip(t.creator) ||'.'|| strip(t.name)",
"|| case when t.type = 'T' then ''" ,
"else ' ty=' || t.type end" ,
"from sysibm.systables t" ,
"where t.type not in ('A','V')" ,
"and t.dbName=s.dbName and t.tsName=s.name" ,
"), 'not found')" ,
"end" ,
"from sysibm.systableSpace s" ,
"where dbName" sqlClause(qu) "and name" sqlClause(nm)
/*???else if ty = 'TS' then
sql = "select 'ts', strip(dbName) || '.' || strip(tsName)," ,
"case when count(*) = 1 then 'tb '" ,
"else strip(char(count(*))) || ' tables||| '",
"end" ,
"|| min(strip(creator) ||'.'|| strip(name))",
"|| case when count(*) = 1 and min(type) <> 'T'" ,
"then ' ty=' || min(type) else '' end" ,
"from sysibm.systables" ,
"where type not in ('A','V')" ,
"and dbName" sqlClause(qu),
"and tsName" sqlClause(nm),
"group by dbName, tsName" ???????????*/
else if ty = 'TB' | ty = 'VW' | ty = 'AL' then
sql = "select case type when 'V' then 'vw'",
"when 'A' then 'al' else 'tb' end," ,
"strip(creator) || '.' || strip(name)" ,
"|| case when type <> '"left(ty, 1)"'" ,
"then ' ty=' || type else '' end," ,
"case when type = 'A' then 'for '" ,
"|| strip(location) || '.'" ,
"|| strip(tbCreator)||'.'||strip(tbName)",
"else 'ts ' || strip(dbName) ||'.'",
"|| strip(tsName)",
"end",
"from sysibm.systables" ,
"where type" if(ty=='TB', "not in ('A', 'V')" ,
, "= '"left(ty, 1)"'"),
"and creator" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'IS' then
sql = "select 'is', strip(dbName) ||'.'|| strip(indexSpace),",
"'tb ' || strip(tbCreator)|| '.' || strip(tbName)" ,
" || ' ix ' || strip(name)" ,
'from sysibm.sysIndexes' ,
'where dbname' sqlClause(qu),
'and indexSpace' sqlClause(nm)
else if ty = 'IX' then
sql = "select 'ix', strip(creator) || '.' || strip(name),",
"'tb ' || strip(tbCreator)||'.'||strip(tbName)",
'from sysibm.sysIndexes' ,
'where creator' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDT' then
sql = "select 'udt', strip(schema) || '.' || strip(name),",
"'source ' || strip(sourceSchema)",
"|| '.' || strip(sourceType)",
"from sysibm.sysDataTypes",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'UDF' | ty = 'SP' then
sql = "select case when routineType = 'F' then 'udf'",
"when routineType = 'P' then 'sp'",
"else '?' || routineType end, ",
"strip(schema) || '.' || strip(name),",
"'otp=' || origin || function_type" ,
"|| strip(char(parm_count))",
"|| ' spec=' || strip(specificName)",
"|| ' a=' || active || ' vers=' || version",
"from sysibm.sysRoutines",
'where routineType =' quote(right(ty, 1), "'"),
'and schema' sqlClause(qu) ,
'and name' sqlClause(nm)
else if ty = 'TG' then
sql = "select 'tg', strip(schema) || '.' || strip(name),",
"'teg ' || trigTime || trigEvent||granularity",
"|| ' tb ' || strip(tbOwner) || '.'",
"|| strip(tbName)",
"from sysibm.sysTriggers",
'where schema' sqlClause(qu),
'and name' sqlClause(nm)
else if ty = 'SQ' then
sql = "select 'sq', strip(schema) || '.' || strip(name),",
"'start ' ||" repAll(dec2s, "?", "start"),
"|| ': ' ||" repAll(dec2s, "?", "minValue"),
"|| '-' ||" repAll(dec2s, "?", "maxValue"),
"|| ' inc ' ||" repAll(dec2s, "?", "increment"),
"from sysibm.sysSequences",
"where seqType='S' and schema" sqlClause(qu),
"and name" sqlClause(nm)
else if ty = 'SY' then
sql = "select 'sy', strip(creator) || '.' || strip(name),",
"'for ' || strip(tbCreator) || '.'" ,
"||strip(tbName)",
"from sysibm.sysSynonyms",
"where creator" sqlClause(qu),
"and name" sqlClause(nm)
else do
call mAdd o, ty left(qu'.'nm, 30) '* query nicht implementiert'
return
end
call sqlQuery 1, sql 'order by 2', 'FT FN FI'
do cx=0 by 1 while sqlFetch(1, d)
call mAdd o, lefA(m.d.ft, 3) lefA(m.d.fn, 30) m.d.fi
end
call sqlClose 1
if cx = 0 then
call mAdd o, lefA(ty, 3) lefA(strip(qu)left('.', qu \== '') ,
|| strip(nm), 30) '* nicht gefunden'
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 = m.e.auf7 || 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('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'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('m.e.auf7'Q)'
sIff = 'dsn.dba.'m.e.auf7'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
repAll: procedure expose m.
parse arg src, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
/**** ca *************************************************************/
/*--- extract ddl from source system ---------------------------------*/
caDDl: procedure expose m.
parse arg o, scp, GlbChg
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
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' m.timeout'//??' cf mark ,
, 'receive' oDsn)
call caDD1 o, scp, GlbChg, oDsn
call sendJob2 o, sndIn, cf mark
end
return
endProcedure caDDL
/*--- quickMigrate to create ddl -------------------------------------*/
caDD1: procedure expose m.
parse arg o, scp, GlbChg, ddlOut
call mapPut e, 'user', userid()
call mapPut e, 'ddlOut', ddlOut
call mapExpAll e, o, skelStem('CCOM')
call mapPut e, 'comm', mapExp(e, 'dbx $fun',
copies('recover', pos('.RDL(', ddlOut) > 0)'DDL' ,
'$AUFTRAG $NACHTRAG')
if abbrev(scp, '//') then
call mAdd o, scp, '// DD *'
else do sx=1 to m.scp.0
call rcmQuickAdd o, m.scp.sx.type, m.scp.sx.qual, m.scp.sx.name
end
call mapExpAll e, o, skelStem('CCO2')
call caGlbChg o, glbChg
return
endProcedure caDD1
caGlbChg: procedure expose m.
parse arg o, gCh
if gCh == '' then
return
upper gCh
if symbol('m.glbChg.gCh.0') \== 'VAR' then do
glblDsn = m.libPre".GlbChg("gCh")"
if sysDsn("'"glblDsn"'") \== 'OK' then
call err 'mask' gCh':' glblDsn sysDsn("'"glblDsn"'")
call readDsn glblDsn, 'M.GLBCHG.'gCh'.'
end
call mAddSt o, 'GLBCHG.'gCh
return
endProcedure caGlblChg
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/**** bmc ************************************************************/
/*--- src und trg profile erstellen ----------------------------------*/
bmcVars: procedure expose m.
m.e.profSrc = m.e.auftrag'_SRC'
m.e.profTrg = m.e.auftrag'_TRG'
m.e.profOwn = 'DBXAUFTR'
return
endProcedure bmcVars
bmcVarsProf: procedure expose m.
parse arg isImport
m.e.profChg = bmcMask2Prof(m.e.comMask)
if isImport then
m.e.profImp = bmcMask2Prof(m.e.impMask)
return
endProcedure bmcVarsProf
bmcMask2Prof: procedure expose m.
parse arg mask
m2 = translate(mapExp(e, mask))
return word(translate(m2, ' ', '.()'), 2)'.'dsnGetMbr(m2)
endProdecure bmcMask2Prof
/*--- src und trg profile erstellen ----------------------------------*/
bmcSrcTrg: procedure expose m.
parse arg oldSrc prof
if symbol('m.mask.hier') \== 'VAR' then
call maskHierarchy
if m.scopeSrc.rz \== m.sysRz | m.scopeTrg.rz \== m.sysRz then
call err 'bmc compare on other rz not implemented'
if m.scopeSrc.dbSy \== m.scopeTrg.dbSy then
call err 'bmc compare on different dbSystems not implemented'
call configureDbSy m.scopeSrc.rz, m.scopeSrc.dbSy
call bmcProfile m.e.profOwn, m.e.profSrc, 'SCOPESRC'
if m.optAuto then
call maskScope m.e.comMask, 'SCOPESRC', 'SCOPETRG'
call bmcProfile m.e.profOwn, m.e.profTrg, 'SCOPETRG'
return
endProcedure bmcSrcTrg
bmcProfile: procedure expose m.
parse arg ow, prof, scp
call sqlConnect m.scp.dbSy
call sqlExec "insert into bmcacma1.CM_BLPROFILE" ,
"(BLPOWNER, blpName, type, template)" ,
"values('"ow"', '"prof"', 'C', '"prof"####')", -803
call sqlExec "delete from bmcacma1.CM_SCOPE" ,
"where scOwner = '"ow"' and scName = '"prof"'", 100
do sx=1 to m.scp.0
sn = scp'.'sx
if m.sn.type = 'DB' then do
q1 = m.sn.name
q2 = ''
end
else do
q1 = m.sn.qual
q2 = m.sn.name
end
call sqlExec "insert into bmcacma1.CM_SCOPE" ,
"(SCOWNER, SCName, Type, ACTION,OBJECT,NAME_PART1,NAME_PART2",
",MIGDT, MIGTS, MIGTB, MIGCK, MIGFK, MIGIX, MIGVW, MIGAU",
",MIGSY, MIGAL, MIGRO, MIGTR, MIGUC, MIGAX",
")values('"ow"', '"prof"', 'B', 'I'" ,
", '"m.sn.type"', '"q1"', '"q2"'" ,
",'N' , 'Y', 'Y', 'Y', 'Y', 'Y', 'Y', 'N'",
",'Y' , 'Y', '', 'Y', 'Y', 'Y')"
end
call sqlCommit
return
endProcedure bmcProfile
zglSchub: procedure expose m.
parse arg fun rest
if length(fun) = 4 & datatype(fun, 'n') then
parse arg zgl fun rest
else
zgl = substr(date('s'), 3, 4)
only18 = fun == 18
if only18 then
parse var rest fun rest
if fun = '' then
call err 'zglSchub kein Fun fuer Auftraege:' arg(1)
call sqlConnect m.myDbSys
call sql2St "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
copies("and einfuehrungs_zeit = '18:00'", only18) , zsa
call sqlDisconnect
do zx=1 to m.zsa.0
if m.zsa.zx.workliste = '' then
iterate
say zx m.zsa.zx.workliste m.zsa.zx.auftrag ,
m.zsa.zx.einfuehrungs_zeit m.zsa.zx.id7
call work m.zsa.zx.workliste fun rest
end
endProcedure zglSchub
/*--- zStat Zuegelschub Statistik ------------------------------------*/
zstat a? yymm? - in rz4, create AyyMM mit AuftragsListe
----------------------------------------------------------------------*/
zStat: procedure expose m.
parse upper arg aArg
parse upper arg fun zgl
rz = sysvar('sysNode')
if fun = '' then
if rz = 'RZ4' then
fun = 'A'
else if rz = 'RZ2' | rz = 'RR2' | rz = 'RQ2' then
fun = 'S'
z0 = translate(zgl, '000000000', '123456789')
if zgl = '' then
z1 = substr(date('s'), 3, 4)
else if z0 == '0000' then
z1 = zgl
else if z0 == '000000' then
z1 = substr(zgl, 3)
else if z0 == '00.00.00' then
z1 = translate('5634', zgl, '12.34.56')
else
call err 'bad Zugelschub should be yymm or dd.nn.yy not' zgl
aDsn = m.libPre'.ZGL(ZSTA'z1')'
sDsn = m.libpre'.ZGL(ZSTS'z1')'
if fun = 'A' then do
if rz <> 'RZ4' then
call err 'zstat a... only in rz4'
if sysDsn("'"aDsn"'") == 'OK' then
call err "e}"aDsn "existiert schon"
call zStatAuftragsListe z1, m.libPre'.auftrag', aDsn
end
else if fun == 'S' then do
if rz <> 'RZ2' & rz <> 'RR2' & rz <> 'RQ2' & rz <> 'RZ4' then
call err 'zstat s... only in rz2 or rz4'
if sysDsn("'"aDsn"'") \== 'OK' then
call err aDsn "existiert nicht"
call zStatsStatistik z1, aDsn, sDsn
end
else
call err 'i}bad fun' fun 'in arguments zStat' aArg
return 0
endProcedure zStat
zStatAuftragsListe: procedure expose m.
parse arg zgl, lib, outDsn
zg2 = '20'zgl
zg3 = translate('.34.12', zgl, '1234')
zg4 = translate('.cd.20ab', zgl, 'abcd')
call sqlConnect m.myDbSys
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
/* copy ii end ********* Installation Info *************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
m.m.0 = mx
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
m.m.0 = mbr_name.0
end
return mx
endProcedure mbrList
/*--- return wheter a dsn exists ------------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
----------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse arg fr, to, mbrs
if mbrs \== '' then do
if dsnGetMbr(fr) \== '' | dsnGetMbr(to) \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if words(mbrs) == 1 then do
parse value strip(mbrs) with old '>' new
if old = '' then
call err 'bad mbr old/new' mbrs
fr = dsnSetMbr(fr, old)
to = dsnSetMbr(to, word(new old, 1))
mbrs = ''
end
end
/* currently we do everything with csm
if the need arises, implement tso only version */
return csmCopy(fr, to, mbrs)
endProcedure dsnCopy
dsnDelete: procedure expose m.
parse arg aDsn
parse value dsnCsmSys(aDsn) with sys '/' dsn
if sys \== '*' then
return csmDel(sys, dsn)
if adrTso("delete '"dsn"'", 8) == 0 then
return 0
if pos('IDC3330I **' dsnGetMbr(dsn)' ', m.tso_trap) >= 1 then
say 'member not found and not deleted:' dsn
else if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then
say 'dsn not found and not deleted:' dsn
else
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDelete
/* copy dsnList end ************************************************/
/* copy match begin ***************************************************/
/*--- 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
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse upper arg rz, dsn
if dsnGetMbr(dsn) == '' then do
if adrCsm("allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)", 8) == 0 then do
call adrTso 'free dd(del1)'
return 0
end
if pos('CSMSV29E DATA SET' dsn 'NOT IN CAT', m.tso_trap) > 0,
then do
say 'dsn not found and not deleted:' rz'/'dsn
return 4
end
end
else do
if adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8) == 0 then
return 0
if pos('CSMEX77E Member:'dsnGetMbr(dsn) 'not f', m.tso_trap) ,
> 0 then do
say 'member not found and not deleted:' rz'/'dsn
return 4
end
end
return err('csmDel rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(fr) \== ''
toMbr = dsnGetMbr(to) \== ''
call csmAlloc fr, frDD, 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
/*??if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr) ???????? */
call csmAlloc to, toDD, 'shr', , ':D'frDD
/* if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end ?????????????? */
inDD = tsoDD('csmIn*', 'a')
i.0 = 0
if mbrs \== '' then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
else if \ frMbr & m.tso_dsOrg.frDD == 'PO' then do
call adrCsm "mbrList ddName("frDD") index(' ') short"
i.0 = mbr_mem#
do ix=1 to i.0
i.ix = ' S M='mbr_name.ix
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", "*"
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do /* copy output to stem */
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead return sqlRdrRead(m)")
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead return sqlRdrRead(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
return sqlsOut(scanSqlStmtRdr(sqlSrc, opt), retOk, 'a')
endProcedure sqlStmts
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrRead: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrRead
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then
return err('??? old interface') / 0
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
m.m.bufI0 = m.m.bufI0 + m.m.buf.0
m.m.readIx = 0
interpret objMet(m, 'jRead')
ix = 1
if m.m.buf.0 < ix then
return err('jRead but no lines') / 0
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
interpret objMet(m, 'jWrite')
return
endProcedure jWrite
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.bufMax = 0
return m
endProcedure jReset
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
call jReset0 m, arg, arg2, arg3
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
/*--- text for a method, for buffer of size 1 only ------------------*/
jWrite1Met: procedure expose m.
parse arg f1
return "jWrite if m.m.buf.0\==1 then call err 'bad jWrite1Met';" ,
"var = m'.BUF.1'; m.m.buf.0 = 0;" f1
/*--- text for a method, for buffer
jWriteBMet: procedure expose m.
parse arg f1, fe
return "jWrite" ,
copies("do wx=1 to m.m.buf.0;" ,
"var = m'.BUF.'wx;" f1"; end;", f1 <> '') ,
copies("vBu = m'.BUF';" fe";", fe <> ''),
"m.m.bufI0 = m.m.bufI0 + m.m.buf.0; m.m.buf.0 = 0"
------------------*/
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "new return 'm = jReset0('classMet(cl, 'new2')');'" ,
"classMet(cl, 'jReset')'; return m'" )
/* "new ?r m = jReset0(?new2); ?jReset; return m" */
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
cDe= classNew('n JRWDelegLazy u LazyRoot', 'm',
, "new return 'return jReset('classMet(cl, 'new1')', arg)'" )
/* , "new ?r return jReset(?new1, arg)", */
c2 = classNew('n JRWDeleg u JRW', 'm',
, "METHODLAZY" cDe,
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, jWrite1Met(" say o2Text(m.var, 157)"),
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose" ,
, "jRead return 0",
, "jWrite call err 'buf overflow",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
call classNew "n JbufText u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = word(arg 80, 1)",
, "jWrite call jBufWrite m, o2Text(line, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jBufText: write text descriptions -----------------------------*/
jbufText: procedure expose m.
m = oNew('JbufText') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = o2text(arg(ax))
end
m.m.buf.0 = ax-1
return m
endProcedure jbufText
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
m.m.bufMax = 1e30
if opt == m.j.cWri then do
m.m.buf.0 = 0
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
m.m.buf.0 = ax
return m
endProcedure jBufWriteStem
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.s2c., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj ---------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
r = m'=['
do fx=1 to m.cl.flds.0 while length(r) <= maxL
f1 = m.cl.flds.fx
c1 = m.cl.f2c.f1
if c1 = m.class_V then
op = '='
else if m.c1 == 'r' then
op = '=>'
else
op = '=?'c1'?'
r = r || left(' ', fx > 1) || m.cl.flds.fx || op
if m.cl.flds.fx == '' then
r = r || strip(m.m)
else
r = r || strip(mGet(m'.'m.cl.flds.fx))
end
if length(r) < maxL then
return r']'
else
return left(r, maxL-3)'...'
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, met
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
return 'return o2TextFlds(m, '''cl''', maxL)'
endProcedure o2TextGen
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = ']'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "o2Text return o2textGen(cl)",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "scanSqlIn2Scan return" ,
"'return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'",
, "new return 'return' classMet(cl, 'new2')",
, "new1 call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'oMutate(mNew('''cl'''), '''cl''')'" ,
, "new2 call classMet cl, 'oClear';" ,
"return 'classClear('''cl''','" ,
"classMet(cl, 'new1')')'" ,
, "oClear return classClearGen(cl)" ,
, "oCopy return oCopyGen(cl)")
laStr = classNew('n LazyString u LazyRoot', 'm',
, "scanSqlIn2Scan return 'if wOpt == '''' then wOpt = 0;" ,
"return scanSqlReset(s,'" ,
"classMetRmRet(cl, 'in2File')', wOpt, sOpt)'")
/* 'o2Text ?r return m"=[?:]"' */
m.class_S = classNew('n String u', 'm',
, 'METHODLAZY' laStr,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, 'o2String return m')
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
laRun = classNew('n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=['className(cl)']'''")
/* 'o2Text ?r return m"=[?:]"' */
call classNew 'n ORun u', 'm',
, 'METHODLAZY' laRun ,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively -------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldGen: procedure expose m.
parse arg cl
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
classClearGen: procedure expose m.
parse arg cl
call classMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
dProcedure classClearGen
/* copy class end ***************************************************/
/* copy map begin ******************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
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 = mapAdr(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 mapAdr(a, ky, 'g') \== ''
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 = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address ---*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* 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.ut_alfDot, '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>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a --------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a -------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem -------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem ------------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem -----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
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 tsoOpen grp, 'R'
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 tsoClose 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 out 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 out 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 m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
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 lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- 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 */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD 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, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
dd = tsoDD(dd, 'a')
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
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)'
call tsoFree word(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)'
call tsoFree word(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
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- 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
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/ 6