zOs/REXX/DBXEXE
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.1
19. 1.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. 1.2016 Walter support sequence
*/ /* end of help
19.11.2015 Walter remote edit, anaPre .......
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 0 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')
end
else do
ow = 'S100447'
cChgs = 'PROT'if(abbrev(auftName, 'XB'), 'DVBP', 'DBOF')
iChgs = 'DBOF$impNm'
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 DD1 DD2 EXE' ,
'JCL QUALITY QUICK REC RE1 RDL '
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
d = '* .JCL' m.e.auftrag
else if llq == 'QUALITY' | (LLQ =='DDL' ,
& a2 =='' & length(a1) <=1) then do
d = '* .'word('DDL QUALITY', pos(wh, 'DQ')) m.e.auf7 ,
|| left(a1 || m.e.nachtrag, 1)
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
if llq == 'DDI' then
llq = 'DDL'
d = r2 d2'.'llq m.e.auf7 || n2
end
parse var d rz dsn mbr
eFun = word('Edit View', 1 + (fun \== 'E'))
if wh = 'Q' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wh == 'A' | wh == 'R' then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"m.libPre || dsn"("mbr")')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"m.libPre || dsn"')",
"member("mbr")" mac, 4
return
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'
ddlIx = 2 - (iChgs \== '')
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib||ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddBB
end
call addIf o'.TWO'
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly == '') ,
copies('keepTgt0', m.e.keepTgt == 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
call mapPut e, 'ddlIn', ddlAA
ddlImp = ddlLib'L('nact')'
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'
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')
call addIf o'.TWO', 'end'
call setIf o'.TWO', 'ANA', 0 4, 'POST'
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.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'
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.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', ,
, classNew('n* SQL u f FT v, f FN v, f FI v')
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 SQ' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V SQ' , 'EXPLODE ROUTINE'
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'
call rcmQuickTyp1 'SEQUENCE ', 'SQ Q'
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 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 rTy ., t aa
m.rcm_quickT2DB2.t = dTy
if rTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = rTy
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 *************************/
/* 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
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 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 = c2d(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
/* copy csi end ******************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, retOk
if dsnGetMbr(csnTo) \= '' & dsnGetMbr(csnTo) \= '' then do
if dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
csnTo = dsnSetMbr(csnTo)
end
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysTo = '*' then do
old = sysDsn("'"dsnTo"'")
end
else if sysFr = '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
mv = 'UNITCNT(30)' /* 3.10.13 wieder zurueck */
say 'creating' dsn 'with multi volume' mv
end
else if rc \= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call tsoFree word(alRes, 2)
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
csmRc = adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'",
c , retOk)
if sysTo = '*' & old <> 'OK' then do
/* csm normally does not set mgmtclass - avoid delete | */
call adrTso "ALTER '"dsnTo"' mgmtclas(COM#A091)"
end
return csmRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if disp = 'NEW' & nn \== '' then
a2 = a2 dsnCreateAtts( , nn, 1)
if retRc <> '' | nn = '' then
return adrCsm('allocate' al a2 rest, retRc)
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return 0
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/*--- 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'
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
timeout = 77
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
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w'
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) timeout("timeout")"
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')",
"timeout("timeOut")", '*'
if rc <> 0 | appc_rc <> 0 then do
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
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
/*--- 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
/* 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
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
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
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
call sqlIni
m.sqlO.ini = 1
call jIni
m.sqlO.cursors = left('', 200)
call classNew 'n SqlResultRdr u JRWO', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlResultRdrOpen m, opt",
, "jClose call sqlClose m.m.cursor",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlDRS u SqlSel', 'm',
, "jReset m.m.loc = arg; m.m.type = arg2;",
, "jOpen call sqlDRSOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelReadO(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, retOk, resTy)",
, "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, retOk,resTy)",
, "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, retOk, resTy)",
, "sqlFetch return sqlCsmFetch(cx, dst)",
, "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, retOk,resTy)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
return 0
endProcedure sqlOini
/*--- connect and/or disconnect to DB2 -------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlOIni
if pos('/', sys) > 0 then do
parse value space(sys, 0) with hst '/' sys
cTy = 'Csm'
end
else do
hst = ''
cTy = 'Rx'
end
if m.sql.conType==cTy & m.sqlHost==hst & m.sqlconDbSYs == sys then
return 0
if m.sql.conType \== '' then
call sqlDisconnect
res = 0
if cTy = 'Rx' then
res = sqlRxConnect(sys, retOk)
else
m.sql.conDbSys = sys
if res < 0 then
return res
m.sql.conType = cTy
m.sql.conhost = hst
m.sql.connection = oNew('Sql'cTy'Connection')
return res
endProcedure sqlConnect
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql.conType == 'Rx' then
call sqlRxDisconnect
m.sql.conType = ''
m.sql.conDbSys = ''
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, retOk, resTy
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlQuery')
else
interpret objMet(cx, 'sqlQuery')
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlFetch')
else
interpret objMet(cx, 'sqlFetch')
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
if datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlClose')
else
interpret objMet(cx, 'sqlClose')
return 0
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlUpdate')
else
interpret objMet(cx, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
if cx == '' | datatype(cx, 'n') then
interpret objMet(m.sql.connection, 'sqlCall')
else
interpret objMet(cx, 'sqlCall')
endProcedure sqlCall
sqlSel: procedure expose m.
parse arg src, type
s = oNew('SqlSel', inp2str(src, '-sql'), type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- 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
sqlStmtsOpt: procedure expose m.
parse arg src, opts
upper opts
sub = ''
o = ''
retOk = ''
do wx=1 to words(opts)
w = word(opts, wx)
if abbrev(w, '-SQL') then
o = o'-sql'substr(w, 5)
else if w == '-O' | w == 'O' then
o = o'-o'
else if w = '*' | datatype(w, 'n') then
retOk = retOk w
else if length(w) == 4 then
sub = w
else
call err 'bad opt' w 'in opts' opts 'not -sql? -o or subsys'
end
call sqlOIni
if (sub == '' & m.sql.conDbSys== '') ,
| (sub \== '' & m.sql.conDbSys \== sub) then
call sqlConnect sub
return sqlStmts(src, strip(retOk), strip(o))
endProcedure sqlStmtsOpt
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fmtFTab
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
dlm = ';'
isStr = oStrOrObj(sqlSrc, m.j.in)
fLen = ''
if pos('sql', opt) > 0 then
fLen = word(substr(opt, pos('sql', opt)+3), 1)
if isStr then do
m.sqlStmts.rdr = ''
call scanSrc sqlStmts, ggStr
end
else do
fi = jOpen(o2File(ggObj), '<')
call jCatSqlReset sqlStmts, , fi, fLen
end
do forever
s1 = jCatSqlNext(sqlStmts, dlm)
if s1 = '' then
leave
if translate(left(s1, 10)) == 'TERMINATOR' then do
dlm = strip(substr(s1, 11))
if length(dlm) \== 1 then
call scanErr sqlStmts, 'bad terminator' dlm
iterate
end
call outSt(splitNl(sqlTmp, sqlStmt(s1, retOk, opt)))
end
if \ isStr then
call jClose fi
return 0
endProcedure sqlStmts
sqlStmt: procedure expose m.
parse arg src, retOk, opt
cx = sqlGetCursor()
r1 = sqlExecute(cx, src, retOK)
res = m.sql.sqlHaHi || sqlMsgLine(r1, m.sql.cx.updateCount, src)
if m.sql.cx.resultSet \== '' then do
rdr = sqlResultRdr(cx)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fmtFTab sqlStmtFmt, rdr
res = sqlMsgLine(m.rdr.rowCount 'rows fetched', , src)
end
call sqlFreeCursor cx
return res
endProcedure sqlStmt
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk, opt
src = inp2Str(src)
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then
return sqlMsgLine( , upds, src, coms 'commits')
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
removeSqlStmt: procedure expose m.
parse arg src, ggRet, opt
bx = verify(src, '( ')
if bx < 1 then
return ''
fun = translate(word(substr(src, bx), 1))
w2 = translate(word(substr(src, bx), 2))
res = ''
if fun == 'SELECT' | fun = 'WITH' then do
s = oNew('SqlSel', inp2str(src, '%S%+Q\s'))
if pos('o', opt) > 0 then
call pipeWriteAll s
else
call fmtFTab sqlStmtFmt, s
res = m.s.rowCount 'rows fetched'
end
else if fun = 'SET' & abbrev(w2, ':') then do
ex = pos('=', w2)
if ex > 2 then
var = strip(substr(w2, 2, ex-2))
else
var = strip(substr(w2, 2))
if var = '' then
var = 'varUnbekannt'
call sqlExec src, ggRet
res = 'sqlCode' sqlCode var'='value(var)
end
else if fun = 'SET' | (fun = 'DECLARE' & w2 = 'GLOBAL') then do
call sqlExImm src, ggRet
res = 'sqlCode' sqlCode
end
else if fun = 'CALL' then do
res = sqlStmtCall(src, ggRet, opt)
end
else do
call sqlExec src, ggRet
res = 'sqlCode' sqlCode
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 THEN
res = res',' sqlErrd.3 'rows' ut2Lc(fun)'d'
end
aa = strip(src)
ll = 75 - length(res)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
return res':' aa
endProcedure removeSqlStmt
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSrc(scanSqlReset(sqlstmtcall, ,0), 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 fmtFTab 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 assNN('A', jReadO(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
sqlResultRdr: procedure expose m.
parse arg cx, type
return oNew('SqlResultRdr', cx, type)
endProcedure sqlRdr
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlSel', inp2str(src, '%S%qn %S'), type)
endProcedure sqlRdr
sqlResultRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlResultRdrOpen('m',' opt')'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlResultRdrOpen
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
m.m.cursor = sqlGetCursor()
call sqlQuery m.m.cursor, m.m.src, ,m.m.type /* ????? */
return sqlResultRdrOpen(m, opt)
endProcedure sqlOpen
/*--- dynamic result sets --------------------------------------------*/
sqlDRS: procedure expose m.
parse arg loc, type
return oNew('SqlDRS', loc, type)
endProcedure sqlDRS
sqlDRSOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlDRSOpen('m',' opt')'
crs = sqlGetCursor('a')
crN = 'C'crs
m.m.cursor = crs
call sqlReset crs
call sqlexec 'allocate C'crs 'cursor for result set :m.m.loc'
call sqlExec 'describe cursor c'crs 'into :m.sql.'crs'.D'
m.m.jReading = 1
m.m.rowCount = 0
return m
endProcedure sqlDRSOpen
/*--- create the type, fetch vars etc. from the sqlDA ---------------*/
sqlFetchClass: procedure expose m.
parse arg cx
if m.sql.cx.type = '' then do
ff = mCat('SQL.'cx'.COL', '%qn v, f %s')
m.sql.cx.type = classNew('n* SQL u f' ff 'v')
end
return m.sql.cx.type
endProcedure sqlFetchClass
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelReadO: procedure expose m.
parse arg m
cx = m.m.cursor
v = oNew(sqlFetchClass(cx))
if \ sqlFetch(cx, v) then
return ''
m.m.rowCount = m.m.rowCount + 1
return v
endProcedure sqlSelReadO
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlSelClose
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm an handle sqlCode ---------------------------*/
sqlCsmExe:
parse arg cx, ggSqlStmt, ggRetOk
sql_HOST = m.sql.conHost
SQL_DB2SSID = m.sql.conDbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
call 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\nstmt =' 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, retOk, resTy, src
res = sqlCsmExe(cx, sqlSrc, 100 retOk)
if res < 0 then
return res
if src == '' then
src = 'SQL.'cx'.DATA'
m.sql.cx.data = src
f = ''
if resTy \== '' then do
f = oClaMet(class4Name(resTy), 'oFlds')
if m.f.0 < sqlD then
call err 'not enough fields in type'
end
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = sqlVarName(f, kx, sqlDa_name.kx)
m.sql.cx.col.kx = cn
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.src.rx.cn = m.sqlNull
else
m.src.rx.cn = value(rxNa'.'rx)
end
end
m.src.0 = sqlRow#
m.sql.cx.col.0 = sqlD
m.sql.cx.daIx = 0
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = m.sql.cx.data
rx = m.sql.cx.daIx + 1
if rx > m.sql.cx.data.0 then
return 0
m.sql.cx.daIx = rx
do kx = 1 to m.sql.cx.col.0
c = m.sql.cx.col.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 -----------------------------------------------*/
sqlIni: procedure expose m.
if m.sql.ini == 1 then
return
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql.defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql.ini = 1
m.sql.conType = ''
m.sql.conDbSys = ''
m.sql.conhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2 RZ4') > 0
m.sqlRetOK = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlIni
/*--- 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
nop
else if sysvar(sysnode) == 'RZ1' then
sys = 'DBAF'
/* else if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
*/ else
call err 'no default subsys for' sysvar(sysnode)
m.sql.conDbSys = sys
ggSqlStmt = 'connect' sys
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
ggSqlStmt = 'disconnect'
m.sql.conDbSys = ''
address dsnRexx ggSqlStmt
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlDisconnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, retOk, resTy
res = sqlPrepare(cx, src, retOk, 1)
if res < 0 then
return res
if resTy \== '' then
m.sql.cx.type = class4Name(resTy)
res = sqlExec('declare c'cx 'cursor for s'cx, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
call sqlRxFetchVars cx
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- 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' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
call sqlSetNull cx, dst
return 1
endProcedure sqlRxFetch
/*--- return csv header line -----------------------------------------*/
sqlHeaderCSV: procedure expose m.
parse arg cx
x = sqlRxFetchVars(cx)
return mCatFT('SQL.'cx'.COL', 1, m.sql.cx.d.sqlD, '%qn,%s')
endProcedure sqlHeaderCSV
/*--- fetch next row return it as csv line, return '' at end ---------*/
sqlFetchCSV: procedure expose m.
parse arg cx, retOk
dst = 'sql.csvFetch'
fetCode = sqlExec('fetch c'cx 'into' sqlRxFetchVars(cx), 100 retOk)
if fetCode == 100 then
return ''
if fetCode < 0 then
return fetCode
res = ''
do kx=1 to m.sql.cx.d.sqlD
cn = m.sql.cx.col.kx
val = m.dst.cn
if m.sql.cx.d.kx.sqlType // 2 = 1 & m.dst.col.sqlInd < 0 then
res = res','m.sqlNull
else if pos(',', val) > 0 | pos('"', val) > 0 then
res = res','quote(val, '"')
else
res = res','val
end
return substr(res, 2)
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 sqlExImm(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 sqlExImm(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
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
src = inp2Str(src, '-sql')
f = translate(word(substr(src, max(verify(src, '( '), 1)), 1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' 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
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, retOk, type
cx = m.sql.defCurs
res = sqlQuery(cx, src, retOk, type)
if res >= 0 then do
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
end
m.dst.0 = res
call sqlRxClose cx
return res
endProcedure sql2St
/*-- execute a query and return value of the first column
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst
cx = m.sql.defCurs
call sqlQuery cx, src
if \ sqlFetch(cx, dst) then
if arg() > 2 then
return arg(3)
else
call err 'no row returned for:' src
if sqlFetch(cx, dst.2) then
call err '2 or more rows for' src
c1 = m.sql.cx.col.1
res = m.dst.c1
call sqlRxClose cx
return res
endProcedure sql2One
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.needDesc = 1
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.type = ''
m.sql.cx.col.0 = ''
m.sql.cx.into = ''
return
endProcedue sqlReset
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, retOk, descOut
src = inp2str(src, '%qn%s ')
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlReset cx
return sqlExec('prepare s'cx s 'from :src', retOk)
endProcedure sqlPrepare
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx us
if us == '' then do
if arg() <= 1 then
return sqlExec('open c'cx)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
end
return sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I')
endProcedure sqlOpen
/*--- execute a prepared statement with arg(2), arg(3)... ------------*/
sqlExePreSt: procedure expose m.
parse arg cx retOk
if arg() <= 1 then
return sqlExec('execute s'cx, retOk)
call sqlDescribeInput cx
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
return sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
endProcedure sqlExePreSt
/*--- describe output (if not already done)
and return size of sqlDa ------------------------------------*/
sqlDescribeOutput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.d.sqlD, 'n') then
call sqlExec 'describe s'cx 'into :M.SQL.'cx'.D', 0
return m.sql.cx.d.sqlD
endProcedure sqlDescribeOutput
/*--- describe input (if not already done)
and return size of input sqlDA ------------------------------*/
sqlDescribeInput: procedure expose m.
parse arg cx, force
if force == 1 | \ datatype(m.sql.cx.i.sqlD, 'n') then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
return m.sql.cx.i.sqlD
endProcedure sqlDescribeInput
/*--- 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
/*--- put sqlNull in all vars where indicator says so ---------------*/
sqlSetNull: procedure expose m.
parse arg cx, dst
do nx=1 to m.sql.cx.sqlNull.0
col = m.sql.cx.sqlNull.nx
if m.dst.col.sqlInd < 0 then
m.dst.col = m.sqlNull
end
return
endProcedure sqlSetNull
/*--- use describe output to generate column names,
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx
if m.sql.cx.fetchVars \== '' then
return m.sql.cx.fetchVars
call sqlDescribeOutput cx
f = m.sql.cx.type
if f \== '' then do
f = oClaMet(f, 'oFlds')
if m.f.0 < m.sql.cx.d.sqlD then
call err 'not enough column names'
end
m.sql.cx.col.0 = m.sql.cx.d.sqlD
nx = 0
vars = ''
do kx=1 to m.sql.cx.d.sqlD
cn = sqlVarName(f, kx, m.sql.cx.d.kx.sqlName)
m.sql.cx.col.kx = cn
m.sql.cx.col2kx.cn = kx
vars = vars', :m.dst.'cn
if m.sql.cx.d.kx.sqlType // 2 = 1 then do
vars = vars' :m.dst.'cn'.sqlInd'
nx = nx + 1
m.sql.cx.sqlNull.nx = cn
end
end
m.sql.cx.sqlNull.0 = nx
m.sql.cx.fetchVars = substr(vars, 3)
return m.sql.cx.fetchVars
endProcedure sqlRxFetchVars
sqlCol2kx: procedure expose m.
parse arg cx, nm
call sqlRxFetchVars cx
if symbol('M.SQL.CX.COL2KX.NM') \== 'VAR' then
return ''
kx = m.sql.cx.col2kx.nm
if m.sql.cx.col.kx == nm then
return kx
drop m.sql.cx.col.kx
return ''
endProcedure sqlCol2kx
sqlVarName: procedure expose m. sqlVarName.
parse arg f, kx, sNa
if f == '' then do
cx = verifId(sNa)
if cx > 0 then /* avoid bad characters for classNew| */
sNa = left(sNa, cx-1)
upper sNa
if sNa == '' | symbol('sqlVarName.sNa') == 'VAR' then
sNa = 'COL'kx
sqlVarName.sNa = 1
return sNa
end
else do
if m.f.kx == '' then
call err 'implement empty varName'
return substr(m.f.kx, 2)
end
endProcedure sqlVarName
/*--- 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
sqlExImm:
parse arg ggSrc, ggRetOk
return sqlExec('execute immediate :ggSrc', ggRetOk)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRetOk
m.sql.sqlHaHi = ''
address dsnRexx 'execSql' ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
interpret sqlErrorHandler(rc, ggRetOk, ggSqlStmt)
endProcedure sqlExec
sqlErrorHandler: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg drC, retOk, verb rest
if drC == 0 then
return 'return 0'
if wordPos(drC, '1 -1') < 0 then
return "call err 'dsnRexx rc" drC"' sqlmsg()"
if pos('-', retOK) < 1 then
retOK = retOk m.sqlRetOk
if pos('*', retOK) > 0 | wordPos(sqlCode, retOK) > 0 then do
if sqlCode < 0 & pos('say', retOK) > 0 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
else
return "return" sqlCode
end
upper verb
if verb == 'DROP' then do
if sqlCode == -204 & wordPos('dne', retok) > 0 then
return 'return' sqlCode
if sqlCode = -672 & verb=='DROP' ,
& wordPos('rod', retok) > 1 then do
hahi = m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, 'tb='sqlErrMc ,verb rest)'\n'
call sqlExec 'alter table' SqlErrMc ,
'drop restrict on drop'
hahi = hahi || m.sql.sqlHaHi ,
|| sqlMsgLine(sqlCode, , ggSqlStmt)'\n'
call sqlExec verb rest
m.sql.sqlHaHi = hahi
return 'return' sqlCode
end
end
if drC < 0 then
return "call err sqlmsg(); return" sqlCode
if (sqlCode <> 0 | sqlWarn.0 ^==' ') & pos('w',retOK) < 1 then
return "call outSt errMsg(' }'sqlMsg()); return" sqlCode
return 'return' sqlCode
endProcedure sqlErrorHandler
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()'\n'sqlCaMsg(sqlCa2Rx(sqlCa))
end
ggSt = 'SQL.HOST'
ggVa = 'SQL.HOST.VAR'
ggBe = 'SQL.HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggVV = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggVV = sqlHostVarFind(ggSt, 1)
else
ggVV = ''
if ggVV == '' then
ggRes = ggRes || sqlMsgSrcPos(ggSqlStmt, sqlErrd.5)
else
ggRes = ggRes || sqlMsgSrcPos(value(ggVV), sqlErrd.5)
end
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000, sqlErrd.5)
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' value(m.ggVa.ggXX)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql.conHost \== '') then
ggRes = ggRes'\nsubsys =' m.sql.conDbSys ,
|| ', host =' m.sql.conHost', interfaceType' m.sql.conType
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
/*--- 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
/*--- 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
/*--- 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 = 0
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut.alfRexN1) > 0 then
iterate
ex = verify(src, m.ut.alfRex, 'n', cx)
sx = sx + 1
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 = ''
end
m.st.0 = sx
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, var
met = objMet(m, 'jRead')
if m.m.jReading then
interpret met
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface'
met = objMet(m, 'jReadO')
if m.m.jReading then
interpret met
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
met = objMet(m, 'jWrite')
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret met
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
met = objMet(m, 'jWriteO')
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret met
return
endProcedure jWriteO
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, line)
call jWrite m, m.line
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while assNN('li', jReadO(rdr))
call jWriteO m, li
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: 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
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
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
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
return jCatSql(m, substr(fmt, 5))
else
fmt = '%s%qn %s%qe%q^'fmt
call jOpen m, m.j.cRead
if \ jRead(m, line) then do
call jClose m
return ''
end
res = f(fmt, m.line)
do while jRead(m, line)
res = res || f(fmt'%Qn', m.line)
end
call jClose m
return res || f(fmt'%Qe')
endProcedure jCatLines
/*--- cat the line of a file, using comments
fixline (with token wrapping) or separate lines -------*/
jCatSql: procedure expose m.
parse arg m, fLen
call jCatSqlReset m'.JCATSQL', , jOpen(m, '<'), fLen
res = jCatSqlNext(m'.JCATSQL')
call jClose m
return res
endProcedure jCatSql
jCatSqlReset: procedure expose m.
parse arg m, aSrc, m.m.rdr, m.m.fLen
call jCatSqlNL m, aSrc
return m
endProcedure jCatSqlReset
jCatSqlNL: procedure expose m.
parse arg m
if m.m.rdr \== '' then
if jRead(m.m.rdr, m'.SRC') then do
if m.m.fLen \== '' then
m.m.src = left(m.m.src, m.m.fLen)
else if m.m.src == '' then
m.m.src = ' '
else if substr(m.m.src, length(m.m.src), 1) \== ' ' then
m.m.src = m.m.src' '
m.m.pos = 1
return 1
end
m.m.pos = length(m.m.src)+1
return 0
endProcedure jCatSqlNl
jCatSqlNext: procedure expose m.
parse arg m, stop
sta = 'tt'
res = ''
do forever
do while scanSBEnd(m)
if \ jCatSqlNl(m) then
return strip(res)
end
bx = m.m.pos
sta = scanSql2Stop(m, sta, stop)
s1 = left(sta, 1)
if pos(s1, stop) > 0 then do
if res <> '' then
return strip(res)
end
else if s1 == '-' | s1 == '/' then
res = res' '
else if pos('/', sta) = 0 then
res = res || substr(m.m.src, bx, m.m.pos - bx)
end
/*-------- ?????????????????????
jCatSqlNext?: procedure expose m.
parse arg m, stop
res = ''
bx = m.m.pos
do forever
call scanUntil m, '"''-/'stop
if scanSBEnd(m) then do
res = res || substr(m.m.src, bx)
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '--' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
bx = 0
end
else if substr(m.m.src, m.m.pos, 2) = '/*' then do
res = res || substr(m.m.src, bx, m.m.pos-bx)' '
do forever
px = pos('*/', m.m.src, m.m.pos)
if px > 0 then
leave
if \ jCatSqlNL(m) then
return res
end
bx = px+2
m.m.pos = bx
end
else if scanLit(m, "'", '"') then do
c1 = m.m.tok
do while \ scanStrEnd(m, c1)
res = res || substr(m.m.src, bx)
if m.m.fLen \== '' then
if jCatSqlNl(m) then do
bx = m.m.pos
iterate
end
call err 'unclosed' c1 'string:' m.m.src
end
end
else if pos(substr(m.m.src, m.m.pos, 1), stop) > 0 then do
res = strip(res||substr(m.m.src, bx, m.m.pos-bx), 't')
call scanChar m, 1
if res <> '' then
return strip(res)
bx = m.m.pos
end
else if \ scanLit(m, '-', '/') then do
call err 'bad char at' substr(m.m.src, m.m.pos) 'in' m.m.src
end
if bx = 0 then
if jCatSqlNl(m) then
bx = m.m.pos
else
return strip(res)
end
endProcedure jCatSqlNext
??????????????*/
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"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new return jReset("m.class.basicNew", arg, arg2, arg3)",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, 'J.GGVAR') then return '';",
"return s2o(m.j.ggVar)" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
m.class.forceDown.c1 = c1'#new'
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new return jReset("m.class.basicNew", arg)",
, "jRead return jRead(m.m.deleg, var)" ,
, "jReadO return jReadO(m.m.deleg)" ,
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteO call jWrite(m.m.deleg, var)" ,
, "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" )
m.class.forceDown.c2 = c2'#new'
call classNew 'n JRWO u JRW', 'm',
, "jRead res = jReadO(m); if res == '' then return 0;" ,
"m.var = o2string(res); return 1" ,
, "jReadO" am "jReadO('m')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
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',
, "jWrite say line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JStem u JSay', 'm',
, "jReset m.m.stem = arg;",
"if \ dataType(m.arg.0, 'n') then m.arg.0 = 0" ,
, "jWrite call mAdd m.m.stem, line"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m',' var') but not opened r')"
m.j.errReadO = "return err('jReadO('m',' var') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
m.j.errWriteO= "return err('jWriteO('m',' var') but not opened w')"
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose call oMutatName m, 'JBuf'",
, "jReset call jBufReset m, arg",
, "jRead" m.j.errRead ,
, "jReadO" m.j.errReadO ,
, "jWrite" m.j.errWrite ,
, "jWriteO" m.j.errWriteO
call classNew "n JBufOR u JBuf", "m",
, "jRead return jBufORead(m, var)",
, "jReadO return jBufOReadO(m)"
call classNew "n JBufSR u JBuf", "m",
, "jRead return jBufSRead(m, var)",
, "jReadO return jBufSReadO(m)"
call classNew "n JBufOW u JBuf", "m",
, "jWrite call jBufOWrite m, line",
, "jWriteO call jBufOWriteO m, var"
call classNew "n JBufSW u JBuf", "m",
, "jWrite call jBufSWrite m, line",
, "jWriteO call jBufSWriteO m, var"
call classNew "n JBufTxt u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = 80",
, "jWriteO call jBufWrite m, o2Text(var, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
j2Rdr: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
else
return o2file(ggObj)
endProcedure j2Rdr
/* jstr is part of out interface --> inp2str */
inp2str: procedure expose m.
parse arg rdr, fmt
if oStrOrObj(rdr, m.j.in) then
return ggStr
else
return o2String(ggObj, fmt)
endProcedure inp2str
j2Buf: procedure expose m.
parse arg rdr
if oStrOrObj(rdr, m.j.in) then
return jBuf(ggStr)
if oClaInheritsOf(ggCla, 'JBuf') & m.ggObj.jUsers < 1 then
return ggObj
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, o2File(ggObj)
return jClose(b)
endProcedure j2Buf
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedure in
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadO(m.j.in)
endProcedure in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.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
m.m.allS = 1
return m
endProcedure jBuf
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBufTxt: procedure expose m.
m = oNew('JBufTxt') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufTxt
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allS = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
if m.m.allS then
call oMutatName m, 'JBufSR'
else
call oMutatName m, 'JBufOR'
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allS = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
if m.m.allS then
call oMutatName m, 'JBufSW'
else
call oMutatName m, 'JBufOW'
return m
endProcedure jBufOpen
jBufOWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', s2o(line)
return
endProcedure jBufOWrite
jBufSWrite: procedure expose m.
parse arg m, line
call mAdd m'.BUF', line
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allS then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufOWriteO: procedure expose m.
parse arg m, ref
call mAdd m'.BUF', ref
return
endProcedure jBufOWriteO
jBufSWriteO: procedure expose m.
parse arg m, ref
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl == m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
do ax=1 to m.m.buf.0
m.m.buf.ax = s2o(m.m.buf.ax)
end
m.m.allS = 0
call oMutatName m, 'JBufOW'
call mAdd m'.BUF', ref
return
endProcedure jBufWriteO
jBufOReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return m.m.buf.nx
endProcedure jBufOReadO
jBufSReadO: procedure expose m.
parse arg m
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return ''
m.m.readIx = nx
return s2o(m.m.buf.nx)
endProcedure jBufSReadO
jBufORead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufORead
jBufSRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
m.var = m.m.buf.nx
return 1
endProcedure jBufRead
jBufTxtWriteO: procedure expose m.
parse arg m, ref
if m.m.allS \== 1 then
call err '1 \== allS' m.m.allS 'in jBufTxtWriteO('m',' ref')'
cl = objClass(ref, '?')
if cl = m.class.classV then
call mAdd m'.BUF', m.ref
else if cl == m.class.classW then
call mAdd m'.BUF', substr(ref, 2)
else if ref == '' then
call mAdd m'.BUF', '@ null object'
else if cl == '?' then
call mAdd m'.BUF', '@'ref 'class=???'
else do
l = '@'ref 'class='className(cl)
ff = oFlds(ref)
do fx=1 to m.ff.0 while length(l) < m.m.maxl + 3
if m.ff.fx == '' then
l = l', .='m.ref
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.ref.f1
end
end
if length(l) > m.m.maxl then
l = left(l, m.m.maxl-3)'...'
call mAdd m'.BUF', l
end
return
endProcedure jBufTxtWriteO
/* 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
if the parent is class OLazyMet, a methof found there is
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o.ini == 1 then
return
m.o.ini = 1
call mIni
m.o.escW = ']'
m.o.lazyGen = 'OLazyMetGen' /* lazy method generator */
call oAddCla m.o.lazyGen
return
endProcedure oIni
/*--- return whether cl is a currently defined class ----------------*/
oIsCla: procedure expose m.
parse arg cl
return symbol('m.o.cParent.cl') == 'VAR'
endProcedure oIsCla
/*--- add class cl with the given parents ---------------------------*/
oAddCla: procedure expose m.
parse arg cl, parents
if verifId(cl, '.') > 0 | pos('.', cl) <> lastPos('.', cl) then
call err 'bad class name' cl 'in oAddCla('cl',' parents')'
if oIsCla(cl) then
call err 'duplicate class' cl 'in oAddCla('cl',' parents')'
do px=1 to words(parents)
if \ oIsCla(word(parents, px)) then
call err word(parents, px) 'is no class' ,
'in oAddCla('cl',' parents')'
end
m.o.cParent.cl = parents
return
endProcedure oAddCla
/*--- add to class cl method met ------------------------------------*/
oAddMet: procedure expose m.
parse arg cl, met, cont
if \ oIsCla(cl) then
call err 'undefined class' cl 'in oAddMet('cl',' met',' cont')'
if symbol('m.o.cMet.cl.met') == 'VAR' then
call err 'duplicate method' met 'in oAddMet('cl',' met',' cont')'
m.o.cMet.cl.met = cont
return
endProcedure oAddMet
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
interpret oClaMet(cl, 'new')
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o.escW) then
return m.class.classW
else if arg() >= 2 then
return arg(2)
else
return err('no class found for object' m)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return oClaInheritsOf(cl, sup)
endProcedure oKindOf
oClaInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if symbol('m.o.cParent.cl') \== 'VAR' then
cl = class4name(cl)
if symbol('m.o.cParent.sup') \== 'VAR' then
sup = class4name(sup)
if cl == sup then
return 1
do sx=1 to words(m.o.cParent.cl)
if oClaInheritsOf(word(m.o.cParent.cl, sx), sup) then
return 1
end
return 0
endProcedure oClaInheritsOf
/*--- return the code of method me of object m
set m to the address and ggClass to the class ---------------*/
objMet: procedure expose m. m ggClass
parse arg m, me
if symbol('m.o.o2c.m') == 'VAR' then
ggClass = m.o.o2c.m
else if abbrev(m, m.o.escW) then
ggClass = "w"
else if arg() >= 3 then
return arg(3)
else
return err('no class found for object' m)
if symbol('m.o.cMet.ggClass.me') == 'VAR' then
return m.o.cMet.ggClass.me
code = oClaMet(ggClass, me, '---')
if code \== '---' then
return code
else if arg() >= 3 then
return arg(3)
return err('no method' me 'in class' className(ggClass) ,
'of object' m)
endProcedure objMet
oClaMet: procedure expose m.
parse arg cl, me
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
if \ oIsCla(cl) then do
c2 = class4Name(cl, '')
if c2 \== '' & oIsCla(c2) then do
cl = c2
if symbol('m.o.cMet.cl.me') == 'VAR' then
return m.o.cMet.cl.me
end
else do
if arg() >= 3 then
return arg(3)
else
return err('no class' cl 'in oClaMet('cl',' me')')
end
end
code = oLazyMetGen(m.o.lazyGen, cl, me)
do px = 1 to words(m.o.cParent.cl) while code == '---'
code = oClaMet(word(m.o.cParent.cl, px), me, '---')
end
if code == '---' then do
if arg() >= 3 then
return arg(3)
else
return err('no met' me 'in class' cl)
end
m.o.cMet.cl.me = code
return code
endProcedure oClaMet
oLazyMetGen: procedure expose m.
parse arg lg, cl, me
if symbol('m.o.cMet.lg.me') \== 'VAR' then
return '---'
interpret m.o.cMet.lg.me
endProcedure oLazyMetGen
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
/*--- return the contents of field f navigation along path ----*/
oGet: procedure expose m.
parse arg obj, path, clazz
nullNew = 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccStr(m, cl)
if ret == 1 then
return str
return err(ret 'in oGet('obj',' path')')
endProcedure oGet
oAccStr: procedure expose m. str
parse arg m, cl
if cl == m.class.classV then
str = m.m
else if m.cl.valueCl == '' then
return 'no value @' m 'class' className(cl)
else if m.m == '' then
return 'null @' m 'class' className(cl)
else if abbrev(m, m.o.escW) then
str = substr(m ,2)
else
str = o2String(m.m)
return 1
endProcedure oAccStr
oGetO: procedure expose m.
parse arg obj, path, opt, clazz
nullNew = pos('n', opt) > 0
ret = oAccPath(obj, path, clazz)
if ret == 1 then
ret = oAccO(m, cl, opt)
if ret == 1 then
return ref
else
return err(ret 'in oGetO('obj',' path')')
endProcedure oGetO
oAccO: procedure expose m. ref
parse arg m, cl, opt
if cl == m.class.classV then do
ref = s2o(m.m)
end
else if m.cl \== 'r' then do
ref = m
end
else if m.m == '' then do
if opt == '-b' then do
m.m = jBuf()
end
else if opt == '-n' then do
rsn = oRefSetNew(m, cl)
if rsn \==1 then
return rsn
end
ref = m.m
end
else if objClass(m.m, 0) \== 0 then do
ref = m.m
end
else do
return 'no class for' m.m '@' m 'class' cl
end
return 1
endProcedure oAccO
oPut: procedure expose m.
parse arg obj, path, str
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPut(m, cl, str)
if res == 1 then
return str
return err(res 'in oPut('obj',' path',' str')')
endProcedure oPut
ocPut: procedure expose m.
parse arg m, cl, str
if m.cl.valueCl == m.class.classV then
m.m = str
else if m.cl.valueCl \== '' then
m.m = s2o(str)
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPut
oPutO: procedure expose m.
parse arg obj, path, ref
nullNew = 1
res = oAccPath(obj, path)
if res == 1 then
res = ocPutO(m, cl, ref)
if res == 1 then
return ref
return err(ret 'in oPut('obj',' path',' ref')')
endProcedure oPutO
ocPutO: procedure expose m.
parse arg m, cl, ref
if m.cl.valueCl == m.class.classV then
m.m = o2string(ref)
else if m.cl.valueCl \== '' then
m.m = ref
else if m.cl.stemCl \== '' then
return 'implement put to stem'
else
return 'no value @' m 'class' className(cl)
return 1
endProcedure ocPutO
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
oClaClear: procedure expose m.
parse arg cla, m
interpret "drop cla;" oClaMet(cla, 'oClear')
return m
endProcedure oClaClear
oAccPath: procedure expose m. m cl nullNew
parse arg m, pa, cl
if cl == '' & m \== '' then do
cl = objClass(m)
end
if pa == '' then
return 1
call oClaMet cl, 'oFlds'
if abbrev(pa, m.class.cRef) ,
| (\ m.cl.hasFlds & abbrev(pa, m.class.cNav)) then do
if pa == m.class.cRef & m.cl.valueCl == m.class.classV then do
cl = m.class.classV
return 1
end
if (m.cl.valueCl == '' | m.cl.valueCl == m.class.classV) ,
& m.cl \== 'r' then
return 'no reference @' m 'class' cl
if m.m = '' then do
if \ nullNew then
return 'null @' m 'class' className(cl)
rsn = oRefSetNew(m, cl)
if rsn \== 1 then
return rsn
end
return oAccPath(m.m, substr(pa, 2))
end
if pos(left(pa, 1), m.class.cPath) > 0 then
return oAccPath(m, substr(pa, 2), cl)
px = verify(pa, m.class.cPath, 'm')
if px < 1 then
px = length(pa)+1
fn = left(pa, px-1)
pa = substr(pa, px)
if symbol('m.cl.f2c.fn') == 'VAR' then
return oAccPath(m'.'fn, pa, m.cl.f2c.fn)
if m.cl.stemCl=='' | fn=='' | verify(fn, '0123456789','n')>0 then
return 'no field' fn '@' m 'class' className(cl)
if fn == 0 then
return oAccPath(m'.0', pa, m.class.classV)
if abbrev(fn, 0) | verify(m.m.0, '0123456789', 'n') > 0,
| fn > m.m.0 then
return 'bad stem index' fn'>'m.m.0 '@' m 'class' className(cl)
return oAccPath(m'.'fn, pa, m.cl.stemCl)
endProcedure oAccPath
oRefSetNew: procedure expose m.
parse arg m, cl
cr = m.cl.valueCl
if m.cr.class = '' then
return 'no class for null @' m 'class' className(cl)
if m.cr.class = m.class.classW then
m.m = o2s()
else if m.cr \== 'r' then
return 'class' className(cl) 'not ref'
else
m.m = oNew(m.cr.class)
return 1
endProcedure oRefSetNew
/*--- 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
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" oClaMet(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
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
if arg() >= 1 then
r = oNew(classNew('n* ORun u ORun, m oRun' arg(1)))
else
r = oNew(classNew('n| ORun u ORun'))
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- 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 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 opt == '' then
opt = '-b '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return true if object is kind of String------------------------*/
oStrOrObj: procedure expose m. ggStr ggObj ggCla
parse arg ggObj, def
if ggObj == '' then
ggObj = def
ggCla = objClass(ggObj, '')
if ggCla == '' then do
ggStr = ggObj
ggObj = ''
return 1
end
else if wordPos(ggCla, m.class.classV m.class.classW) > 0 then do
ggStr = o2String(ggObj)
ggObj = ''
return 1
end
else do
ggStr = ''
return 0
end
endProcedure oStrOrObj
/*--- return true if object is kind of String ----- ???? -------------*/
oStrOrFile: procedure expose m. ggStr ggObj ggCla
parse arg m, def
if oStrOrObj(m, def) then
return 1
ggObj = o2File(ggObj)
return 0
endProcedure oStrOrFile
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL
if m == '' then
return '@ null object'
if maxL == '' then
maxL = 80
cl = objClass(m, '?')
if cl = m.class.classV then
l = m.m
else if cl == m.class.classW then
l = substr(m, 2)
else if cl == '?' then
l = '@'m 'class=???'
else do
l = '@'m 'class='className(cl)
ff = oFlds(m)
do fx=1 to m.ff.0 while length(l) < maxL + 3
if m.ff.fx == '' then
l = l', .='m.m
else do
f1 = substr(m.ff.fx, 2)
l = l',' f1'='m.m.f1
end
end
end
if length(l) <= maxL then
return l
return left(l, maxL-3)'...'
endProcedure o2Text
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o.escW || str
return r
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m, '')
if cl = '' then
return m
else if cl = m.class.classV then
return = m.m
else if cl == m.class.classW 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' (ce (',' ce)*)?
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.class.in2 = 0
call oIni
call mapIni
call mNewArea 'CLASS', 'CLASS'
call mapReset 'CLASS.N2C' /* name to class */
m.class.classV = classBasicNew('u', 'v')
m.class.classW = classBasicNew('u', 'w')
m.class.classO = classBasicNew('u', 'o')
m.class.class = classNew('n class u v',
, 'c u u f NAME v, s r class',
, 'c f u f NAME v, f CLASS r class',
, 'c s f CLASS r class' ,
, 'c c u f NAME v, f CLASS r class',
, 'c m u f NAME v, f MET v' ,
, 'c r f CLASS r class' )
m.class.cNav = '.'
m.class.cRef = '|'
m.class.cDot = '%'
m.class.cPath = m.class.cNav || m.class.cRef || m.class.cDot
m.class.classR = classNew('r')
m.class.basicNew = "oMutate(mNew(cl), cl)"
call oAddMet m.o.lazyGen, 'new', "return classGenNew(cl, me)"
call oAddMet m.o.lazyGen,'oClear',"return classGenClear(cl, me)"
call oAddMet m.o.lazyGen,'oFlds',"return classGenFlds(cl, me)"
call oAddMet m.o.lazyGen, 'oCopy', "return classGenCopy(cl, me)"
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr))
call classFinish cr
call oClaMet cr, 'oFlds' /* generate flds */
end
m.class.in2 = 1
call oAddMet m.class.classV, 'oCopy', "return oCopyV(m, t)"
call classAddMet m.class.classV, 'o2String return m.m'
call classAddMet m.class.classW, 'o2String return substr(m, 2)'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return oRun2File(m)',
, 'm o2String return jCatLines(oRun2File(m), fmt)'
return
endProcedure classIni
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'u' & m.cl.name \= '' then
return m.cl.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
classBasicNew: procedure expose m.
parse arg ty, nm, cl, nmTy
n = mNew('CLASS')
m.n = ty
m.n.name = nm
m.n.nameComp = nm
if ty == 'u' & nm \== '' then do
if pos(nmTy, '*|') > 0 then do
m.n.name = nm || substr(n, 1+lastPos('.', n))
if nmTy == '*' then
m.n.nameComp = nm'*'
else
m.n.nameComp = m.n.name
end
call mapAdd class.n2c, m.n.name, n
end
call mapAdd class.n2c, n, n
m.n.class = ''
m.n.met = ''
m.n.0 = 0
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classBasicNew('ty',' nm',' cl')'
else if nm == '' & pos(ty, 'fm') > 0 then
call err 'empty name: classBasicNew('ty',' nm',' cl')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classBasicNew('ty',' nm',' cl')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classBasicNew('ty',' nm',' cl')'
else if pos(ty, 'fcrs') > 0 then do
if cl \== '' then
m.n.class = mapGet(class.n2c, cl)
else if ty == 'r' then
m.n.class = m.class.classO
/* else say 'cl leer' ty nm nmTy ???????*/
end
else if ty == 'm' then
m.n.met = cl
else if cl \== '' then
call err 'class for type' ty': classBasicNew('ty',' nm',' cl')'
return n
endProcedure classBasicNew
classNew: procedure expose m.
parse arg clEx 1 ty rest
if abbrev(ty, 'n') then do
if wordPos(ty, 'n n? n* n|') < 1 then
call err 'bad type' ty': classNew('clEx')'
nmTy = right(ty, 1)
parse var rest nm ty rest
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == 'n' then do
if mapHasKey(class.n2c, nm) then
call err 'class' nm 'already defined: classNew('clEx')'
end
else if nmTy == '?' then do
if mapHasKey(class.n2c, nm) then
return mapGet(class.n2c, nm)
end
else if nmTy == '*' then do
if arg() \== 1 then
call err 'arg()='arg() 'for n* : classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
end
n = classBasicNew('u', nm, , nmTy)
end
else do
nmTy = ''
if arg() \== 1 then
call err 'arg()='arg() 'without name: classNew('clEx')'
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
call err 'bad type' ty': classNew('clEx')'
nm = ''
if pos(ty, 'usr') < 1 then
parse var rest nm rest
if ty = 'u' then do
n = classBasicNew(ty)
end
else if ty = 'm' then do
n = classBasicNew(ty, nm, rest)
rest = ''
end
else do
parse var rest t1 rest
if wordPos(t1, 'u f s c m r') > 0 then do
n = classBasicNew(ty, nm)
m.n.class = classNew(t1 rest)
rest = ''
end
else do
n = classBasicNew(ty, nm, t1)
end
end
end
if ty \== 'u' then do
if rest \== '' then
call err 'rest' rest 'but end of classExp expected:' clEx
end
else do
lx = 0
do while lx < length(rest)
cx = pos(',', rest, lx+1)
if cx <= lx | word(substr(rest, lx+1), 1) == 'm' then
cx = length(rest)+1
a = mAdd(n, classNew(strip(substr(rest, lx+1, cx-lx-1))))
lx=cx
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
call mAdd n, classNew(pref || arg(ax))
end
end
cr = mIterBegin('CLASS')
do while assNN('cr', mIter(cr)) & \ classEqual(n, cr)
end
isNew = cr == n
if \ isNew then do
if mapRemove(class.n2c, n) \== n then
call err 'mapRemove('n') mismatch'
if m.n == 'u' & m.n.name \== '' then
if mapRemove(class.n2c, m.n.name) \== n then
call err 'mapRemove('m.n.name') mismatch'
call mFree n
n = cr
end
if isNew & m.class.in2 then
call classFinish n
if nmTy == '' | nmTy == '*' then
call mapAdd class.n2c, clEx, n
return n
endProcedure classNew
/*--- to the finish for new class cl -------------------------------*/
classFinish: procedure expose m.
parse arg cl, force
call oMutate cl, m.class.class
/* find super and sub classes */
m.cl.sub = ''
sups = ''
do ux=1 to m.cl.0
u1 = m.cl.ux
if m.u1 \== 'u' then
iterate
if wordPos(u1, sups) > 0 then
call err u1 'already in sups' sups': classSuperSub('cl')'
sups = sups u1
if wordPos(m.cl.SUB, cl) > 0 | symbol('m.u1.sub') \== 'VAR' then
call err cl 'is already in' u1'.sub' u1.SUB ,
|| ': classSuperSub('cl')'
m.u1.sub = strip(m.u1.sub cl)
end
m.cl.super = sups
/* add class to o */
call oAddCla cl, sups
if pos(m.cl, 'mfrsv') < 1 then do
allMets = ''
forceMets = ''
do cx=1 to m.cl.0
ch = m.cl.cx
if m.ch == 'm' then do
call oAddMet cl, m.ch.name, m.ch.met
allMets = allMets m.ch.name
end
else if symbol('m.class.forceDown.ch') == 'VAR' then
forceMets = forceMets m.class.forceDown.ch
end
myForce = ''
do fx=1 to words(forceMets)
parse value word(forceMets, fx) with fCla '#' fMet
if wordPos(fMet, allMets) < 1 then do
call oAddMet cl, fMet, m.o.cMet.fCla.fMet
myForce = myForce cl'#'fMet
allMets = allMets fMet
end
end
if myForce \== '' then
m.class.forceDown.cl = strip(myForce)
end
if cl == m.class.class then
call mAlias 'CLASS', cl
else /* object addresses */
call mNewArea cl, 'O.'substr(cl,7)
if m.cl \== 'u' | m.cl.name == '' then
return
call mAlias cl, m.cl.name
return
endProcedure classFinish
classAddMet: procedure expose m.
parse arg clNm, met code
cl = class4Name(clNm)
if pos(m.cl, 'uvw') < 1 then
call err 'class not nvw but' m.cl,
'in classAdd1Method('clNm',' met code')'
call mAdd cl, classNew('m' met code)
call oAddMet cl, met, code
return cl
endProcedure classAddMet
/*--- return true iff the two classes are equal -------------------*/
classEqual: procedure expose m.
parse arg l, r
if m.l \== m.r | m.l.nameComp \== m.r.nameComp ,
| m.l.class \== m.r.class | m.l.0 \== m.r.0 then
return 0
if m.l.met \== m.r.met then
return 0
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
classGenNew: procedure expose m.
parse arg cl, met
return "m=" m.class.basicNew";" oClaMet(cl, 'oClear') ";" ,
"return m"
endProcedure classGenNew
classGenFlds: procedure expose m.
parse arg cl, met
m.cl.flds.0 = 0
m.cl.stms.0 = 0
m.cl.stemCl = ''
m.cl.valueCl = ''
call classGenFldsAdd cl, cl
m.cl.hasFlds = m.cl.flds.0 > 1 ,
| (m.cl.flds.0 == 1 & m.cl.flds.1 \== '') | m.cl.stms.0 > 0
return cl'.FLDS'
endProcedure classGenFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classGenFldsAdd: procedure expose m.
parse arg f, cl, nm
n1 = substr(nm, 1+abbrev(nm, '.') )
if symbol('m.f.f2c.n1') \== 'VAR' then
m.f.f2c.n1 = cl
if cl == m.class.classV | cl == m.class.classW | m.cl=='r' then do
if nm == '' then do
if m.f.valueCl \== '' then
return err('value mistmatch')
m.f.valueCl = cl
end
if nm == '' then do
call mMove f'.FLDS', 1, 2
m.f.flds.1 = ''
end
else do
call mAdd f'.FLDS', nm
end
return 0
end
if m.cl = 's' then do
if m.cl.class == '' then
call err 'stem null class'
a1 = mAdd(f'.STMS', nm)
m.a1.class = m.cl.class
if nm == '' then
m.f.stemCl = m.cl.class
return 0
end
if m.cl = 'f' then
return classGenFldsAdd(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return classGenFldsAdd(f, m.cl.class, nm)
do tx=1 to m.cl.0
call classGenFldsAdd f, m.cl.tx, nm
end
return 0
endProcedure classGenFldsAdd
classGenClear: procedure expose m.
parse arg cl, met
r = ''
call oClaMet cl, 'oFlds'
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
if f1 == '' then
c1 = cl
else do
c1 = substr(f1, 2)
c1 = m.cl.f2c.c1
end
if c1 == m.class.classW then
r = r classGenStmt(f1, "m.m~ = '"m.o.escW"';")
else
r = r classGenStmt(f1, "m.m~ = '';")
end
do sx=1 to m.cl.stms.0
r = r classGenStmt(m.cl.stms.sx, "m.m~.0 = 0;")
end
return r
endProcedure classGenClear
classGenStmt: procedure expose m.
parse arg f, st, resWo
isNice = translate(f) == f
resWo = translate(resWo) 'GGFF M'
fDod = '.'f'.'
do wx=1 to words(resWo) while isNice
isNice = pos('.'word(resWo, wx)'.', fDot) < 1
end
if isNice then
return repAll(st, '~', f)
else
return "ggFF = '"substr(f, 2)"';" repAll(st, '~', '.ggFF')
endProceduer classGenAss
classGenCopy: procedure expose m.
parse arg cl, me
r = repAll("if t == '' then t =" m.class.basicNew ";" ,
"else call oMutate t, cl;", 'cl', "'"cl"'")
ff = oClaMet(cl, 'oFlds') /* build code for copy */
do fx=1 to m.cl.flds.0
r = r classGenStmt(m.cl.flds.fx, 'm.t~ = m.m~;', 't')
end
do fx=1 to m.cl.stms.0
nm = m.cl.stms.fx
sc = m.cl.stms.fx.class
if nm == '' then
st = ''
else do
r = r "st = '"substr(nm, 2)"';"
st = '.st'
end
r = r "m.t"st".0 = m.m"st".0;" ,
"do sx=1 to m.m"st".0;" ,
"call oClaCopy '"sc"', m"st".sx, t"st".sx; end;"
end
return r 'return t;'
endProcedure classGenCopy
/*--- oCopy for classW ----------------------------------------------*/
oCopyW: procedure expose m.
trace ?r
parse arg m, t
if t == '' then
return m
m.t = o2String(m)
return oMutate(t, m.class.classV)
endProcedure oCopyW
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively output (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- 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 out(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class.classO then do
if a == '' then
return out(p1'obj null')
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class.classV then
return out(p1'=' m.a)
if t == m.class.classW == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return out(p1'refTo :'className(m.t.class) '@null@')
else
return classOutDone(m.t.class, 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.classV
call out 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 out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, 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.class, 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
/* 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 = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
if m.map.keys.a \== '' then
call mAdd m.map.Keys.a, ky
m.res = ''
return res
endProcedure mapValAdr
/* copy map end *******************************************************/
/* copy 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>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
m.m.area.0 = m.m.area.0 + 1
a = 'M.AREA.'m.m.area.0
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'m.m.area.0
if symbol('m.m.n2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m.n2a.adr = a
call mAlias adr, nm
m.m.p2a.adr = a
m.a.0 = 0
m.a.free.0 = 0
m.a.address = adr
return nm
endProcedure mNewArea
mAlias: procedure expose m.
parse arg oldNa, newNa
if symbol('m.m.n2a.oldNa') \== 'VAR' then
call err 'area' oldNa 'does not exist'
if oldNa == newNa then
return
if symbol('m.m.n2a.newNa') == 'VAR' then
call err 'newName' newNa 'for old' oldNa 'already used'
m.m.n2a.newNa = m.m.n2a.oldNa
return
endProcedure mAlias
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m.n2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
ggArea = m.m.n2a.name
if m.ggArea.free.0 > 0 then do
fx = m.ggArea.free.0
m.ggArea.free.0 = fx-1
m = m.ggArea.free.fx
end
else do
m.ggArea.0 = m.ggArea.0 + 1
m = m.ggArea.address'.'m.ggArea.0
end
return m
endProcedure mNew
mFree: procedure expose m.
parse arg m
p = 'M.P2A.'left(m, lastPos('.', m)-1)
area = m.p
fx = m.area.free.0 + 1
m.area.free.0 = fx
m.area.free.fx = m
return
endProcedure mFree
/*--- iterate over all allocate elements of an area ------------------*/
mIterBegin: procedure expose m.
parse arg nm
a = m.m.n2a.nm
return m.a.address'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
p = 'M.P2A.'left(cur, lx-1)
a = m.p
ix = substr(cur, lx+1)
do ix=ix+1 to m.a.0
n = m.a.address'.'ix
do fx=1 to m.a.free.0 while m.a.free \== n
end
if fx > m.a.free.0 then
return n
end
return ''
endProcedure mIter
/*--- 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
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
/*--- 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, possibly repeated --------------------------
args: stem, fmt see fGen: -------------------------------------*/
mCat: procedure expose m.
parse arg st, fmt
return mCatFT(st, 1, m.st.0, fmt)
mCatFT: procedure expose m.
parse arg st, fx, tx, fmt
if tx < fx then
return ''
fmt = '%s%qn%s%qe%q^'fmt
res = f(fmt, m.st.fx)
do sx=fx+1 to tx
res = res || f(fmt'%Qn', m.st.sx)
end
return res || f(fmt'%Qe')
endProcedure mCatFT
mIni: procedure expose m.
if m.m.ini == 1 then
return
m.m.ini = 1
call utIni
m.mBase64 = m.ut.alfUC || m.ut.alfLc || m.ut.digits'+-'
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 ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: 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 tsoDD(dd, 'o') '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskW' 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
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')'
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 readDDNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
m.m.cx = m.m.cx + 1
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
m.m.buf0x = m.m.buf0x + m.m.0
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt)then
return ''
m.m.cx = 1
return m'.1'
endProcedure readDDNx
/*--- return the 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
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' readNxLiNo(m)li
endProcedure readnxPos
readNxLiNo: procedure expose m.
parse arg m
return m.m.buf0x + m.m.cx
endProcedure readnxLiNo
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readDDNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ datatype(res, 'n') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, 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 arg dd, f
if symbol('m.tso.ddAlloc') \== 'VAR' then do
call errIni
m.tso.ddAlloc = ''
m.tso.ddOpen = ''
end
if m.err.ispf then
address ispExec 'vget wshTsoDD shared'
else
wshTsoDD = m.tso.ddAlloc
if f == '-' then do
ax = wordPos(dd, m.tso.ddAlloc)
if ax > 0 then
m.tso.ddAlloc = delWord(m.tso.ddAlloc, ax, 1)
ox = wordPos(dd, m.tso.ddOpen)
if ox > 0 then
m.tso.ddOpen = delWord(m.tso.ddOpen , ox, 1)
if ax < 1 & ox < 1 then
call err 'tsoDD dd' dd 'not used' m.tso.ddAlloc m.tso.ddOpen
sx = wordPos(dd, wshTsoDD)
if sx > 0 then
wshTsoDD = delWord(wshTsoDD , sx, 1)
end
else if f == 'o' then do
if wordPos(dd, m.tso.ddOpen m.tso.ddAlloc) < 1 then
m.tso.ddOpen = strip(m.tso.ddOpen dd)
end
else if f <> 'a' then do
call err 'tsoDD bad fun' f
end
else do
if right(dd, 1) = '*' then do
dd = left(dd, length(dd)-1) || m.err.screen
cx = lastPos(' 'dd, ' 'm.tso.ddAlloc)
if cx > 0 then do
old = word(substr(m.tso.ddAlloc, cx), 1)
if old = dd then
dd = dd'1'
else if datatype(substr(old, length(dd)+1), 'n') then
dd = dd || (substr(old, length(dd)+1) + 1)
else
call err 'tsoDD old' old 'suffix not numeric dd' dd
end
end
if wordPos(dd, m.tso.ddAlloc) < 1 then
m.tso.ddAlloc = strip(m.tso.ddAlloc dd)
if wordPos(dd, wshTsoDD) < 1 then
wshTsoDD = strip(wshTsoDD dd)
end
if m.err.ispf then
address ispExec 'vPut wshTsoDD shared'
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
else if disp = 'NEW' and nn \== '' then
c = c dsnCreateAtts(,nn)
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then
return 0
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
say 'rc='alRc 'for' c rest
call saySt adrTsoal
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoAtts: procedure expose m.
parse arg dsn
rc = listDsi("'"dsn"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = 'CAT'
al = ''
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("translate('1 2 3', ' 'sysREcFM, ' 123')")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoAtts
tsoFree: procedure expose m.
parse arg ddList, ggRet
do dx=1 to words(ddList)
dd = word(ddList, dx)
call adrTso 'free dd('dd')', ggRet
call tsoDD dd, '-'
end
return
endProcedure tsoFree
tsoFreeAll: procedure expose m.
all = m.tso.ddAlloc m.tso.ddOpen
do ax = 1 to words(all)
call adrTso 'execio 0 diskW' word(all, ax) '(finis)', '*'
end
m.tso.ddOpen = ''
call tsoFree m.tso.ddAlloc, '*'
return
endProcedure tsoFreeAll
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
forCsm = forCsm == 1
aU = ' 'translate(atts)
res = ''
if dsn \== '' then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, '~') then
return res tsoAtts(substr(atts, 2))
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
recfm='f b'
end
else do
if rl = '' then
rl = 32756
recfm = substr(a1, 2, 1) 'b'
end
res = res "recfm("space(recfm, 1-forCsm)") lrecl("rl")"
end
if pos('(', dsn) > 0 & pos(' DSNTYPE(', aU) < 1 ,
& pos(' DSORG(', aU) < 1 then
res = res 'dsntype(library) dsorg(po)'
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(10, 1000) cyl' || copies('inder', forCsm)
return res atts
endProcedure dsnCreateAtts
/*--- 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
/*--- 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
/* copy adrTso end ****************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call utIni
m.err.ini = 1
m.err.handler = ''
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
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then
interpret m.err.handler
call errSay 'f}'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.eCat == 'f' then do
call errSay ' }errorhandler exiting with divide by zero' ,
'to show stackHistory'
x = 1 / 0
end
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.ddAlloc') == 'VAR' then
call tsoFreeAll
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return saySt(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.eCat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err.eCat '}' msg
end
res = msg
if m.err.eCat <> '' then do
pTxt = ',error,fatal error,input error,s-}scanErr,warning,'
/* pTxt = ',error,fatal error,input error,syntax error,warning,' */
px = pos(','m.err.eCat, pTxt)
if px < 1 then do
m.err.eCat = 'f'
px = pos(','m.err.eCat, pTxt)
end
res = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if substr(res, 3, 1) == '}' then
parse var res 2 opt 3 br 4 res
if opt == '-' then
res = res msg
else do
parse source . . s3 . /* current rexx */
res = res 'in' s3':' msg
end
end
return splitNl(err, res) /* split lines at \n */
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
/*--- say (part of) the lines of a stem ----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
say m.st.lx
end
return st
endProcedure saySt
/*--- 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
/*--- 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 'assertRes =' arg(1)
if assertRes \==1 then
call err 'assert failed' arg(1) '==>' assertRes':' arg(2)
return
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'
m.ut.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.ut.alfUC = translate(m.ut.alfLc)
m.ut.Alfa = m.ut.alfLc || m.ut.alfUC
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.alfRex = m.ut.Alfa'.0123456789@#$?' /* charset puff mit ¬*/
m.ut.alfRexN1= '.0123456789'
m.ut.alfPrint = m.ut.alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
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')
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
say 'end ' utTime()
return
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(s) >= len then
return s
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.alfLc, m.ut.alfUc)
/*--- 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
tstUtc2d: procedure expose m.
numeric digits 33
say c2d('ffffff'x)
say utc2d('ffffff'x)
say utc2d('01000000'x) 256*256*256
say utc2d('01000001'x)
say utc2d('020000FF'x) 256*256*256*2+255
say utc2d('03020000EF'x) 256*256*256*770+239
return
endProcedure tstUtc2d
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
/* copy ut end ********************************************************/