zOs/REXX/DBX
/* rexx ****************************************************************
synopsis: DBX opt* fun args v3.3
21.11.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
dropAll
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
************************************************************************
23.11.2016 Walter lmm -> mbrList in auftragNext
*/ /* end of help
21.11.2016 Stephan neues ddlcheck und Anapost mit exception handling
23. 6.2016 Walter dropAll und fix fuer DDLONLY (aber CA ...)
10. 6.2016 Walter anaPost fuer ddlChange, DDK, PBG 4G
3. 6.2016 Walter mLem43, fix error fuer ren dbSy, uts2old
25. 4.2016 Walter utProfile for runstats profile, raus fuer ddlOnly
9. 2.2016 Walter support alias, view exeOut .....
19. 1.2016 Walter support sequence
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
***********************************************************************/
/* Konstanten ----------------------------------------------------*/
CONST_PROFILE = 1 ;
/* if userid() = 'A586114' then CONST_PROFILE = 2 */
if CONST_PROFILE = 1 then do /* PROD Konfiguration */
m.debug = 0
m.editMacro = 0
m.editProc = 0
m.aTb = 'OA1P.tAdm70A1'
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.rexxLib = 'DSN.DB2.EXEC'
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
m.libSpezial = m.libPre'.SPEZIAL'
end
if CONST_PROFILE = 2 then do /* TEST Konfiguration */
m.debug = 0
m.editMacro = 0
m.editProc = 0
m.aTb = 'OA1P.tAdm70A1'
m.auftrag.dataset = 'DSN.DBX.AUFTRAG'
m.rexxLib = 'DSN.DBXAPP.V33.SRC.EXEC'
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DBXAPP.V33.SRC.SKELS(dbx'
m.libSpezial = m.libPre'.SPEZIAL'
end
/* dbx.main() ----------------------------------------------------*/
call errReset hi
call sqlIni
parse upper arg oArgs
oArg1 = word(oArgs, 1)
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 0 & 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
call mapPut e, 'rexxLib', m.rexxLib
/* Ersetzt durch Konfigurations Profile *************************
m.libPre = 'DSN.DBX'
m.libSkels = 'DSN.DB2.SKELS(dbx'
if 0 then do /* ??? testSkels */
m.libSkels = 'DSN.DBX.V32skels(dbx'
call mapPut e, 'rexxLib', 'DSN.DBX.V32REXX'
say left('test v32' m.libSkels',' mapGet(e, 'rexxLib'), 78,'*')
end
if 0 & userid() = 'A540769' then do /* testSkels */
m.libSkels = 'A540769.wk.skels(dbx'
call mapPut e, 'rexxLib', 'A540769.WK.REXX'
m.libSkels = 'A540769.wk.skels(dbx'
say '??? test' m.libSkels mapGet(e, 'rexxLib') '|||'
end
m.libSpezial = m.libPre'.spezial'
****************************************************************/
call configureRZ sysvar('SYSNODE')
m.sysRz = m.myRz
if m.myRZ = RZ4 then
m.myDbSys = DP4G
else
m.myDbSys = 'noSysDbSysFor'm.myRz
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 if m.uId = 'F267248' then
ii = 'Caspar cr'
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.DDK'
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'.DDI'
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_uc
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
lx = mbrList(ml, dsnSetMbr(m.na.nx, pre'*'))
say left(m.ml.1, 8) '-' left(m.ml.lx, 8)right(m.ml.0, 5) ,
'member in' dsnSetMbr(m.na.nx, pre'*')
if m.ml.lx >> max then
max = m.ml.lx
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"'", 100
if m.sql.7.updateCount \== 1 then do
call sqlUpdate , 'rollback'
call err m.aTb 'updateCount' m.sql.7.updateCount
end
else
call sqlCommit
call sqlDisconnect
end
if opt = '-R' then
nop
else
call adrIsp "edit dataset('"dsnNN"')", 4
end
m.auftrag.0 = '' /* do not write back the new auftrag | */
if opt = '-R' then
m.exitValue = nn
return 0
endProcedure nextAuftrag
/*--- einen neuen Auftrag initialisieren -----------------------------*/
neuerAuftrag: procedure expose m.
parse arg isTst, rz, auftName, ai
if rz = '' then
rz = m.myRz
else
call configureRz rz
if isTst then do
ow = m.uid
maPr = 'T' || left(translate(m.uNa), 3, 'X')
cChgs = 'ALLLALLL'
iChgs = 'QZ91S2T'
end
else do
ow = 'S100447'
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 ,
, ' aUtil all' ,
, ' 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, 'r'
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))
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 == 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 DDK DDI DD1 DD2 EXE EXO' ,
'JCL QUALITY QUICK REC RE1 RDL START'
lx = pos(' 'left(wh, 1), ll)
if length(wh) == 2 then
do while lx > 0 & right(word(substr(ll, lx+1), 1), 1) ,
\== right(wh, 1)
lx = pos(' 'left(wh, 1), ll, lx+2)
end
if lx < 1 then
call err 'i}bad libType='wh 'in' fun||wh a1 a2
llq = word(substr(ll, lx+1), 1)
end
if llq = 'JCL' then do
d = '* .JCL' m.e.auftrag
end
else if llq == 'QUALITY' | LLQ == 'DDK' | llq = 'DDL' then do
d = '* .'llq m.e.auf7 || left(a1 || m.e.nachtrag, 1)
end
else if llq == 'EXO' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
msk = r2'/DSN.DBY'd2'.'m.e.auf7'*.**.EX*'
if dsnList(oo, msk, 0) < 1 then do
say 'no datasets like' msk
return
end
do ox=1 to m.oo.0
d1 = m.oo.ox
d2 = substr(d1, pos('.', d1, 19)+1)
if ox=1 | abbrev(d2, '##DT') ,
| (d2 > dMi2 & \ abbrev(dMi2, '##DT')) then do
dMax = d1
dMi2 = d2
end
end
d = r2 dMax
end
else if llq == 'START' then do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 'DSN.DBY'd2'.'m.e.auf7'.'llq
end
else do
parse value a2rzDbSysNacLast(a1, a2) with r2 '/' d2 '#' n2
d = r2 d2'.'llq m.e.auf7 || n2
end
parse var d rz dsn mbr
if length(dsn) <= 20 then
dsn = m.libPre || dsn
eFun = word('Edit View', 1 + (fun \== 'E'))
if llq = 'QUALITY' then do
ddlxParm = substr(m.auftrag.member, 8, 1)
mac = 'MACRO(DDLX) PARM(DDLXPARM)'
end
else if wordPos(llq, 'ANA AN1 REC RE1 EXO') > 0 then
mac = 'MACRO(AC)'
else
mac = ''
if rz == '*' | rz == m.sysRz then
call adrIsp eFun "dataset('"dsn ,
|| copies("("mbr")", mbr<>'')"')" mac, 4
else
call adrCsm eFun "system("rz") dataset('"dsn"')",
copies("member("mbr")", mbr <> '') mac, 4
return
endProcedure viewEdit
/*- translate a list of abbreviations to rz/dbSys -------------------*/
a2rzdbSys: procedure expose m.
parse upper arg a
a1 = translate(a, ' /', ',.')
a2 = ''
do wx=1 to words(a1)
w = word(a1, wx)
sx = wordPos(w, m.promN_A)
if sx < 1 then
a2 = a2 w
else
a2 = a2 translate(word(m.promN_T, sx), ' 2', ',P')
end
a3 = ''
call iiIni
do wx=1 to words(a2)
w = word(a2, wx)
parse var w r1 '/' d1
if wordPos(r1, m.ii_rz) > 0 then
r2 = r1
else do
if pos('/', w) < 1 then
parse var w r1 2 d1
r2 = iiGet(plex2rz, r1, '^')
if r2 == '' then do
r2 = iiGet(c2rz, r1, '^')
if r2 == '' then
call err 'i}bad rz='r1 'in' w
end
end
d2 = ''
if d1 \== '' then do
ad = iiGet(rz2db, r2)
cx = pos(d1, ad)
if cx < 1 then
call err 'i}bad dbSys='d1 'in' r3 'in' a
d2 = word(substr(ad, lastPos(' ', ad, cx)+1), 1)
end
a3 = a3 r2'/'d2
end
return strip(a3)
endProcedure a2rzDbSys
/*- translate a list of abbreviations to rz/dbSys
add missing dbSys from promotion ptht
unique, ordered by rz, RZ4 first --------------------*/
a2rzDbSysProm: procedure expose m.
parse arg inp
if inp = '' then
call err 'a2rzDbSysProm empty'
a1 = a2RzDbSys(inp)
allRz = m.sysRz
r.allRz = ''
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r = '' then
call err 'no rz in' w 'in list' a1 'in inp' inp
if d = '' then do
ppx = m.promPath
sx = pos(r'/', m.promD.ppx)
if sx < 1 then
call err 'ungueltiges rz/dbSystem:' w 'for' inp
d = substr(m.promD.ppx, sx+4, 4)
end
if wordPos(r, allRz) < 1 then do
allRz = allRz r
r.r = r'/'d
end
else if wordPos(r'/'d, r.r) < 1 then
r.r = r.r r'/'d
end
res = ''
do wx=1 to words(allRz)
w = word(allRz, wx)
res = res r.w
end
return space(res, 1)
endProcedure a2rzDbSysProm
/*- translate a list of abbreviations to first rz/dbSys#nachtrag
default to last import ----------------------*/
a2rzdbSysNacLast: procedure expose m.
parse arg a, n
a1 = a2rzDbSys(a)
if a1 == '' then
mx = m.imp.0
else do
do wx=1 to words(a1)
w = word(a1, wx)
parse var w r '/' d
if r \== '' & d \== '' & n \== '' then
return w'#'n
do mx = m.imp.0 by -1 to 1
if r \== '' & m.imp.mx.rz \== r then
iterate
if d \== '' & m.imp.mx.dbSys \== d then
iterate
if n \== '' & m.imp.mx.nachtrag \== n then
iterate
leave
end
if mx > 0 then
leave
end
end
if mx < 1 | mx > m.imp.0 then
call err 'i}no import for' a '#'n
n1 = left(a2, 1)
return m.imp.mx.rz'/'m.imp.mx.dbSys'#'m.imp.mx.nachtrag
endProcedure a2rzdbSysNacLast
/*--- return jcl either dd dummy or dd disp=shr,dsn=... --------------*/
shrDummy: procedure expose m.
parse arg dsn, keepEmpty
if dsn \= '' then
return 'DISP=SHR,DSN='translate(dsn)
else if keepEmpty == 1 then
return ''
else
return 'DUMMY'
endProcedure shrDummy
/*--- funktion i -----------------------------------------------------*/
import: procedure expose m.
parse upper arg fun, rzDbSyList opt .
call analyseAuftrag
if m.e.nachtrag = '?' then
call err 'vor i=import braucht es compare'
if opt <> '' then
nop
else if m.cmpLast then
call err 'i=import mit c = oder v = muss Nachtraege',
'explizit angeben, z.B. dbx i' rzDbSyList m.e.nachtrag
if ^ m.nacImp & m.e.tool = 'IBM' then do
cdl = cdlDsnCheck(m.e.nachtrag)
if m.e.dbaCheck \== 0 & m.e.tool == 'IBM' then do
if m.editMacro then
dbaParm = 'EX0'
else
dbaParm = 'END'
call adrIsp "edit dataset('"cdl"') macro(dbacheck)",
"parm(dbaParm)", 4
end
end
call mapPut e, 'expOpt', if(m.e.keepTgt, 'A', 'X')
if list = '' then
call err 'no targets in list "'rzDBSysList'"'
impCnt = 0
if fun = 'IA' then
fu2 = 'Ana'
else if fun = 'IE' then
fu2 = 'AnaExe'
else
fu2 = ''
if m.e.tool == 'IBM' & fu2 \== '' then
call err 'fun' fun 'not implemented for ibm'
call configureRz m.sysRz
call mapPut e, 'fun', strip('import'fun fu2 left(rzDbSyList, 30))
call mapPut e, 'jobName', 'Y'm.e.auf7
m.jOut.0 = 0
m.jOut.two.0 = 0
m.jOut.send.0 = 0
call addIfEndSet jOut
call addIfEndSet 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, 'r'
call sqlUpdate 1, "update" m.aTb "set" substr(sq, 3) ,
"where workliste = '"m.e.auftrag"'", 100
if m.sql.1.updateCount = 0 then
say m.e.auftrag 'nicht in der AuftragsTable' 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)
eIf = 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 addIfEndSet o, eIf, 'CP'toRz
end
end
if m.o.two.0 == 0 then do
end
else if m.sysRz == toRz then do
endIf = addIf(o)
call mAddSt o, o'.TWO'
call addIfEndSet o, endIf, m.o.two.ifLine
end
else do
endIf = 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 addIfEndSet o, endIf, 'SUB'toRz
end
m.o.two.0 = 0
call addIfEndSet 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
endIf = 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 addIfEndSet o, endIf, 'SUB???'
return
endProcedure ibmImportExpand
caImport: procedure expose m.
parse arg o, fun, nachAll, iChgs, iMap, iRule
if length(nachAll) \== 1 then
call err 'caImport nachAll' nachAll 'not exactly one'
nact = mapGet(e, 'mbrNac')
ddlSrc = m.libPre'.DDL('nact')'
if iRule == '' | iRule = 'EMPTY' | iRule = 'IGNORE' then
iRule = 'ALL'
if iChgs = 'EMPTY' then
iChgs = ''
if substr(iChgs, 5, 4) == left(iChgs, 4) then
iChgs = ''
call mapPut e, 'iMap', iMap
call mapPut e, 'iRule', iRule
ddlLib = m.libPre || mapGet(e, 'subsys')'.DD'
ddC.1 = 1
ddC.2 = 2
ddC.3 = 'I'
ddlIx = 3 - (iChgs \== '') - m.e.anapost
ddlAA = ddlLib || ddlIx'('nact')'
call copyMbr o, nact, ddlSrc, m.myRz , ddlLib|| ddC.ddlIx'('nact')'
if iChgs \== '' then do
ddlIx = ddlIx + 1
ddlBB = ddlLib || ddC.ddlIx'('nact')'
call caImpRename o'.TWO', iChgs, nact, ddlAA, ddlBB
ddlAA = ddlBB
end
endIf = addIf(o'.TWO')
call mapPut e, 'aOpt1', ' ' copies('ddlOnly', m.e.ddlOnly) ,
copies('dropAll', m.e.dropAll) ,
copies('keepTgt0', m.e.keepTgt == 0) ,
copies('anaPost0', m.e.anaPost == 0) ,
copies('uts2old', m.e.uts2old == 1)
call mapExpAll e, o'.TWO', skelStem('aOpt')
call addIfEndSet o'.TWO', endIf, 'AOPT'
call mapPut e, 'stry', nact
call stepGroup
ddlImp = ddlLib'I('nact')'
if m.e.anaPost then do
call mapPut e, 'ddlIn', ddlAA
call mapPut e, 'ddlOut', ddlImp
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CPre')
call addIfEndSet o'.TWO', endIf, 'PRE'
end
call mapPut e, 'ddlin', ddlImp
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CImp')
call addIfEndSet o'.TWO', endIf, '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 = '' | m.e.ddlOnly then
utProf = ''
else
utProf = m.e.aUtil || copies('RUN',
, wordPos(m.myRz, 'RZX RZY RZZ RR2') > 0)
if utProf = '' then do
call mapPut e, 'aUtilNm', ''
call mapPut e, 'aUtilCre', ''
end
else do
call mapPut e, 'aUtilNm', 'UPNAME ' utProf' U'
call mapPut e, 'aUtilCre', 'UPCRT ' mapGet(e, 'cacr')
end
if m.e.ddlOnly then
call mapPut e, 'ddlOnlyOrUnload', '' /*
errror in rc/m no control ......
call mapPut e, 'ddlOnlyOrUnload', 'DDLONLY' */
else
call mapPut e, 'ddlOnlyOrUnload', 'UNLOAD'
call mapPut e, 'dropAll', copies('DROPALL', m.e.dropALl)
endIf = addIf(o'.TWO')
call mapExpAll e, o'.TWO', skelStem('CAna')
if m.e.anapost then
call mapExpAll e, o'.TWO', skelStem('CPost')
call addIfEndSet o'.TWO', endIf,
, 'ANA', 0 4, copies('POST', m.e.anaPost)
end
if fun == 'IA' then do /* copy execute jcl */
call stepGroup
endIf = addIf(o'.TWO')
oldIf = m.o.two.ifLine
call mapExpAll e, o'.TWO', skelStem(left(m.e.tool, 1)'ECP')
old = stepGroup(11)
call addIfEndSet 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 mAdd o'.TWO', '}]'
m.o.two.ifLine = oldIf
call stepGroup old
call addIfEndSet o'.TWO', endIf, 'EXCP', 0 4
end
else if fun == 'IE' then do /* add execute steps */
call caExecute o'.TWO'
end
return
endProcedure caImport
caExecute: procedure expose m.
parse arg o
pre = mapExp(e, '${libPre}${subsys}')
nact = mapGet(e, 'mbrNac')
if m.e.anapost then do
endIf = addIf(o)
call caDD1 o, '// DD DISP=SHR,DSN='pre'.QUICK('nact')',
, , pre'.RDL('nact')'
call addIfEndSet o, endIf, 'DDL', 0 4
call mapPut e, 'rdlArc', pre'.RDL('nact')'
end
else do
call mapPut e, 'rdlArc', ''
end
endIf = addIf(o)
call mapExpAll e, o, skelStem(left(m.e.tool, 1)'Exe')
call addIfEndSet o, endIf, 'EXE', 0 4
return
endProcedure caExecute
caImpRename: procedure expose m.
parse arg o, msk, nact, ddlIn, ddlOut
endIf = addIf(o)
call mapPut e, 'rStry', m.e.auf7'#'
call mapPut e, 'ddlin', ddlIn
call mapPut e, 'ddlout', ddlOut
call mapExpAll e, o, skelStem('CREN')
call caGlbChg o, msk
call mAdd o, '// ENDIF' /* for unterminated if in cRen */
call addIfEndSet o, endIf, '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
addIfEndSet: procedure expose m.
parse arg o, endIf, stp, codes
if endIf \== '' then
call mAdd o, endIf
if stp == '' | m.e.tool = 'IBM' then
m.o.ifLine = ''
else if words(stp) > 1 then
m.o.ifLine = stp
else do
li = ''
do ax=3 by 2 to arg() while arg(ax) \== ''
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
m.o.ifLine = substr(li, 6)
end
return
endProcedure addIfEndSet
addIf: procedure expose m.
parse arg o, opt
if symbol('m.addIfCnt') \== 'VAR' then
m.addIfCnt = 1
else
m.addIfCnt = m.addIfCnt + 1
if m.o.ifLine == '' then
return ''
pr = left('//IF'm.addIfCnt, 9)'IF'
cond = space(m.o.ifLine, 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'
return '// ENDIF IF'm.addIfCnt
endProcedure addIf
addJobError: procedure expose m.
parse arg o
if m.e.tool == ibm then
return
cond = m.o.ifLine
if m.o.ifLine = '' then
m.o.ifLine = 'ABEND OR RC <> 0'
else
m.o.ifLine = 'ABEND OR RC > 4 OR NOT (' m.o.ifLine ')'
endIf = addIf(o)
call mAdd o, '//*** jobError: set CC to >= 12 ********************',
, '//JOBERROR EXEC PGM=IDCAMS ',
, '//SYSPRINT DD SYSOUT=*',
, '//SYSIN DD *',
, ' SET MAXCC = 12',
, endIf
return
endProcedure addJobError
/*--- DSN für CDL des Nachtrags zurückgeben und auf Existenz prüfen---*/
cdlDsnCheck: procedure expose m.
parse arg nt
cdl = m.libPre'.'if(m.e.tool=='IBM', 'CDL', 'DDL') ,
|| '('m.e.auf7 || nt')'
if m.cdlDsnCheck.cdl == 1 then
return cdl
rr = sysDsn("'"cdl"'")
if rr <> 'OK' then
call err 'cdl fuer' nt'. Nachtrag fehlt:' cdl rr
m.cdlDsnCheck.cdl = 1
return cdl
endProcedure cdlDsnCheck
/*--- Date und user rechtsbuendig einfuegen --------------------------*/
addDateUs: procedure expose m.
parse arg le
return le right(date(s) time() m.uNa, 71-length(le))
endProcedure addDateUs "'"
/*--- den aktuellen Auftrag analysieren ------------------------------*/
analyseAuftrag: procedure expose m.
m.scopeSrc.0 = 0
m.scopeSrc.dbSy = m.pr1Sub
m.scopeSrc.rz = m.myRz
m.catSrc.0 = ''
m.scopeTrg.0 = 0
m.scopeTrg.dbSy = m.pr1Sub
m.scopeTrg.rz = m.myRz
m.catTrg.0 = ''
m.imp.seq = -1
impX = 0
m.nacImp = 0
m.e.cChgs = ''
m.e.iChgs = ''
m.e.impMask = ''
m.e.iMap = 'ALLLALLL'
m.e.iRule = ''
m.e.impIgno = ''
m.e.tool = 'CA'
m.e.aModel = 'ALL'
m.e.aUtil = ''
m.e.keepTgt = 1
m.e.anaPost = 1
m.e.ddlOnly = 0
m.e.dropAll = 0
m.e.uts2old = 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 VP5 VPT UTS2OLD' ,
'KEEPTGT DBACHECK QCHECK CA DDLONLY DROPALL ANAPOST'
ignWo = 'SW SENDWSL RECEIVEWSL RECEIVESOURCE'
ignCh = '*|'
lev1Wo = 'SCOPE SOURCE TARGET COMPARE VERSION IMPORT SENDTARGET' ,
varWo varWu 'PROTOTYPERZ'
do lx=1 to m.auftrag.0
li = left(m.auftrag.lx, 72)
parse upper var li w1 w2 w3 .
if w1 = '' | pos(left(w1, 1), ignCh) > 0 ,
| wordPos(w1, ignWo) > 0 then
iterate
if wordPos(w1, vaWo) < 1 then
call err 'operation' w1 ', erwartet' vaWo 'in Zeile' lx li
if w1 = 'AUFTRAG' then do
if w2 ^= m.auftrag.member then
call err 'auftrag' w2 '<> member' m.auftrag.member
m.e.auftrag = w2
m.e.auf7 = left(w2, 7)
m.e.nachtrag = '?'
m.nachtrag.0 = 0
if dataType(left(w3, 1), 'U') & length(w3) <= 8 then
ow = w3
else
ow = 'S100447'
call mapPut e, 'chgOwn', ow
vaWo = lev1Wo
end
else if abbrev(w1, 'VP') then do
call configureRZ , , substr(w1, 2)
end
else if wordPos(w1, 'CA IBM') > 0 then do
m.e.tool = w1
end
else if w1 == 'AOPT' then do
m.e.w1 = subword(li, 2)
end
else if wordPos(w1, varWo) > 0 then do
m.e.w1 = word(li, 2)
end
else if wordPos(w1, varWu) > 0 then do
m.e.w1 = w2
end
else if w1 = 'PROTOTYPERZ' then do /* alte syntax sep08 ??? */
m.scopeSrc.rz = word(li, 2)
end
else if wordPos(w1, 'SCOPE SOURCE TARGET') > 0 then do
suSy = ''
if w1 = 'SOURCE' then do
scp = 'SCOPESRC'
suSy = w2
end
else if w1 = 'TARGET' then do
scp = 'SCOPETRG'
if abbrev('EXPLICIT', w2, 2) then do
m.optAuto = 0
suSy = w3
end
else do
suSy = w2
if abbrev('EXPLICIT', w3, 2) then
m.optAuto = 0
end
end
else do /* alte syntax */
if abbrev('SOURCE', w2) then
scp = 'SCOPESRC'
else if abbrev('TARGET', w2) then
scp = 'SCOPETRG'
else
call err 'scope' w2 'nicht abk. von SOURCE TARGET',
'in Zeile' lx li
end
if (abbrev(suSy, 'DQ0') | abbrev(suSy, 'RZ1.DQ0')) ,
<> (m.libPre == 'DSN.DBQ') then
call err 'DBSys' suSy 'mit Auftrag in' m.libPre
m.scp.0 = 0
if pos('.', suSy) > 0 then
parse var suSy suRz '.' suSy
else if pos('/', suSy) > 0 then
parse var suSy suRz '/' suSy
else
suRZ = ''
if suSy <> '' then
m.scp.dbSy = suSy
if suRz <> '' then
m.scp.rz = suRz
vaWo = m.scopeTypes m.scopeType1 lev1Wo
call debug 'scope' scp m.scp.rz'.'m.scp.dbSy
end
else if wordPos(w1, m.scopeTypes m.scopeType1) > 0 then do
parse value analyseScope(li) with ty nm qu
if ty = '?' then
call err nm qu 'in scope line' lx':' strip(li)
aa = mAdd(scp, 'scope')
m.aa.type = ty
m.aa.qual = qu
m.aa.name = nm
end
else if wordPos(w1, 'COMPARE VERSION SENDTARGET') > 0 then do
if w1 = 'SENDTARGET' then
w2 = w3
cmpLast = abbrev(w2, '=')
w2 = strip(w2, 'l', '=')
if length(w2) <> 1 | pos(w2, m.nachtragChars) < 1 then
call err 'nachtrag' w2 'in Zeile' lx li
if pos(w2, m.nachtragChars) ,
< pos(m.e.nachtrag, m.nachtragChars) then
call err 'nachtrag' w2 '< vorherigem' m.e.nachtrag ,
'in Zeile' lx li
if m.e.nachtrag <> w2 then do
m.e.nachtrag = w2
nx = m.nachtrag.0 + 1
m.nachtrag.0 = nx
m.nachtrag.nx = w2
end
m.nachtrag.nx.fun = ''
m.nachtrag.nx.last = cmpLast
if pos(left(w1, 1), 'CV') > 0 then
m.nachtrag.nx.fun = left(w1, 1)
if abbrev(w3, "'") | verify(w3, '/.', 'm') < 1 then
t1 = m.myRz'/'m.pr1Sub
else
t1 = translate(w3, '/', '.')
m.nachtrag.nx.trg = t1
call debug 'nachtr' nx m.nachtrag.nx 'trg' m.nachtrag.nx.trg
m.nacImp = (w1 <> 'COMPARE')
end
else if w1 = 'IMPORT' then do
parse upper var li . dbSy nachAll chg .
dbSy = translate(dbSy, '/', '.')
if pos('/', dbSy) < 1 then
dbSy = 'RZ1/'dbSy
impX = impX + 1
m.imp.impX.nachtrag = nachAll
parse var dbSy m.imp.impX.rz '/' m.imp.impX.dbSys
parse var chg chgAuf '.' chgNac '.' chgSeq '.' chgImp
aa = m.e.auftrag
if chgAuf = aa then do
if left(chgNac, 1) <> left(nachAll, 1) then
call err 'Nachtrag von mismatch in Zeile' lx li
if right(chgNac, 1) <> right(nachAll, 1) then
call err 'Nachtrag bis mismatch in Zeile' lx li
end
else if abbrev(chgAuf, aa) ,
& substr(chgAuf, length(aa)+4, 1) == '_' then do
chgSeq = substr(chgAuf, length(aa)+1, 3)
end
else
call err 'Auftrag mismatch in Zeile' lx li
if chgSeq <= m.imp.seq then
call err 'seq' chgSeq 'nicht > letzte' m.imp.seq,
'in Zeile' lx li
m.nacImp = 1
m.imp.last = dbSy
m.imp.dbSy.nachtrag = nachAll
if wordPos(dbSy, allImpSubs) < 1 then do
allImpSubs = allImpSubs dbSy
m.imp.dbSy.nachTop = left(nachAll, 1)
end
do nx=length(nachAll) by -1 to 1
if pos(substr(nachAll, nx, 1), m.nachtragChars) ,
> pos(m.imp.dbSy.nachTop , m.nachtragChars) then
m.imp.dbSy.nachTop = substr(nachAll, nx, 1)
end
m.imp.dbSy.change = chg
m.imp.seq = chgSeq
end
else do
call err 'ungültiger Operator' w1 'in Zeile' lx':' strip(li)
end
end
m.imp.0 = impX
m.e.keepTgt = m.e.keepTgt == 1
m.e.anaPost = m.e.anaPost == 1
m.promPath = abbrev(m.e.auftrag, 'XB') + 1
m.e.prodDbSys = if(abbrev(m.e.auftrag, 'XB'), 'DVBP', 'DBOF')
m.e.ddlOnly = m.e.ddlOnly == '' | m.e.ddlOnly == 1
m.e.dropAll = m.e.dropAll == '' | m.e.dropAll == 1
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
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)
endIf = addIf(o)
call mapExpAll e, o, skelStem(if(toRz = m.sysRz, 'cMbr', 'sMbr'))
call addIfEndSet o, endIf, '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, 'r'
else
call sqlConnect m.scp.rz'/'m.scp.dbSy, 'c'
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, 0 , 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 do
dbSy = substr(dbSy, 5)
call sqlConnect dbSy, 'r'
end
else do
call sqlConnect dbSy, 'c'
end
dbSy = ut2lc(dbSy)
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
rd = sqlRdr(sql 'order by 2', 'FT FN FI')
call jOpen rd, '<'
do cx=0 while jRead(rd)
d = m.rd
call mAdd o, lefPad(m.d.ft, 3) lefPad(m.d.fn, 30) m.d.fi
end
call jClose rd
if cx = 0 then
call mAdd o, lefPad(ty, 3) lefPad(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
/*--- 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
if m.e.anaPost then
oDsn = mapExp(e, '${libPre}.DDK($mbrNac)')
else
oDsn = mapExp(e, '${libPre}.DDL($mbrNac)')
if m.sysRz = m.scp.rz then do
call caDD1 o, scp, GlbChg, oDsn
call addIfEndSet o, , ddl, 0 4
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
call addIfEndSet o, , 'RECSRC'
end
if m.e.anaPost then do
endif = addIf(o)
call mapExpAll e, o, skelStem('CDDPO')
call addIfEndSet o, endIf
end
return 0
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 'ALIAS' , 'A AL'
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 *************************/
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, 'r'
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, 'r'
call sqlQuery 1, "select * from" m.aTb ,
"where trunc_timestamp(timestamp(einfuehrung) , 'mon')" ,
" = '20"left(zgl, 2)"-"right(zgl, 2)"-01-00.00.00'" ,
"order by workliste"
ox = 0
do while sqlFetch(1, a)
err = ''
m1 = m.a.workliste
if m1 = '' then
err = 'leere Workliste'
else if sysDsn("'"lib"("m1")'") <> 'OK' then
err = 'Auftrag fehlt, sysdsn='sysDsn("'"lib"("m1")'")
else do
call readDsn lib'('m1')', 'M.I.'
w2 = word(m.i.2, 2)
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then
err = 'zuegelschub fehlt in auftrag:' m.i.2
else if \ (abbrev(w2, zgl) | abbrev(w2, zg2) ,
| right(w2, 6) == zg3 | right(w2, 8) == zg4) then
err = 'falscher zuegelschub:' m.i.2
else do
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax,1)),
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = left(m1, 8) left(ac, 3),
left(m.a.auftrag, 10) ,
left(m.a.einfuehrungs_zeit, 5) ,
left(m.a.id7, 3)
end
end
if err \== '' then
say 'error' m1 err
end
call sqlClose 1
call sqlDisconnect
call writeDsn outDsn, 'M.O.', ox, 1
return
endProcedure zStatAuftragsListe
zStatsStatistik: procedure expose m.
parse arg zgl, aufLst, out
call zStatReset mm
call readDsn aufLst, m.l.
do lx=1 to m.l.0
au = word(m.l.lx, 1)
a7 = left(translate(au), 7)
if abbrev(a7, '*') | a7 = '' then
iterate
m.auft.a7 = au word(m.l.lx, 2)
m.mm.auft = m.mm.auft a7
m.mm.count.list = m.mm.count.list + 1
end
dbSys = ''
rz = sysvar(sysNode)
if rz = 'RZ4' then do
dbSys = 'DBOL DP4G'
end
else do px=1 to m.promD.0
p1 = translate(m.promD.px, ' ', ',')
pc = pos(rz'/', p1)
do while pc > 0
ps = word(substr(p1, pc+4), 1)
if wordPos(ps, dbSys) < 1 then
dbSys = strip(dbSys ps)
pc = pos(rz'/', p1, pc+4)
end
end
do dx=1 to words(dbSys)
d1 = word(dbSys, dx)
say 'statistics for' d1
ana = m.libpre || d1'.ANA'
if sysDsn("'"ana"'") <> 'OK' then do
say '---' d1 'sysDsn('ana')' sysDsn("'"ana"'")
iterate
end
say '---' d1
lmm = lmmBegin(ana)
laM7 = ''
laAct = 0
do forever
m1 = lmmNext(lmm)
m7 = left(m1, 7)
if laM7 \== m7 then do
if laAct then do
say '---'laM7 || laTop m.auft.laM7,
copies('<><><>', laTop \== word(m.auft.laM7, 2))
call countNachtrag mm, laM7 || laTop, laSeq
call countSqls mm, ana'('laM7 || laTop')'
end
if m1 == '' then
leave
laM7 = m7
laAct = symbol('m.auft.m7') == 'VAR'
if laAct then do
laNac = m.auft.m7
if words(laNac) < 2 then
laSeq = 999
else
laSeq = pos(word(laNac, 2), m.nachtragChars)
laTop = ''
end
end
if laAct then do
nac = substr(m1, 8, 1)
seq = pos(nac, m.nachtragChars)
if seq < 1 then
call err 'bad Nachtrag' m1
if seq > pos(laTop, m.nachtragChars) then
laTop = nac
end
end
end
total = '--total--'
m.o.0 = 0
call mAdd o, 'Zuegelschub' zgl 'Statistik fuer' dbSys 'in' rz,
, left('Auftraege in Liste', 19) right(m.mm.count.list, 9),
, left('Auftraege analys''t', 19) right(m.mm.count.auft, 9),
, left('Nachtraege', 19) right(m.mm.count.nact - m.mm.count.auft, 9)
call zStatsCountOut mm, o
say words(m.mm.auft) 'auftraege in list but not in ana' m.mm.auft
call mAdd o, words(m.mm.auft) 'auftraege in list but not in ana',
if(length(m.mm.auft) < 35, m.mm.auft, left(m.mm.auft, 32)'...')
call writeDsn out, m.o., , 1
call adrIsp "view dataset('"out"')", 4
return
endProcedure zStatsStatistik
zStatReset: procedure expose m.
parse arg m
m.m.verbs = ' CREATE ALTER DROP '
m.m.verb2 = m.m.verbs 'REBIND'
m.m.objs = 'DATABASE TABLESPACE TABLE INDEX VIEW TRIGGER SYNONYM ALIAS'
m.m.obj2 = m.m.objs 'UNIQUE'
m.m.obId = 'd s t i v g y a'
m.m.auft = ''
m.m.count.auft = 0
m.m.count.list = 0
m.m.count.nact = 0
m.m.count.rebind = 0
m.m.count.load = 0
do ox=1 to words(m.m.obj2)
o1 = word(m.m.obj2, ox)
do vx=1 to words(m.m.verbs)
v1 = word(m.m.verbs, vx)
m.m.count.o1.v1 = 0
end
end
return
endProcedure zStatReset
zStatsCountOut: procedure expose m.
parse arg mm, o
call mAdd o ,
, left('Load', 19) right(m.mm.count.load, 9),
, left('Rebind Package', 19) right(m.mm.count.rebind, 9),
, , left('',19) m.mm.verbs
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
m.mm.count.total.v1 = 0
m.mm.count.index.v1 = m.mm.count.index.v1 + m.mm.count.unique.v1
end
obj3 = m.mm.objs total
do ox=1 to words(obj3)
o1 = word(obj3, ox)
t = left(o1, 19)
do vx=1 to words(m.mm.verbs)
v1 = word(m.mm.verbs, vx)
t = t right(m.mm.count.o1.v1, 9)
m.mm.count.total.v1 = m.mm.count.total.v1 + m.mm.count.o1.v1
end
call mAdd o, t
end
return
endProcedure zStatsCountOut
checkAuftrag: procedure expose m.
parse arg lib, von bis, aufLst
say 'zStat fuer Zuegelschub von' von 'bis' bis
say ' erstellt Auftragsliste auf' aufLst
ox = 0
if bis == '' then
bis = von
lmm = lmmBegin(lib)
ls = 0
z0 = 0
do mx=1
m1 = lmmNext(lmm)
if m1 == '' then
leave
call readDsn lib'('m1')', 'M.I.'
ls = ls + m.i.0
if mx // 100 = 0 then
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='mx 'lines='ls
if translate(word(m.i.2, 1)) \== 'ZUEGELSCHUB' then do
z0 = z0 + 1
iterate
end
z1 = word(m.i.2, 2)
if z1 << von | z1 >> bis then
iterate
do ax=m.i.0 by -1 to 2 while translate(word(m.i.ax, 1)) ,
\== 'COMPARE'
end
ac = if(ax>2, word(m.i.ax, 2))
ox = ox + 1
m.o.ox = m1 ac
end
say m1 'noZgl='z0 'thisZgl='ox 'mbrs='||(mx-1) 'lines='ls
call writeDsn aufLst, m.o., ox, 1
return 0
endProcedure checkAuftrag
countNachtrag: procedure expose m.
parse arg m, mbr, seq
if mbr == '' then
return
mSq = pos(substr(mbr, 8, 1), m.nachtragChars)
m.m.count.auft = m.m.count.auft + 1
m.m.count.nact = m.m.count.nact + mSq
a7 = left(mbr, 7)
wx = wordPos(a7, m.m.auft)
if wx > 0 then
m.m.auft = subword(m.m.auft, 1, wx-1) subword(m.m.auft, wx+1)
else
say a7 mbr 'not in list'
return
endProcedcure countNachtrag
countSqls: procedure expose m.
parse arg m, dsn
call readNxBegin nx, dsn
do lx=1
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then
iterate
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = lx
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lx = lx + 1
lp = readNx(nx)
end
if lx - sx > 1200 | lp == '' then
say '???snapshot' sx'-'lx 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.obj2)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' lx':'li
o = word(m.m.obj2, ox)
if 0 then
say v o lx':' strip(li, 't')
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' li
m.m.count.o.v = m.m.count.o.v + 1
end
call readNxEnd nx
return
endProcedure countSqls
countAna: procedure expose m.
parse arg lst
call zStatReset caa
call mapReset 'CAA.OBJ', 'k'
call mapReset 'CAA.UTL', 'k'
call mapReset 'CAA.DDL', 'k'
m.cao.0 = 0
m.caP.0 = 0
lib = ''
oMbr = ''
do lx=1 to words(lst)
w = word(lst, lx)
if length(w) = 4 then
lib = 'dsn.dbx'w'.ana'
else if length(w) > 8 | pos('.', w) > 0 then
lib = w
else if lib == '' then
call err 'no lib' w 'in countAna' lst
else
lib = dsnSetMbr(lib, w)
if dsnGetMbr(lib) == '' then
iterate
say 'countAna' lib
oMbr = dsnGetMbr(lib)
call mAdd caP, '', '***' oMbr lib
call countAna1 caa, lib, caP
lib = dsnSetMbr(lib)
end
if oMbr = '' then
call err 'no anas'
call zStatsCountOut caa, caO
call mAddSt caO, caP
out = dsnSetMbr(dsn2jcl('~tmp.countAna'), oMbr)
call writeDsn out '::f', m.caO., , 1
call adrIsp "view dataset('"out"')", 4
return 0
endProcedure countAna
countAna1: procedure expose m.
parse arg m, dsn, out
call readNxBegin nx, dsn
do forever
lp = readNx(nx)
if lp == '' then
leave
li = translate(strip(m.lp))
if li == '' | abbrev(li, '--') then do
if abbrev(li, '--##') then
if translate(word(li, 1)) == '--##BEGIN' then
call countAnaBeg m, nx, li
iterate
end
if abbrev(li, '.') then do
if abbrev(li, '.CALL SNAPSHOT') then do
sx = readNxLiNo(nx)
do until lp == '' | abbrev(m.lp, '.ENDDATA')
lp = readNx(nx)
end
sy = readNxLiNo(nx)
if sy - sx > 1200 | lp == '' then
say '???snapshot' sx'-'sy 'tooLong/end missing'
end
else if abbrev(li, '.CALL UTIL LOAD ') then do
m.m.count.load = m.m.count.load + 1
end
iterate
end
if wordPos(word(li, 1), m.m.verb2) < 1 then
iterate
v = word(li, 1)
if v = 'REBIND' then do
m.m.count.rebind = m.m.count.rebind ,
+ (pos('PACKAGE', li) > 0)
iterate
end
ox = wordPos(word(li, 2), m.m.obj2)
if ox < 1 & (v == 'DROP' | v == 'ALTER') then
iterate
ox = wordPos(word(li, 2), m.m.objs)
do wx=3 to min(5, words(li)) while ox < 1
ox = wordPos(word(li, wx), m.m.objs)
end
if ox < 1 then
call err 'no object' m.m.obj2 'in' readNxPos(nx)
o = word(m.m.obj2, ox)
oI1 = word(m.m.obId, ox)
if 0 then
say v oI1 o readNxPos(nx)
if \ datatype(m.m.count.o.v, 'n') ,
| wordPos(v, m.m.verbs) < 0 then
say '???' v o '???' readNxPos(nx)
m.m.count.o.v = m.m.count.o.v + 1
nm = word(li, wx)
if pos(';', nm) > 0 then
nm = left(nm, pos(';', nm)-1)
onNm = ''
if pos(';', li) < 1 & words(li) <= wx then do
lp = readNx(nx)
li = translate(strip(m.lp))
wx = 0
end
if wordPos(word(li, wx+1), 'ON IN') > 0 then
onNm = word(li, wx+2)
if o == 'INDEX' & v == 'CREATE' then do
if nm == '' | onNm == '' | word(li, wx+1) \== 'ON' then
call err 'bad index' readNxPos(nx)
/* say 'index' nm 'on' onNm */
call addDDL m, v, 'i'nm, 't'onNm
end
else if wordPos(v, 'CREATE ALTER DROP') > 0 then do
if v == 'CREATE' & oI1 = 's' then
call addDdl m, v, oI1 || onNm'.'nm, '?'
else
call addDdl m, v, oI1 || nm, '?'
end
else
say '????' v oI1 nm
end
call readNxEnd nx
uk = mapKeys(m'.OBJ')
call sort uk, sk
do ux=1 to m.uk.0
u1 = m.sk.ux
if abbrev(mapGet(m'.OBJ', u1), '?') then
call objShow m, u1, 0, out
end
return 0
endProcedure countAna1
objShow: procedure expose m.
parse arg m, o, l, out
t = left('', l)o mapGet(m'.DDL', o, '') 'u' mapGet(m'.UTL', o, '')
if out == '' then
say t
else
call mAdd out, t
chs = mapGet(m'.OBJ', o)
do cx=2 to words(chs)
call objShow m, word(chs, cx), l+5, out
end
return
endProcedure objShow
countAnaBeg: procedure expose m.
parse arg m, nx, li
wMod = word(li, 2)
wTs = '?'
wMod = substr(wMod, lastPos('.', wMod) + 1)
if wMod == 'CHKSTART:' | wMod = 'ANAPOST' then
return
else if wMod == 'FUNLD' | wMod == 'LOAD' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'TABLE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 't'substr(word(li, 4), 7)
lp = readNx(nx)
l2 = m.lp
if \ abbrev(l2, '--## ') | word(l2, 2) \== 'DBTS' then
call err 'bad FUNLD cont' readNxPos(nx)
wTs = 's'word(l2, 3)
if right(wTs, 1) == ':' then
wTs = left(wTs, length(wTs)-1)
end
else if wMod == 'REORG' then do
if word(li, 3) \== 'OBJ' ,
| \abbrev(word(li, 4), 'TABLESPACE:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 's'substr(word(li, 4), 12)
end
else if wMod == 'RECOVIX' then do
if word(li, 3) \== 'OBJ' | \abbrev(word(li, 4), 'INDEX:') then
call err 'bad begin' wMod readNxPos(nx)
wTb = 'i'substr(word(li, 4), 7)
end
else
call err 'implement begin' wMod readNxPos(nx)
if 0 then
say wMod '>>' wTb 'in' wTs
call addUtl m, wMod, wTb, wTs
return
endProcedure countAnaBeg
addObj: procedure expose m.
parse arg m, ob, pa
vv = mapGet(m'.OBJ', ob, pa)
if word(vv, 1) = '?' then
vv = pa subword(vv, 2)
else if pa \== '?' & word(vv, 1) \== pa then
call err obj 'parent old =' vv '\==' pa
call mapPut m'.OBJ', ob, vv
pb = word(vv, 1)
if pb == '?' then
return
call addObj m, pb, '?'
ch = mapGet(m'.OBJ', pb)
if wordPos(ob, ch) < 1 then
call mapPut m'.OBJ', pb, ch ob
return
endProcedure addObj
addUtl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.UTL', ob, mapGet(m'.UTL', ob, '') fun
return
endProcedure addUtl
addDDl: procedure expose m.
parse arg m, fun, ob, pa
call addObj m, ob, pa
call mapPut m'.DDL', ob, mapGet(m'.DDL', ob, '') fun
return
endProcedure addDDl
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.MLEM43
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 = 'DP4G DBOL'
m.ii_rzDbCsmF = 'RZ2/DVBP RR2/DVBP' /* 'RQ2/DVBP' */ ,
'RZZ/DEVG RZY/DEVG RZX/DEVG'
m.ii_rzDbCsmT = 'S25/DVBP R25/DVBP' /* 'Q25/DVBP' */ ,
'Z25/DEVG Y25/DEVG X25/DEVG'
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))
iiRz2Sys: procedure expose m.
parse arg rz
return iiGet(rz2sys, rz)
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiPut:procedure expose m.
parse upper arg rz '/' db
rz = strip(rz)
db = strip(db)
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
if db <> '' then do
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
end
return 1
endProcedure iiPut
iiIxPut:procedure expose m.
parse arg ix
call iiIni
if ix > words(m.ii_rzDb) then
return 0
else
return iiPut(word(m.ii_rzDb, ix))
endProcedure iiIxPut
ii2RzDb:procedure expose m.
parse arg a, forCsm
r = ii2rzDbS(a, forCsm)
if r \== '' then
return r
else
return err('i}no rz/dbSys for' a)
ii2RzDbS:procedure expose m.
parse upper arg a, forCsm
if pos('/', a) > 0 then
parse var a r '/' d
else if length(a) == 2 then
parse var a r 2 d
else
parse var a d r
myRz = sysvar(sysnode)
call iiIni
if r == '' then
r2 = myRz
else if length(r) <> 1 then
r2 = r
else do
r2 = iiGet(plex2rz, r, '^')
if r2 == '' then
r2 = iiGet(c2rz, r, '^')
end
if length(d) == 4 then
d2 = d
else do
if symbol('m.ii_rz2db.r2') \== 'VAR' then
return ''
if d == '' then do
if myRz == 'RZ4' then
d2 = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
d2 = 'DX0G'
else
return ''
end
else do
x = pos(d, m.ii_rz2db.r2)
if x < 1 then
return ''
d2 = substr(m.ii_rz2db.r2,
, lastPos(' ', m.ii_rz2db.r2, x)+1,4)
end
end
if r2 = myRz then
return '*/'d2
res = translate(r2'/'d2)
if forCsm \==1 | wordPos(res, m.ii_rzDbCsmF) < 1 then
return res
else
return word(m.ii_rzDbCsmT, wordPos(res, m.ii_rzDbCsmF))
endProcedure ii2RzDbS
/* copy ii end ********* Installation Info *************************/
/* copy dsnList begin *************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search -------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names ------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise -----------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED*/
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' | vo = 'MIGRAT' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- check if a dataset is archive -----------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise -----------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- dsnList: csi or csm to stem -----------------------------------*/
dsnList: procedure expose m.
parse arg oo, aMsk, rzPref
parse value dsnCsmSys(aMsk) with rz '/' msk
if msk \== '' & right(msk, 1) \== ' ' ,
& pos('*', msk) < 1 & length(msk) < 42 then
msk = msk'.**'
if rz == '*' then do
call csiOpen dsnList_csi, msk
do ox=1 while csiNext(dsnList_csi, oo'.'ox)
end
end
else do
pre = copies(rz'/', rzPref \== 0)
call adrCsm 'dslist system('rz') dsnMask('msk') short', 4
do ox=1 to stemSize
m.oo.ox = pre || dsName.ox
end
end
m.oo.0 = ox-1
return m.oo.0
endProcedure dsnList
/*--- mbrList with listDS or csm to stem ----------------------------*/
mbrList: procedure expose m.
parse arg m, pds
parse value dsnCsmSys(translate(dsn2jcl(pds))) with sys '/' dsn
msk = strip(dsnGetMbr(dsn))
if msk == '*' then
msk = ''
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmMbrList(m, sys, dsn, msk)
if adrTso(listDS "'"dsn"'" members, 8) <> 0 then
mx = -99
else if m.tso_trap.1 <> dsn then
call err 'mbrList dsn='dsn '<> trap.1='m.tso_trap.1
else if m.tso_trap.2 <> '--RECFM-LRECL-BLKSIZE-DSORG' then
call err 'mbrList dsn='dsn 'trap.2='m.tso_trap.2
else do
parse var m.tso_trap.3 ,
m.m.RECFM m.m.LRECL m.m.BLKSIZE m.m.DSORG .
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=4 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx + 1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
if \ mFound then
mx = -98
end
m.m.0 = mx
return mx
endProcedure mbrList
/*--- return whether a dsn exists -----------------------------------*/
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) <> '' then
return csmMbrList(tso_dsnExits, rz, dsnSetMbr(dsn) ,
, dsnGetMbr(dsn)) == 1
else do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
endProcedure dsnExists
/*--- copy members / datasets ---------------------------------------
fr, to from or to dsn with or without member
mbrs: space separated list of mbr or old>new
opts
* all members from lib to lib
& members as defined in mbrs argument
- sequentiel (or library WITH member)
*- if * fails then do - from fr to to
&- if & fails then do - from fr(mbr) to to
---------------------------------------------------------------------*/
dsnCopy: procedure expose m.
parse upper arg fr opt . , to toPl, mbrs
op1 = '?'
if opt \== '' then do
parse upper arg opt fr .
if pos(left(opt, 1), 'WTC?') > 0 then
parse var opt op1 2 opt
end
if opt == '-' then do
if mbrs \== '' then
call err 'op1 - but mbrs not empty' mbrs
end
else do
fMb = dsnGetMbr(fr)
fr = dsn2jcl(dsnSetMbr(fr))
tMb = dsnGetMbr(to)
to = dsn2jcl(dsnSetMbr(to))
if mbrs = '' then
if fMb = '' then
to = dsnSetMbr(to, tMb)
else if tMb = '' then
mbrs = fMb
else
mbrs = fMb'>'tMb
else if fMb \== '' | tMb \== '' then
call err 'fr='fr 'to='to 'but with mbrs='mbrs
if mbrs = '' then
o2 = left('*', tMb = '')'-'
else if words(mbrs) = 1 & pos('>', mbrs) < 1 then
o2 = if(verify(mbrs, '*?', 'm') > 0, '*', '&')'-'
else
o2 = '&'
if opt == '' then
opt = o2
else if pos(opt, o2) == 0 then
call 'bad opt' opt 'not in' o2
end
if abbrev(opt, '*') then do
mbrs = ''
do mx=1 to mbrList(tso_dsnCopy, fr'('fMb')')
mbrs = mbrs m.tso_dsnCopy.mx
end
if m.tso_dsnCopy.0 > 0 then
opt = '&'
else if m.tso_dsnCopy.0 = 0 then do
say 'nothing copied, no members in' fr
return
end
else if substr(opt, 2, 1) == '-' then
opt = '-'
else
return err(fr 'is not a library')
end
/* currently we use csm, which calls IBM Utilities
for us, which seems not to be easy do to directly */
if op1 == 'C' | op1 == '?' then do
r = csmCop2(op1 opt, fr, to toPl, mbrs)
if datatype(r, 'n') then
return r
op1 = r
end
if op1 == 'W' | op1 == 'T' then /* use read and write,
allows reformatting */
return dsnCopW(op1 opt, fr, to toPl, mbrs)
call err 'dsnCopy bad opt' op1 opt
endProcedure dsnCopy
dsnCopW: procedure expose m. i.
parse arg o1 o2, fr, to tPl, mbrs
if words(mbrs) > 1 then do
do mx=1 to words(mbrs)
call dsnCopW o1 o2, fr, to tPl, word(mbrs, mx)
end
return words(mbrs)
end
parse var tPl tA1 ':' tA2
if \ abbrev(o2, '&') then do
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
else do
parse value strip(mbrs) with fMb '>' tMb
fr = dsnSetMbr(fr, fMb)
parse value dsnAlloc(fr, , 'readDD') with fDD fFr
tAt = strip(tA1 ':'firstNS(tA2, ':D'fDD))
to = dsnSetMbr(to, firstNS(tMb, fMb))
parse value dsnCsmSys(to) with rz '/' .
if o2 = '&-' & rz == '*' then do
r2 = sysDsn("'"to"'")
if r2 == 'OK' | r2 == 'MEMBER NOT FOUND' ,
| r2 == 'DATASET NOT FOUND' then
nop
else if r2 ,
== 'MEMBER SPECIFIED, BUT DATASET IS NOT PARTITIONED' then
to = dsnSetMbr(to)
else
call err 'sysDsn(to='to')' r2
end
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
if o2 = '&-' & rz \== '*' then do
if m.tso_dsorg.tDD <> 'PO' then do
call tsoFree tFr
to = dsnSetMbr(to)
parse value dsnAlloc(to tAt, , 'writeDD') with tDD tFr
end
end
end
cnt = 0
trunc = 0
do while readDD(fDD, i., 500)
cnt = cnt + i.0
call writeDD tDD, i., , o1 == 'T'
if m.tso_rc then
trunc = 1
end
call tsoClose fDD
if cnt = 0 then
call tsoOpen tDD, 'W'
call tsoClose tDD
call tsoFree fFr tFr
say 'copied' cnt 'recs from' fr 'to' to copies('truncation',trunc)
return cnt
endProcedure dsnCopW
dsnDel: procedure expose m.
parse upper arg aDsn, aMbrs
parse value dsnCsmSys(dsn2jcl(aDsn)) with sys '/' dsn
mbrs = dsnGetMbr(dsn) aMbrs
dsn = dsnSetMbr(dsn)
if sys \== '*' then
return csmDel(sys, dsn, mbrs)
if mbrs = '' then do
dRc = adrTso("delete '"dsn"'", 8)
end
else do
call dsnAlloc 'dd(deldd)' dsn
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrTso("delete '"dsn"("m1")' file(delDD)", 8)
if dRc <> 0 then do
if pos('IDC3330I **' m1' ', m.tso_trap) < 1 then
leave
say 'member not found and not deleted:' dsn'('m1')'
dRc = 0
end
end
call tsoFree deldd
end
if dRc = 0 then
return 0
if pos('IDC3012I ENTRY' dsn 'NOT FO', m.tso_trap) >= 1 then do
say 'dsn not found and not deleted:' dsn
return 4
end
call err 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return 8
endProcedure dsnDel
/* copy dsnList end ************************************************/
/* copy match begin **************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ---------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end ****************************************************/
/* copy scan begin ************************************************
Achtung: inc generiert SB aus scan, Aenderungen nur in scan|
SB = scanBasic: single line, no reader, no newLines, class not needed
scanSrc(m, source) starts scanning a single line = scanBasic
scanLook(m,len) : returns next len chars, pos is not moved
scanChar(m,len) : scans next len chars
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanEnd(m) : returns whether we reached end of input
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
ScanNat(m) : scan a natural number (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanVerify(m,c,o): verify(...,c,o,...)
scanKeyValue(m): scan a key = value clause (with spaces)
scanWord(m,st,uc) : scan a space delimited word or a string,
st=stopper, if u=1 then uppercase non-strings
scanSpace(m) : skips over spaces (and nl and comment if \ basic
scanInfo(m) : text of current scan location
scanErr(m, txt): error with current scan location
m is an address, to store our state
returns: true if scanned, false otherwise
if a scan function succeeds, the scan position is moved
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
/*--- start basic scannig: set new src, reset outFields -------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 1
return m
endProcedure scanSrc
scanBasic: procedure expose m.
parse arg src
if symbol('m.scan.0') == 'VAR' then
m.scan.0 = m.scan.0 + 1
else
m.scan.0 = 1
return scanSrc('SCAN.'m.scan.0, src)
endProcedure scanBasic
scanEr3: procedure expose m.
parse arg m, txt, info
return err('s}'txt'\n'info)
scanErr: procedure expose m.
parse arg m, txt
if arg() > 2 then
return err(m,'old interface scanErr('m',' txt',' arg(3)')')
return scanEr3(m, txt, scanInfo(m))
/*--- scanInfo: text of current scan position for scanErr -----------*/
scanInfo: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSBInfo(m)
else
interpret objMet(m, 'scanInfo')
endProcedure scanInfo
scanSBInfo: procedure expose m.
parse arg m
return 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't') ,
|| '\npos' m.m.Pos 'in string' strip(m.m.src, 't')
/*--- return the next len characters until end of src ---------------*/
scanLook: procedure expose m.
parse arg m, len
if len == '' then
return substr(m.m.src, m.m.pos)
else
return substr(m.m.src, m.m.pos,
, min(len, 1 + length(m.m.src) - m.m.pos))
endProcedure scanLook
/*--- scan len chararcters, atmost to end of src --------------------*/
scanChar: procedure expose m.
parse arg m, len
m.m.tok = scanLook(m, len)
m.m.pos = m.m.pos + length(m.m.tok)
return m.m.tok \== ''
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m
do ax=2 to arg()
if abbrev(substr(m.m.src, m.m.pos), arg(ax)) then do
m.m.tok = arg(ax)
m.m.pos = m.m.pos + length(arg(ax))
return 1
end
end
m.m.tok = ''
return 0
endProcedure scanLit
/*--- scan with verify, vOpt is passed to verify --------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt
if vOpt == '' then /* empty string does not take default */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanVerify
/*--- scan while in charset -----------------------------------------*/
scanWhile: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'n')
/*--- scan until in charset -----------------------------------------*/
scanUntil: procedure expose m.
parse arg m, chSet
return scanVerify(m, chSet, 'm')
/*--- scan until (and over) string End ------------------------------*/
scanStrEnd: procedure expose m.
parse arg m, sep
sx = m.m.pos
bx = sx
do forever
ex = pos(sep, m.m.src, sx)
if ex = 0 then do
m.m.val = m.m.val || substr(m.m.src, bx)
return 0
end
m.m.val = m.m.val || substr(m.m.src, bx, ex-bx)
bx = ex + length(sep)
if \ abbrev(substr(m.m.src, bx), sep) then do
m.m.tok = m.m.tok || substr(m.m.src, m.m.pos, bx-m.m.pos)
m.m.pos = bx
return 1
end
sx = bx + length(sep)
end
endProcedure scanStrEnd
/*--- scan a string with quote char qu ------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
if prefs = '' then do
call scanLit m, "'", '"'
end
else do
do px=1 to words(prefs) until scanLit(m, word(prefs, px))
end
end
if m.m.tok == '' then
return 0
m.m.val = ''
if \ scanStrEnd(m, m.m.tok) then
return scanErr(m, 'ending Apostroph missing')
return 1
endProcedure scanString
/*--- scan a word and put value into *.val
a word is either delimited by space or stopper
or a string (with single or double quotes ------*/
scanWord: procedure expose m.
parse arg m, stopper, ucWord
if scanString(m) then
return 1
if stopper == '' then
stopper = m.ut_space
if \scanUntil(m, stopper) then
return 0
if ucWord == 1 then
m.m.val = translate(m.m.tok)
else
m.m.val = m.m.tok
return 1
endProcedure scanWord
/*--- skip, scan and return word or scanErr -------------------------*/
scanRetWord: procedure expose m.
parse arg m, stopper, ucWord, eWhat
if scanWord(scanSKip(m), stopper, ucWord) then
return m.m.val
else
return scanErr(m, eWhat 'expected')
endProcedure scanRetWord
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def, uc
if \ scanWord(m, ' =''"') then
return 0
m.m.key = m.m.val
if \ scanLit(scanSkip(m), '=') then
m.m.val = def
else if \ scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
if uc == 1 then
upper m.m.key m.m.val
return 1
endProcedure scanKeyValue
/*--- scan over space, nl, comments ---------------------------------*/
scanSpace: procedure expose m.
parse arg m
if m.m.scanIsBasic then
return scanSpaceOnly(m)
else
return scanSpNlCo(m)
endProcedure scanSpace
scanSpaceOnly: procedure expose m.
parse arg m
nx = verify(m.m.src, m.ut_space, , m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = left(' ', nx <> m.m.pos)
m.m.pos = nx
return m.m.tok == ' '
endProcedure scanSpaceOnly
/*--- skip over space and return m ----------------------------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpace m
return m
endProcedure scanSkip
/*--- return true if at end of src ----------------------------------*/
scanEnd: procedure expose m.
parse arg m
if m.m.pos <= length(m.m.src) then
return 0
else if m.m.scanIsBasic then
return 1
else
return m.m.atEnd
endProcedure scanEnd
/*--- scan a natural number (no sign, decpoint ...) Ignore After ----*/
scanNatIA: procedure expose m.
parse arg m
return scanVerify(m, '0123456789')
/*--- scan an integer (optional sign, no decpoint ...) Ignore After -*/
scanIntIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
if \ scanNatIA(m) then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, m.m.pos - poX)
return 1
endProcedure scanIntIA
/*--- scanOpt set the valid characters for names, and comments
it must be called
before any of the following functions ---------------------*/
scanOpt: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment, nest
if m.m.scanName1 == '' then
m.m.scanName1 = m.ut_alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
m.m.scanNestCom = nest == 1
return m
endProcedure scanOpt
/*--- return true if at comment -------------------------------------*/
scanSBCom: procedure expose m.
parse arg m
m.m.tok = ''
if m.m.scanComment == '' then
return 0
if \ abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then
return 0
m.m.tok = substr(m.m.src, m.m.pos)
m.m.pos = 1 + length(m.m.src)
return 1
endProcedure scanSBCom
/*--- scan a Name, first char in *.scanName1, rest in *.scanNameR ---*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.m.src, m.m.pos, 1),
, m.m.scanName1) <= 0 then do
m.m.tok = ''
return 0
end
return scanVerify(m, m.m.scanNameR)
endProcedure scanName
/*--- check character after a number
must not be Identifier or plus ----------------------------*/
scanCheckNumAfter: procedure expose m.
parse arg m, res, plus
if \ res then
return 0
if pos(substr(m.m.src, m.m.pos, 1), m.m.scanNameR || plus) > 0 then
call scanErr m, 'illegal char after number' m.m.tok
return 1
endProcedure scanCheckNumAfter
/*--- scan a natural number check character after -------------------*/
scanNat: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNat') / 0
return scanCheckNumAfter(m, scanNatIA(m), '.')
endProcedure ScanNat
/*--- scan an Integer check character after -------------------------*/
scanInt: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanInt') / 0
return scanCheckNumAfter(m, scanIntIA(m), '.')
endProcedure ScanInt
/*--- scan a Number check character after ---------------------------*/
scanNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanNum') / 0
return scanCheckNumAfter(m, scanNumIA(m))
endProcedure ScanInt
/*--- scan a number (optional sign, decpoint, exponent) Ignore After-*/
scanNumIA: procedure expose m.
parse arg m
poX = m.m.pos
call scanLit m, '-', '+'
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.pos = poX
return 0
end
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanNumIA
/*--- scan unsigned number (opt. decpoint, exponent) Ignore After ---*/
scanNumUSPos: procedure expose m.
parse arg m
poX = m.m.pos
cx = verify(m.m.src, '0123456789', , poX)
if cx > 0 then
if substr(m.m.src, cx, 1) == '.' then
cx = verify(m.m.src, '0123456789', , cx+1)
if cx < 1 then do
if abbrev('.', substr(m.m.src, poX)) then
return 0
end
else if abbrev('.', substr(m.m.src, poX, cx-poX)) then do
return 0
end
else if pos(substr(m.m.src, cx, 1), 'eE') > 0 then do
cy = cx + 1 + (pos(substr(m.m.src, cx+1, 1), '-+') > 0)
cx = verify(m.m.src, '0123456789', , cy)
if cx==cy | (cx == 0 & cy > length(m.s.src)) then
call scanErr m, 'exponent expected after E'
end
if cx >= poX then
return cx
else
return length(m.s.src)+1
/*
m.m.tok = substr(m.m.src, poX, cx-poX)
m.m.pos = cx
end
else do
m.m.tok = substr(m.m.src, poX)
m.m.pos = length(m.s.src)+1
end
m.m.val = translate(m.m.tok)
return 1 */
endProcedure scanNumUSPos
scanType: procedure expose m.
parse arg m, opt
m.m.tok = ''
if scanName(m) then
m.m.type = 'n'
else if scanNum(m) then
m.m.type = 0
else if scanString(m) then
m.m.type = left(m.m.tok, 1)
else if scanSpace(m) then
m.m.type = 's'
else do
call scanChar m, 1
m.m.type = m.m.tok
end
return m.m.type
endProcedure scanType
/* copy scan end *************************************************/
/* copy csm begin *****************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
**********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
return csmEx2('csmExec' arg(1), arg(2))
/*--- execute a single csmAppc start command
arg(1)=pgm, arg(2)=parm, arg(3)=rest, arg(4)=retOk ------------*/
csmAppc:
appc_rc = 0 /* csmAppc erstellt diese Variable nicht immmer| */
appc_msg.0 = 0
if 0 <> csmEx2('csmAppc start pgm('arg(1)')' ,
copies("parm("quote(arg(2), "'")")",
, arg(2) <> '') arg(3) , arg(4)) then
ggRc = m.tso_rc
else if appc_rc = 0 then
return 0
else do
ggRc = appc_rc
m.csm_err = ''
m.csm_errMsg = 'tso_rc=0'
end
ggMsg = 'csmAppc rc='ggRc 'appc_rc='appc_rc ,
'reason='appc_reason 'state_c='appc_state_c appc_state_f ,
'\n SUBSYS_TSR15='subsys_tsr15 'tsRc='SUBSYS_TSRC ,
'abend='subsys_tsAbend 'reason='subsys_tsReason
do ggCsmIx=1 to appc_msg.0
ggMsg = ggMsg '\n ' appc_msg.ggCsmIx
end
m.csm_errMsg = ggMsg'\n'm.csm_errMsg
return ggRc
endRoutine csmAppc
/*--- execute single command in arg(1) -----------------------------*/
csmEx2:
if wordPos(translate(word(arg(1), 2)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if pos('TIMEOUT(' , translate(arg(1))) > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso(arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS*/
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else if pos('CSMAP47E TP timed out', m.tso_trap) > 0 then
m.csm_err = 'timeout'
else
m.csm_err = ''
m.csm_errMsg = strip('csm' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='m.tso_stmt m.tso_trap ,
'\ntime='ggStart '-' time()
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err m.csm_errMsg
return m.tso_rc
endRoutine csmEx2
csmDel: procedure expose m.
parse upper arg rz, dsn, aMbrs
mbrs = dsnGetMbr(dsn) aMbrs
lib = dsnSetMbr(dsn)
dd = tsoDD(csmDel, 'a')
if mbrs = '' then do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(del) ddname("dd")", 8)
end
else do
dRc = adrCsm("allocate system("rz") dataset('"lib"')" ,
"disp(shr) ddname("dd")", 8)
if dRc == 0 then do
do mx=1 to words(mbrs)
m1 = word(mbrs, mx)
dRc = adrCsm("mDelete ddName("dd") member("m1")", 8)
if dRc <> 0 then do
if pos('CSMEX77E Member:'m1 'not f', m.tso_trap) ,
< 1 then
leave
say 'member not found, not deleted:' rz'/'dsn'('m1')'
dRc = 0
end
end
end
end
if dRc = 0 then
return tsoFree(dd)
if pos('CSMSV29E DATA SET' lib 'NOT IN CAT', m.tso_trap) >0 then do
say 'dsn not found and not deleted:' rz'/'dsn
call tsoFree dd
return 4
end
eMsg = 'rc='m.tso_rc 'stmt='m.tso_stmt':' m.tso_trap
call tsoFree dd
return err('csmDel' eMsg)
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ---------------------------------------------*/
csmCopy: procedure expose m.
parse upper arg fr, to, mbrs
say 'please use dsnCopy instead of depreceated csmCopy'
return dsnCopy(fr, to, mbrs)
csmCop2: procedure expose m.
parse upper arg o1 o2, fr, to tA1 ':' tA2, mbrs
frDD = tsoDD('csmFrDD', 'a')
tAt = strip(tA1 firstNS(tA2, ':D'frDD))
toDD = tsoDD('csmToDD', 'a')
mbr1 = abbrev(o2, '&') & words(mbrs) = 1
if mbr1 then do
parse value strip(mbrs) with fMb '>' tMb
call csmAlloc fr'('fMb')', frDD, 'shr'
tM2 = firstNS(tMb, copies(fMb, o2 <> '&-'))
call csmAlloc dsnSetMbr(to, tM2), toDD, 'shr', , tAt
end
else do
call csmAlloc fr, frDD, 'shr'
call csmAlloc to, toDD, 'shr', , tAt
end
if m.tso_recFM.frDD <> m.tso_recFM.toDD ,
| m.tso_lRecL.frDD <> m.tso_lRecL.toDD then do
call tsoFree frDD toDD
return if(m.tso_lRecL.frDD <= m.tso_lRecL.toDD, 'W', 'T')
end
inDD = tsoDD('csmInDD', 'a')
i.0 = 0
if abbrev(o2, '&') & \ mbr1 then do
i.0 = words(mbrs)
do mx=1 to i.0
parse value word(mbrs, mx) with mF '>' mT
if mF = '' then
call err 'bad mbr or mbrOld>mbrNew' word(mbrs, mx),
'in csmCopy('fr',' to','mbrs')'
else if mT = '' then
i.mx = ' S M='mF
else
i.mx = ' S M=(('mF','mT'))'
end
end
if i.0 <= 0 then do
call adrTso 'alloc dd('inDD') dummy'
end
else do
call tsoAlloc ,inDD, 'NEW', , ':F'
call writeDD inDD, 'I.', i.0
call tsoCLose inDD
end
outDD = tsoDD('csmOuDD', 'a')
call dsnAlloc('dd('outDD') new ::V137')
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg sysDsn, dd, disp, rest, nn, retRc
upper dd disp
parse value dsnCsmSys(sysDsn) with sys '/' dsn
m.tso_dsn.dd = sys'/'dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
isNew = wordPos(disp, 'NEW MOD CAT') > 0
if isNew & nn \== '' then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
recFm = substr(rest, cx+6, 1)
cy = pos(')', rest, cx)
if cy > cx then
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6),
, 0) || substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then
rest = insert('inder', rest, cx+2)
if isNew then
if pos(' BLKSIZE(', ' 'translate(rest)) <= 0 then do
/* without blkSize csm will fail to read for rec < 272 */
cx = pos(' LRECL(', ' 'translate(rest))
lrecl = substr(rest, cx+6,
, max(0, pos(')', rest, cx+6) - cx - 6))
blk = 32760
if datatype(lRecl ,'n') & translate(recfm) = 'F' then
blk = blk - blk // lRecL
rest = rest 'blkSize('blk')'
end
noRetry = retRc <> '' | isNew | nn == ''
alRc = adrCsm('allocate' a1 rest, if(noRetry, retRc, '*'))
m.tso_dsorg.dd = subsys_dsOrg
m.tso_recFM.dd = subsys_recFM
m.tso_blkSize.dd = subsys_blkSize
m.tso_lRecL.dd = subsys_lRecL
if alRc = 0 then
return 0
m.tso_dsnNF.dd = pos('CSMSV29E DATA SET' dsnSetMbr(dsn) ,
'NOT IN CATALOG', m.tso_trap) > 0
if noRetry | \ m.tso_dsnNF.dd then
if pos('*', retRc) > 0 | wordPos(alRc, retRc) > 0 then
return alRc
else
return err(m.csm_errMsg)
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc sysDsn, dd, 'CAT', rest ,nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('fUnit2I('b', tracksused.1) ,
|| ',' fUnit2I('b', tracks.1)') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
csmMbrList: procedure expose m.
parse arg m, sys, dsn, msk
/* attention mbrList dataset(....)
does not cleanup proberly if dsn is NOT PO
and much later on follow errors appear
which are hard to debug| */
if dataType(dsnAlloc(sys'/'dsn, , mbrLisDD, 8), 'n') then do
say sys dsn
say m.tso_trap
m.m.dsnNF = m.tso_dsnNF.mbrLisDD
if \ m.m.dsnNF then
call err m.csm_errMsg
m.m.0 = -99
end
else do
m.m.dsnNF = 0
m.m.RECFM = m.tso_RECFM.mbrLisDD
m.m.LRECL = m.tso_LRECL.mbrLisDD
m.m.BLKSIZE = m.tso_BLKSIZE.mbrLisDD
m.m.DSORG = m.tso_DSORG.mbrLisDD
if m.m.DSORG \== 'PO' then
m.m.0 = -98
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
call adrCsm "mbrList ddName(mbrLisDD)" msk ,
"index(' ') short"
m.m.0 = mbr_name.0
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
end
call tsoFree mbrLisDD
end
return m.m.0
endProcedure csmMbrList
/*--- 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
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, cmd, keepTsPrt, retOk
do cx=1 to (length(cmd)-1) % 68 /* split tso cmd in linews */
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.tsPrt new dd(rmTsPrt) rmtDdn(sysTsPrt)",
"::v"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
m.csm_exRxMsg = ''
m.csm_exRxRc = csmappc("csmexec" ,
, "select tsocmd('csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc')", , "*")
if m.csm_exRxRc <> 0 then do /* handle csm error */
call readDD 'rmTsPrt', 'M.CSM_TSPRT.', '*'
call tsoClose rmTsPrt
msg = '\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines begin ', 79, '-')
do lx=1 to min(100, m.csm_tsPrt.0)
msg = msg'\n'strip(m.csm_tsPrt.lx, 't')
end
l2 = max(lx, m.csm_tsPrt.0-99)
if l2 > lx then
msg = msg'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines' l2 'to' m.csm_tsPrt.0, 79, '-')
do lx=l2 to m.csm_tsPrt.0
msg = msg'\n'strip(m, m.csm_tsPrt.lx, 't')
end
m.csm_exRxMsg = 'cmsExRx rc='ggRc m.csm_errMsg || msg ,
'\n'left('remote sysTsPrt' ,
m.csm_tsprt.0 'lines end ', 79, '-')
/* call sayNl m.csm_exRxMsg */
end
call tsoFree rmSyPro rmtSys rmtsIn copies(rmTsPrt, keepTsPrt\==1)
if pos(m.csm_exRxRc, 0 4) < 1 then do /* handle csm error */
if pos('*', retOk) > 0 | wordPos(m.csm_exRxRc, retOk) > 0 then
call sayNl m.csm_exRxMsg
else
call err m.csm_exRxMsg
end
return m.csm_exRxRc
endProcedure csmExRx
csmExWsh: procedure expose m.
parse arg rz, rdr, opt
w = oNew(m.class_csmExWsh, rz, rdr, opt)
call pipeWriteAll w
return
csmExWshOpen: procedure expose m.
parse arg m, opt
rz = m.m.rz
if opt \== '<' then
call err 'csmExWshOpen('opt') not read'
a1 = dsnAlloc(rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v",,, '*')
if datatype(a1, 'n') then do
call sayNl 'adrTso rc='a1 'stmt='m.tso_stmt m.tso_trap
say 'trying to free'
call tsoFree 'rmtSys rmTsPrt rmTsIn rmSyPro rmtWsh rmtOut'
call dsnAlloc rz"/tmp.wsh new dd(rmtWsh) rmtDdn(wsh) ::v"
end
wsh = jOpen(file('dd(rmtWsh)'), '>')
call jWriteNow wsh, in2file(m.m.rdr)
call jClose wsh
parse var m.m.wOpt oOpt wSpec
if wSpec = '' then
wSpec = '@'
o2 = firstNS(oOpt, 'v')
if oOpt == 'e' then do
o2 = 'v'
wSpec = '$#outFmt e $#'wSpec
end
if o2 == 'p' then do
fo = file('dd(rmTsPrt)')
end
else do
call dsnAlloc rz"/tmp.out new dd(rmtOut) rmtDdn(out) ::"o2
fo = file('dd(rmtOut)')
end
if oOpt == 'e' then
m.m.deleg = csvIntRdr(csvF2VRdr(fo))
else
m.m.deleg = fo
say 'cmsExWsh sending to' rz wSpec
if abbrev(m.myLib, A540769) then
m.m.exRxRc = csmExRx(rz, m.myLib, m.myWsh wSpec,
, o2 == 'p' , '*')
else
m.m.exRxRc = csmExRx(rz, 'DSN.DB2.EXEC', 'WSH' wSpec,
, o2 == 'p' , '*')
call tsoFree 'rmtWsh'
call jOpen m.m.deleg, opt
m.fo.free = m.fo.dd
return m
endProcedure csmExWshOpen
csmIni: procedure expose m.
if m.csm_ini == 1 then
return
m.csm_ini = 1
call catIni
call classNew 'n CsmExWsh u JRWDeleg', 'm' ,
, "jReset m.m.deleg = ''; m.m.rz = arg; m.m.rdr = arg2" ,
"; m.m.wOpt = arg(4)" ,
, "jOpen call csmExWshOpen m, opt" ,
, "jClose call jClose m.m.deleg;" ,
"if pos(m.m.exRxRc,0 4)<1 then call err m.csm_ExRxMsg;",
"else say 'csm execute wsh rc =' m.m.exRxRc"
return
endProcedure csmIni
/* copy csm end ******************************************************/
/* copy sort begin ***************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ***************************************************/
/* copy sqlO begin **************************************************
sql interface mit o und j Anbindung
**********************************************************************/
sqlConClass_R: procedure expose m.
if m.sqlO_ini == 1 then
return m.class_sqlConn
m.sqlO_ini = 1
call sqlIni
call jIni
/* call scanReadIni */
call classNew 'n SqlRdr u JRW', 'm',
, "jReset m.m.sql = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead if \ sqlRdrRead(m, rStem) then return 0"
return classNew('n SqlConn u', 'm',
, "sqlRdr return oNew(m.class_SqlRdr, src, type)" ,
, "sqlsOut return err('no stmts/sqlsOut in conClass_R')")
endProcedure sqlConClass_R
/*--- return a new sqlRdr with sqlSrc from src
type is the class for result, if empty generated --------------*/
sqlRdr: procedure expose m.
parse arg srcRdr, type
src = in2str(srcRdr, ' ')
interpret classMet(m.sql_ConCla, 'sqlRdr')
endProcedure sqlRdr
/*--- execute sql query, generate type and fetchList ----------------*/
sqlRdrOpen: procedure expose m.
parse arg m, opt
src = m.m.sql
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
res = sqlQuery(cx, src, m.m.type)
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
res = sqlQuery(cx, src, mCat(classFlds(m.m.type),' '))
m.sql.cx.fetchClass = m.m.type
end
if res >= 0 then
return sqlRdrO2(m)
call sqlFreeCursor cx
return res
endProcedure sqlRdrOpen
sqlRdrOpenSrc: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpenSrc('m',' opt')'
m.m.srcTxt = in2str(m.m.src, ' ')
return m.m.srcTxt
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.fetchCount = ''
return m
endProcedure sqlRdrO2
/*--- generate class for fetched objects, if necessary --------------*/
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
/*--- read next from cursor, return as object -----------------------*/
sqlRdrRead: procedure expose m.
parse arg m, rStem
cx = m.m.cursor
if m.sql.cx.fetchcount \== m.m.bufI0 then
call err cx 'fetchCount='m.sql.cx.fetchcount ,
'<> m'.m'.bufI0='m.m.bufI0
do bx=1 to 10
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
leave
end
m.rStem.bx = v
end
m.rStem.0 = bx-1
return bx > 1
endProcedure sqlRdrRead
/*--- close sql Cursor ----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m
cx = m.m.cursor
call sqlClose cx
call sqlFreeCursor cx
m.m.cursor = ''
m.m.fetchCount = m.sql.cx.fetchCount
return m
endProcedure sqlRdrClose
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, m.class_SqlResRdr), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure sqlQuery2Rdr
/*--- select and write all to stdOut --------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return /* do not return fetchCount, writeAll may be delayed| */
endProcedure sqlSel
/* copy sqlO end *************************************************/
/* copy sqlCsm begin *************************************************/
sqlConClass_C: procedure expose m.
if m.sqlCsm_ini == 1 then
return m.class_sqlCsmConn
m.sqlCsm_ini = 1
call sqlConClass_R
call csmIni
call classNew 'n SqlCsmRdr u JRW', 'm',
, "jReset m.m.rzDb=arg; m.m.src=arg2; m.m.type=arg(4)" ,
, "jOpen call sqlCsmRdrOpen m, opt",
, "jClose" ,
, "jRead return 0"
return classNew('n SqlCsmConn u', 'm',
, "sqlRdr return oNew(m.class_SqlCsmRdr" ,
", m.sql_conRzDB, src, type)" ,
, "stmts return err('no stmts in sqlCsm')")
endProcedure sqlConClass_C
/*--- send an sql to csm and handle sqlCode -------------------------*/
sqlCsmExe:
parse arg ggRzDb, sql_query, ggRetOk
parse value dsnCsmSys(ggRzDb) with sql_host '/' sql_db2SSID
sql_query = strip(sql_query) /* csmASqls fails on leading spaces */
call csmAppc 'csmASql', , , 4
if sqlCode = 0 then
return 0
ggSqlStmt = sql_query /* for sqlMsg etc. */
if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))'\nsqlCsmExe' ggRzDb
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset ------------------*/
sqlCsmRdrOpen: procedure expose m.
parse arg m, opt
src = sqlRdrOpenSrc(m, opt)
res = sqlCsmExe(m.m.rzDb, src, 100 retOk)
if res < 0 then
return res
if words(m.m.type) = 1 & \ abbrev(m.m.type, ' ') then
cl = class4name(m.m.type)
else if m.m.type <> '' then
cl = classNew('n* SqlCsm u f%v' m.m.type)
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsApp(vv, SQLDA_REXXNAME.kx)
end
cl = classNew('n* SqlCsm u f%v' vv)
end
ff = classFldD(cl)
if sqlD <> m.ff.0 then
return err('sqlCsmQuery sqlD' sqlD '<>' m.ff.0 'for' ,
className(cl))
do rx=1 to sqlRow#
m.m.buf.rx = m'.BUFD.'rx
call oMutate m'.BUFD.'rx, cl
end
m.m.buf.0 = sqlRow#
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
do rx=1 to sqlRow#
dst = m'.BUFD.'rx || m.ff.kx
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst = m.sqlNull
else
m.dst = value(rxNa'.'rx)
end
end
return 0
endProcedure sqlCsmRdrOpen
/* copy sqlCsm end *************************************************/
/* copy sql begin ****************************************************/
/*** sql.1: basic interface to dsnRexx *******************************/
/*--- initialize sql ------------------------------------------------*/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_rzDb = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
m.sql_retOkDef = m.sql_RetOk
m.sql_cursors = left('', 100)
return 0
endProcedure sqlIni
sqlRetDef: procedure expose m.
m.sql_retOk = m.sql_retOkDef
return
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
if abbrev(ggSqlStmt, 'disCon') | abbrev(ggSqlStmt, 'connec') then
address dsnRexx ggSqlStmt
else
address dsnRexx 'execSql' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
m.sql_errRet = 1
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
if wordPos('ret', m.Sql_retOK) < 1 then
call err ePlus || sqlMsg()
else
call errSay ePlus || sqlMsg()
return sqlCode
endProcedure sqlExec0
/*--- connect to the db2 subsystem sys
cCla = connectionClass
e = rexx local only
r = rexx local only, rdr&objects
s = rexx local only, rdr&objects, stmts (default local)
c = with csmASql , rdr&objects
w = with sqlWsh , rdr&objects, stmts (default remote) ----*/
sqlConnect: procedure expose m.
parse arg sys, cCla
upper sys
if abbrev(sys, '*/') then
sys = substr(sys, 3)
if pos('/', sys) <= 0 then
cCla = firstNS(translate(cCla, 'rs', 'cw'), 's')
else if cCla = '' then
cCla = 'w'
if cCla == 'e' then
m.sql_conCla = 'sql E no connection class'
else
interpret 'm.sql_conCla = sqlConClass_'cCla'(sys, cCla)'
if pos(cCla, 'ers') == 0 then do
m.sql_conRzDB = sys
return
end
call sqlIni /* initialize dsnRexx */
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
if sysvar(sysnode) == 'RZ4' then
sys = 'DP4G'
else if sysvar(sysnode) == 'RZX' then
sys = 'DX0G'
else
call err 'no default dbSys for' sysvar(sysnode)
m.sql_conRzDB = sys
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlConnect
/*--- diconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
m.sql_conCla = ''
m.sql_conRzDb = ''
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlDisconnect
/*--- execute sql thru the dsnRexx interface
check for handled errors, recover from easy errors -------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = '' /* empty error Handler History */
do forever /* for retries */
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode,ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call errSay errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql fail showing haHi or return msgLine ---------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0(ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
/*--- short message for executed sql including count ----------------*/
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
/*** sql.2: error Handler and error Reporting ************************/
/*--- return an sql error message (multiline \n) --------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
/* if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
*/ return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL-7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ---------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message -------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA -----------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars -----*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ---------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before --------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ---------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/*** sql.3: query/update/call interface ******************************/
/*--- reset sql cursor 'c'cx fields ---------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.fetchCount = 0
m.sql.cx.resultSet = ''
m.sql.cx.resultSet.0 = 0
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.var.0 = 0
return sqlResetCrs(cx)
endProcedue sqlReset
sqlResetCrs: procedure expose m.
parse arg cx
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return 0
endProcedue sqlResetCrs
/*--- execute a query from sql, with one resultset ------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQuery
/*--- prepare statement and declare cursor --------------------------*/
sqlPreDec: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlFetchVars cx, feVa
return sqlExec0('declare c'cx 'cursor for s'cx)
endProcedure sqlPreDec
/*--- prepare a query from sql, with one resultset ------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
res = sqlPreDec(cx, src, feVa, retOk)
if res < 0 then
return res
return sqlExec0('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
/*--- open a prepared query -----------------------------------------*/
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false -----------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'm.sql.cx.resultSet ,
'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
m.sql.cx.fetchCount = m.sql.cx.fetchCount + 1
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlFetch
/*--- close cursor 'c'cx --------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
m.sql.cx.sqlClosed = 1
return sqlExec('close c'm.sql.cx.resultSet, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms --------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
parse upper value substr(src, bx) with fun fu2 fu3 .
if fun == 'SET' & \ (fu2=='CURRENT' & left(fu3, 7)=='PACKAGE') ,
then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
vn = strip(substr(w2, 2, ex-2))
if vn = '' then
call err 'bad hostVar in' src
m.sql.cx.Var.0 = 1
m.sql.cx.VarName.1 = vn
abc = 'und so weiter'
trace ?r
src2 = 'set :M.sql.'cx'.var.1' substr(w, ex) subword(src, 3)
src2 = 'set :abc' substr(w, ex) subword(src, 3)
return sqlExec('execute immediate :src2', retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdate
/*-- prepare an update ----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments -------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*--- sql call statement --------------------------------------------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
call sqlReset cx
s = scanSrc(sql_call, src)
if \ scanUntil(s, ' ') | translate(m.s.tok) <> 'CALL' then
call scanErr s, 'no call'
if \ scanUntil(s, '(') then
call scanErr s, 'not ( after call'
prc = strip(m.s.tok)
s2 = ''
call scanLit s, '('
do ax=1
call scanSpaceOnly s
if scanString(s, "'") then do
m.sql.cx.var.ax = m.s.tok
call scanSpaceOnly s
end
else if scanUntil(s, ',)') then
m.sql.cx.var.ax = strip(m.s.tok)
else
call scanErr s, 'value expected in call list'
s2 = s2', :m.sql.'cx'.var.'ax
if scanLit(s, ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, 'missing ,) in call list'
end
m.sql.cx.var.0 = ax
call scanSpaceOnly s
if \ scanEnd(s) then
call scanErr s, 'call does not end after )'
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
res = sqlExec('call' prc'('substr(s2, 3)')', 466 retOk)
say cx 'a1='m.sql.cx.var.1 'a2='m.sql.cx.var.2 'a3='m.sql.cx.var.3
if res \== 466 then
return res
cC = substr(sqlErrMc, lastPos('ff'x, sqlErrMc)+1)
rs = 'SQL.'cx'.RESULTSET'
m.rs = 100+cx
m.rs.0 = cc
m.rs.act = 0
lc = ''
do rx=1 to cc
lc = lc', :m.'rs'.'rx
end
call sqlExec0 'ASSOCIATE LOCATORS ('substr(lc, 3)')' ,
'WITH PROCEDURE' prc
if sqlNextResultSet(cx) then
return 0
else
return err('no resultset')
endProcedure sqlCall
/*--- switch to next resultset, return false if none ----------------*/
sqlNextResultSet: procedure expose m.
parse arg cx
rs = 'SQL.'cx'.RESULTSET'
if m.rs <= 100 | m.rs.act >= m.rs.0 then
return 0
ax = m.rs.act + 1
m.rs.act = ax
call sqlResetCrs cx
call sqlexec0 'allocate c'm.rs 'cursor for result set :m.'rs'.'ax
CALL SQLEXEC0 'DESCRIBE CURSOR :C'm.rs 'INTO :M.SQL.'cx'.D'
call sqlFetchVars cx
return 1
endProcedure sqlNextResultSet
/*-- execute a query, update or call --------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
return sqlCall(cx, src, retOk)
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*--- describe table and return sqlDA -------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names --------------------*/
sqlFetchVars: procedure expose m.
parse arg cx, src, cd
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsApp(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlFetchVars
/*--- append next column name
ensure name is unique and rexx compatible -----------------*/
sqlNiceVarsApp: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsApp
/*--- set one value in a DA, handle nulls ---------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
return sqlExec0('commit')
endProcedure sqlCommit
/*** sql.4: diverse helpers ******************************************/
/*-- fetch all rows to stem and close -------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ---------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close ------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 == 1 then
f2 = sqlFetch(cx, dst'.2')
if f1 >= 0 then
call sqlClose cx
else do
say 'sqlFetch2One sqlCode='f1
call sqlClose cx, '*'
end
if f1 \== 1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 == 1 then
call err 'sqlFetch2One: more than 1 row'
else if f2 \== 0 then
call err 'sqlFetch2One second fetch sqlCode='f2
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ---------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
cx = m.sql_defCurs
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*** sql.5: manage cursors *******************************************/
/*--- 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
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sql_cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sql_cursors
m.sql_cursors = overlay('u', m.sql_cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ---------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sql_cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sql_cursors
m.sql_cursors = overlay(' ', m.sql_cursors, cx)
return
endProcedure sqlFreeCursor
/* copy sql end ****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
**********************************************************************/
jRead: procedure expose m.
parse arg m
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
if \ jReadBuf(m, m'.BUF') then
return 0
ix = 1
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadBuf: procedure expose m.
parse arg m, rStem
interpret objMet(m, 'jRead')
m.m.bufI0 = m.m.bufI0 + m.rStem.0
return m.rStem.0 > 0
endProcedure jReadBuf
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
/*--- read next NonEmpty line ---------------------------------------*/
jReadNE: procedure expose m.
parse arg m
do while jRead(m)
if m.m <> '' then
return 1
end
return 0
endProcedure jReadNE
/*--- read next lines to stem ---------------------------------------*/
jReadSt: procedure expose m.
parse arg m, st
sx = 0
if m.m.readIx >= m.m.buf.0 then do
if jReadBuf(m, st) then
return 1
m.st.0 = 0
return 0
end
do rx = m.m.readIx+1 to m.m.buf.0
sx = sx + 1
m.st.sx = m.m.buf.rx
end
m.m.readIx = m.m.buf.0
m.st.0 = sx
return sx > 0
endProcedure jReadSt
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
call jWriteBuf m
return
endProcedure jWrite
/*--- write the buf to destination ----------------------------------*/
jWriteBuf: procedure expose m.
parse arg m
if \ m.m.jWriting then
return err('jWrite('m') but not opened w')
wStem = m'.BUF'
interpret objMet(m, 'jWriteMax')
return
endProcedure jWriteBuf
jWriteSt: procedure expose m.
parse arg m, qStem
interpret objMet(m, 'jWriteSt')
return
endProcedure jWriteSt
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
if m.rdr.readIx == 1 then do
call jWriteSt m, rdr'.BUF'
m.rdr.readIx = m.rdr.buf.0
end
else
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset0('m')')
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.wriMax = 0
call jCloseSet m
return m
endProcedure jReset0
jCloseSet: procedure expose m.
parse arg m
m.m.jReading = 0
m.m.jWriting = 0
m.m.readIx = 55e55
m.m.bufMax = -55e55
return m
endProcedure jCloseSet
jReset: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oResetNoMut')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
m.m.bufMax = m.m.wriMax
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
/*--- close JRW flush buffer if writing ... -------------------------*/
jClose: procedure expose m.
parse arg m
oUsers = m.m.jUsers
if oUsers = 1 then do
if m.m.jWriting then do
wStem = m'.BUF'
interpret objMet(m, 'jWriteFlu')
end
interpret objMet(m, 'jClose')
call jCloseSet m
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed'
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- force physical close for errCleanup ---------------------------*/
jCloseClean: procedure expose m.
parse arg m
if m.m.jUsers = 0 then
return
m.m.jUsers = 1
return jClose(m)
endProcedure jCloseClean
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = '%##fCatFmt' fmt
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%#0')
end
res = f(f2'%#1', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res || f(f2'%#r')
endProcedure jCatLines
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
m.j.cRead = '<'
m.j.cWri = '>'
m.j.cApp = '>>'
call classIni
am = "call err 'call of abstract method"
cLa= classNew('n JRWLazy u LazyRun', 'm',
, "oReset" m.class_lazyRetMutate,
"'call jReset0 m;' classMet(cl, 'jReset')",
, "jWriteMax return classMet(cl, 'jWrite') '; m.m.buf.0 = 0'" ,
, "jWriteFlu return classMet(cl, 'jWriteMax')",
, "jWriteSt return 'if m.m.buf.0 <> 0" ,
"| m.qStem.0 < m.m.bufMax / 2 then do;" ,
"call mAddSt m''.BUF'', qStem;" ,
"if m.m.buf.0 > m.m.bufMax then do;" ,
"wStem = m''.BUF'';'" ,
"classMet(cl, 'jWriteMax')'; end; end;",
"else do; wStem = qStem;' classMet(cl, 'jWrite') ';end'",
)
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "METHODLAZY" cLa,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' wStem')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
call classNew 'n JRWDelegOC u JRW', 'm',
, "jReset m.m.deleg = arg;" ,
, "jOpen call jOpen m.m.deleg, opt" ,
, "jClose call jClose m.m.deleg"
call classNew 'n JRWDeleg u JRWDelegOC', 'm',
, "jRead if \ jReadSt(m.m.deleg, rStem) then return 0",
, "jWrite call jWriteSt m.m.deleg, wStem" ,
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 do wx=1 to m.wStem.0;say o2Text(m.wStem.wx,157);end",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \=='<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.say = m.j.out
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jReset call jBufReset m, arg, arg2" ,
, "jOpen call jBufOpen m, opt",
, "jRead return 0",
, "jWriteMax call err 'buf overflow'",
, "jWriteFlu ",
, "jWriteSt call mAddSt m'.BUF', qStem" ,
, "jWrite call mAddSt m'.BUF', wStem;" ,
"if m.m.buf.0 > m.m.bufMax then call err 'buf overflow'",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
return
endProcedure jIni
/*--- return a JRW from rdr or in -----------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) --------------*/
jBuf: procedure expose m.
m = oNew(m.class_jBuf) /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jText: write text to deleg ------------------------------------*/
jText: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JText', 'm.m.maxL = arg2' , ,
, 'call mAdd rStem, o2Text($i, m.m.maxL)'),rdr, opt)
jBufReset: procedure expose m.
parse arg m
call oMutate m, m.class_jBuf
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.wriMax = 1e30
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
if opt == m.j.cWri then
m.m.buf.0 = 0
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/*--- lazily create a reader class for 1s protocol ------------------*/
jClassNew1sRdr: procedure expose m.
parse arg cla, reset, op, rd, cls
return classNew('n?' cla 'u JRWDelegOC', 'm',
, 'jReset m.m.delegSp = in2file(arg);' reset ,
, 'jOpen m.m.deleg = in2file(m.m.delegSp);' ,
'call jOpen m.m.deleg, opt;' op ,
, 'jRead if \ jRdr1sRead(m, rStem,' ,
quote(repAll(rd, '$i', 'm.dg.buf.ix'), '"'),
') then return 0' ,
, 'jWrite call jRdr1sWrite m, wStem,' ,
quote(repAll(rd, '$i', 'm.wStem.wx'), '"'),
, 'jClose' cls||left(';', cls <> '') 'call jClose m.m.deleg')
endProcedure jNewClassRdr1s
jRdr1sRead: procedure expose m.
parse arg m, rStem, add1s
m.rStem.0 = 0
dg = m.m.deleg
do while jRead(dg)
do ix = m.dg.readIx to m.dg.buf.0
interpret add1s
end
m.dg.readIx = ix - 1
if m.rStem.0 >= 100 then
return 1
end
return m.rStem.0 > 0
endProcedure jRdr1sRead
jRdr1sWrite: procedure expose m.
parse arg m, wStem, add1s
dg = m.m.deleg
rStem = dg'.BUF'
do wx=1 to m.wStem.0
interpret add1s
end
if m.rStem.0 > m.dg.bufMax then
call jWriteBuf dg
return
endProcedure jRdr1sWrite
/*--- jTalkRdr: say strings, out objects ----------------------------*/
jTalkRdr: procedure expose m.
parse arg rdr, opt
return oNew(jClassNew1sRdr('JTalkRdr', , ,
, "if oKindOfString($i) then say o2string($i);" ,
"else call mAdd rStem, $i"), rdr, opt)
/* copy j end ********************************************************/
/* copy o begin *******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
**********************************************************************/
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
do fx=1 to m.cl.fldd.0
f1 = m || m.cl.fldd.fx
m.f1 = ''
end
return classClearStems(cl, m)
endProcedure classClear
classClearStems: procedure expose m.
parse arg cl, m
do sx=1 to m.cl.stmD.0
s1 = m || m.cl.stmD.sx
m.s1.0 = 0
end
return m
endProcedure classClearStems
classCopy: procedure expose m.
parse arg cl, m, t
do fx=1 to m.cl.fldd.0
ff = m || m.cl.fldd.fx
tf = t || m.cl.fldd.fx
m.tf = m.ff
end
do sx=1 to m.cl.stmD.0
call classCopyStem m.cl.stmD.sx.class,
, m || m.cl.stmD.sx, t || m.cl.stmD.sx
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. ------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value --*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ---------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object --------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then do;
if t = m.class_o then
t = objClass(a)
return outX(p1'done :'className(t) '@'a)
end
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- mutate and reset an object for a class -----------------------*/
oReset: procedure expose m.
parse arg m, cl, arg, arg2
interpret classMet(class4name(cl), 'oReset')
return m
endProcedure oReset
/*--- create an an object of the class cl and reset it --------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2
interpret classMet(class4name(cl), 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
return classInheritsOf(objClass(obj), sup)
/*--- return the code of method met of object m ---------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return true if obj is kind of string -------------------------*/
oKindOfString: procedure expose m.
parse arg obj
return objMet(obj, 'oKindOfString')
/*--- if obj is kindOfString return string
otherwise return arg(2) or fail ---------------------------*/
oAsString: procedure expose m.
parse arg m
interpret objMet(m, 'oAsString')
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oFldD: procedure expose m.
parse arg m
return objMet(m, 'oFldD')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
oCopyGen: procedure expose m.
parse arg cl
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
call classMet cl, 'new'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
endProcedure oCopyGen
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf -----------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return' / 0
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object o=[...] -----*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
/*--- return a short string representation of the fields of an obj --*/
o2TexLR: procedure expose m.
parse arg m, maxL, le, ri
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2TexLR')
endProcedure o2TexLR
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
maxL = maxL - 3
r = ''
do fx=1 to m.cl.fldd.0
c1 = m.cl.fldd.fx.class
r = r || left(' ', fx > 1)substr(m.cl.fldd.fx, 2)
if c1 = m.class_V then
r = r'='
else if m.c1 == 'r' then
r = r'=>'
else
r = r'=?'c1'?'
a1 = m || m.cl.fldd.fx
r = r || m.a1
if length(r) > maxL then
return left(r, maxL)'...'
end
return r
endProcedure o2TextFlds
o2TextGen: procedure expose m.
parse arg cl, le, ri
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextGen' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
if le = '' & ri = '' then
return "return o2TextFlds(m, '"cl"', maxL)"
else
return "return" le "|| o2TextFlds(m, '"cl"'" ,
", maxL - length("le") - length("ri")) || "ri
endProcedure o2TextGen
o2TextStem: procedure expose m.
parse arg st, to, maxL
do sx=1 to m.st.0
m.to.sx = o2Text(m.st.sx, maxL)
end
m.to.0 = m.st.0
return to
endProcedure o2TextStem
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
/* 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),
CLASS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
**********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = ']'
call mapIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "asString return m.m" ,
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "asString return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v', /* method */
, 's r class'
m.class_lazyRetMutate = "return 'call oMutate m, '''cl''';'"
m.class_lazyRoot = classNew('n LazyRoot u', 'm',
, "METHODLAZY" ,
, "f2c call classMet cl, 'oFlds'; return cl'.F2C'" ,
, "f2x call classMet cl, 'oFlds';",
"call mInverse cl'.FLDS', cl'.F2X';" ,
"return cl'.F2X'" ,
, "oFlds call classFldGen cl; return cl'.FLDS'" ,
, "oFldD call classMet cl, 'oFlds'; return cl'.FLDD'" ,
, "o2Text return o2textGen(cl, 'm''=[''', ''']''')",
, "o2TexLR return o2textGen(cl, 'le', 'ri')",
, "s2c call classMet cl, 'oFlds'; return cl'.S2C'" ,
, "stms call classMet cl, 'oFlds'; return cl'.STMS'" ,
, "in2Str return classMet(cl, 'o2String')" ,
, "in2File return classMet(cl, 'o2File')" ,
, "in2Buf return 'return jBufCopy('" ,
"classMetRmRet(cl,'o2File')')'",
, "oKindOfString return classMet(cl, 'asString', '\-\')" ,
"\== '\-\'" ,
, "oAsString if classMet(cl, 'oKindOfString')" ,
"then return classMet(cl, 'asString');",
"else return 'if arg() >= 2 then return arg(2)" ,
"; else return err(m ''is not a kind of string" ,
"but has class' className(cl)''')'" ,
, "o2String return classMet(cl,'asString','\-\')" ,
, "new call mNewArea cl, 'O.'substr(cl,7);" ,
"return 'm = mNew('''cl''');'" ,
"classMet(cl,'oReset')",
)
call classNew 'n= LazyRoot u', 'm',
, "oReset call classMet cl, 'oClear';" m.class_lazyRetMutate,
"'call classClear '''cl''', m;'" ,
, "oResetNoMut return classRmFirstmt(" ,
"classMet(cl, 'oReset'), 'call oMutate ');" ,
, "oClear call classMet cl, 'oFlds'" ,
"; return 'call classClear '''cl''', m'",
, "oCopy return oCopyGen(cl)"
m.class_S = classNew('n String u', 'm',
, 'asString return m' ,
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)')
m.class_N = classNew('n Null u', 'm',
, "asString return ''",
, 'in2Str return o2String(m.j.in, fmt)',
, "o2Text return ''",
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n LazyRun u LazyRoot', 'm',
, "o2Text return 'return m''=['className(cl)']'''"
call classNew 'n ORun u', 'm',
, 'METHODLAZY' m.class_lazyRun,
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)'
call mPut class_inheritMet'.'m.class_V, 0
call mPut class_inheritMet'.'m.class_W, 0
call mPut class_inheritMet'.'m.class_O, 0
call mPut class_inheritMet'.'m.class_S, 0
call mPut class_inheritMet'.'m.class_N, 0
return
endProcedure classIni
/*--- remove first statement if src starts with strt ----------------*/
classRmFirStmt: procedure expose m.
parse arg src, strt
if \ abbrev(src, strt) then
return src
return substr(src, pos(';', src)+2)
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.met = strip(io)
if ty \== 'm' & io <> '' then
call err "io <> '' ty: classNe1("ky")" /0
if ty = 'u' then do
m.n.met = nm
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
end
m.n.name = nm
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = word(refs, rx)
end
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
/* if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6) ??????? */
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
if nmTy == 'n' | nmTy == '?' then do
v = 'CLASS_'translate(nm)
if symbol('m.v') == 'VAR' then
call err 'duplicate class' v
m.v = n
end
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.method.methodLazy') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"met"'"
m.cl.method.met = classMetLazy(m.cl.method.methodLazy, cl, met)
if m.cl.method.met \== '\-\' then
return m.cl.method.met
drop m.cl.method.met
if arg(3) \== '' then
return arg(3)
else
return err('no method' met 'in class' className(cl))
end
if symbol('m.class_n2c.cl') \== 'VAR' then
call err 'no class classMet('cl',' met')'
if cl \== m.class_n2c.cl then
return classMet(m.class_n2c.cl, met)
if m.cl == 'u' then
call classMetGen cl, cl'.'method
if symbol('m.cl.method.methodLazy') \== 'VAR' then
m.cl.method.methodLazy = m.class_lazyRoot
return classMet(cl, met, arg(3))
endProcedure classMet
classMetLazy: procedure expose m.
parse arg build, cl, met
if build = '' then
return '\-\'
cd = classMet(build, met, '\-\')
if abbrev(cd, '?') then
return err('? met' cd 'b='build cl'#'met) / 0
else if cd \== '\-\' then
interpret cd
else
return cd
endProcedure classMetLazy
classMetRmRet: procedure expose m.
parse arg cl, met
cd = classMet(cl, met)
if word(cd, 1) == 'return' then
return subword(cd, 2)
else
return cd
endProcedure classMetRmRet
/*--- generate all methods for a class recursively ------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0 /* methods directly in cl */
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1') == 'VAR' then
nop
else
m.trg.m1 = m.cl.met
end
do cx=1 to m.aC.0 /* inherited methods */
cl = m.aC.cx
if m.cl == 'u' & m.class_inheritMet.cl \== 0 then
call classmetGen cl, trg, pa
end
return
endProcedure classmetGen
classCycle: procedure expose m.
parse arg cl, pa
if wordPos(cl, pa) < 1 then
return pa cl
call err classCycle cl pa / 0
endProcedure classCycle
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
classFldD: procedure expose m.
parse arg cl
return classMet(cl, 'oFldD')
endProcedure classFldD
classFldGen: procedure expose m.
parse arg cl
m.cl.fldS.0 = 0
m.cl.fldS.self = 0
m.cl.fldD.0 = 0
m.cl.stmS.0 = 0
m.cl.stmS.self = 0
m.cl.stmD.0 = 0
return classFldAdd(cl, cl)
endPorcedure classFldGen
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDD', f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMD', f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fd, fs, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
cc = mAdd(fd, left('.', nm \== '')nm)
m.cc.class = cl
if nm == '' then do
m.fs.self = 1
m.fs.self.class = cl
/* call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'.SELF', 1 */
end
else do
cc = mAdd(fs, nm)
m.cc.class = cl
end
return 0
endProcedure classFldAdd1
/* copy class end **************************************************/
/* copy map begin *****************************************************
a map stores values at keys
it may also maintain a list of keys
the basic ideas are similar to the java Interface java.util.Map
contrary to stems we also handle keys longer then 250 bytes
**********************************************************************/
/*--- initialize the module -----------------------------------------*/
mapIni: procedure expose m.
if m.map_ini = 1 then
return
m.map_ini = 1
call mIni
m.map.0 = 0
m.map_inlineSearch = 1
call mapReset map_inlineName, map_inline
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName, opt
if mapHasKey(map_inlineName, pName) then do
im = mapGet(map_inlineName, pName)
if pos('l', opt) < 1 & symbol('m.im.0') \== 'VAR' then do
m.im.0 = m.im.lEnd - m.im.lBegin - 1
do ix=1 to m.im.0
m.im.ix = strip(sourceline(ix+m.im.lBegin), 't')
end
end
return im
end
name = '/'
do lx = m.map_inlineSearch to sourceline()
if \ abbrev(sourceline(lx), '$') then
iterate
li = sourceline(lx)
s1 = pos('/', li)+ 1
if s1 < 3 | s1 > 4 then
iterate
s2 = pos('/', li, s1)
if s2 <= s1 then
iterate
if s1 == 3 then do
if name \== substr(li, s1, s2-s1) then
iterate
im = 'map_inline.' || (m.map_inline.0+1)
call mapAdd map_inlineName, name, im
m.im.lBegin = lBeg
m.im.lEnd = lx
m.im.mark = mrk
if name == pName then do
m.map_inlineSearch = lx+1
return mapInline(pName)
end
name = '/'
end
else if \ mapHasKey(map_inlineName,
, substr(li, s1, s2-s1)) then do
lBeg = lx
mrk = substr(li, 2, s1-3)
name = substr(li, s1, s2-s1)
end
else do
name = '/'
end
end
if pos('r', opt) > 0 then
return ''
return err('no inline data /'pName'/ found')
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
m.map.0 = m.map.0 + 1
return mapReset('MAP.'m.map.0 , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map_keys, '=' in a else in opt) -------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map_keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP_KEYS.'a
else
st = opt
m.map_keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ---------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'a')
if vv == '' then
return err('duplicate in mapAdd('a',' ky',' val')')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value --------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ---------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapAdr(a, ky, 'g') \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ---------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
return err('missing key in mapGet('a',' ky')')
endProcedure mapGet
/*--- return a stem of all keys -------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map_keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map_keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing --------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapAdr(a, ky, 'g')
if vv == '' then
return ''
if m.map_keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map_keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries --------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 247 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) < liLe then do
drop m.a.ky
end
else do
adr = mapAdr(a, ky, 'g')
if adr \== '' then do
ha = left(adr, length(adr) - 2)
do i = 1 to m.ha.0
vv = ha'v'i
drop m.ha.i m.vv
end
drop m.ha.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
f = 'g' return address if exists otherwise ''
'p' return address if exists otherwise newly added address
'a' return '' if exists otherwise newly added address --*/
mapAdr: procedure expose m.
parse arg a, ky, f
if length(ky) + length(a) < 247 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then
return copies(res, f \== 'a')
else if f == 'g' then
return ''
end
else do
len = length(ky)
q = len % 2
ha = a'.'len || left(ky, 80) || substr(ky,
, len % 2 - 40, 85-length(len)-length(a)) || right(ky, 80)
if symbol('M.ha.0') == 'VAR' then do
do i=1 to m.ha.0
if m.ha.i == ky then
return copies(ha'v'i, f \== 'a')
end
end
else do
i = 1
end
if f == 'g' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.0 = i
m.ha.i = ky
res = ha'v'i
end
if m.map_keys.a \== '' then
call mAdd m.map_keys.a, ky
return res
endProcedure mapAdr
/* copy map end ******************************************************/
/* copy mapExp begin *************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ***************************************************/
/* copy m begin *******************************************************
we use variables as follows
m. stem m: all global data and object data that must survive
a procedure call (m for memory in Memoria of B5000)
m.<mbr>.** and m.<mbr>_**: every rexx Module (copy) should only
allocate these addresses to avoid address conficts
with <mbr> the name of therexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
**********************************************************************/
/*---make an area -----*/
mNewArea: procedure expose m.
parse arg nm, adr
ax = m.m_area.0 + 1
m.m_area.0 = ax
m.m_area.ax = nm
if adr == '=' then
adr = nm
else if adr == '' then
adr = 'M.'ax
if symbol('m.m_2a.nm') == 'VAR' then
call err 'area name' nm 'already used'
if symbol('m.m_2a.adr') == 'VAR' then
call err 'adr' adr 'for area' nm 'already used'
m.m_2a.adr = adr
m.m_2a.nm = adr
m.adr.0 = 0
m.m_free.adr.0 = 0
return nm
endProcedure mNewArea
mNew: procedure expose m. ggArea
parse arg name
if symbol('m.m_2a.name') \== 'VAR' then
call err 'area' name 'does not exists'
adr = m.m_2a.name
if m.m_free.adr.0 > 0 then do
fx = m.m_free.adr.0
m.m_free.adr.0 = fx-1
return m.m_free.adr.fx
end
m.adr.0 = m.adr.0 + 1
return adr'.'m.adr.0
endProcedure mNew
mFree: procedure expose m.
parse arg m
adr = left(m, lastPos('.', m)-1)
fx = m.m_free.adr.0 + 1
m.m_free.adr.0 = fx
m.m_free.adr.fx = m
return ''
endProcedure mFree
/*--- iterate over all allocate elements of an area -----------------*/
mIterBegin: procedure expose m.
parse arg nm
return m.m_2a.nm'.0'
endProcedure mIterBegin
mIter: procedure expose m.
parse arg cur
if cur == '' then
return ''
lx = lastPos('.', cur)
adr = left(cur, lx-1)
ix = substr(cur, lx+1)
do ix=ix+1 to m.adr.0
n = adr'.'ix
do fx=1 to m.m_free.adr.0 while m.m_free.adr.fx \== n
end
if fx > m.m_free.adr.0 then
return n
end
return ''
endProcedure mIter
/*--- get m.a -------------------------------------------------------*/
mGet: procedure expose m.
parse arg a
return m.a
endProcedure mGet
/*--- put value v into m.a ------------------------------------------*/
mPut: procedure expose m.
parse arg a, v
m.a = v
return v
endProcedure mPut
/*--- cut stem a to length len --------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a ----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a --------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- create the inverse map of a stem ------------------------------*/
mInverse: procedure expose m.
parse arg a, i
do x=1 to m.a.0
v = m.a.x
m.i.v = x
end
return m.a.0
endProcedure inverse
/*--- add to m.dst.* a (sub)sequence of m.src.* ---------------------*/
mAddSt: procedure expose m.
parse arg dst, src, fx , tx
dx = m.dst.0
if fx == '' then
fx = 1
if tx == '' then
tx = m.src.0
do sx = fx to tx
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSt
/*--- find position of first occurrence of ele in stem m,
return 0 if nonemove a part of a stem -----------------------*/
mPos: procedure expose m.
parse arg m, ele, sx
if sx == '' then
sx = 1
do x=sx to m.m.0
if m.m.x = ele then
return x
end
return 0
endProcedure mPos
/*--- move a part of a stem -----------------------------------------*/
mMove: procedure expose m.
parse arg m, sx, dx
if dx < sx then do
y = dx
do x=sx to m.m.0
m.m.y = m.m.x
y = y + 1
end
end
else if dx > sx then do
y = m.m.0 + dx - sx
do x=m.m.0 by -1 to sx
m.m.y = m.m.x
y = y - 1
end
end
m.m.0 = m.m.0 + dx - sx
return
endProcedure mMove
/*--- insert a stem into another ------------------------------------*/
mInsert: procedure expose m.
parse arg m, tx, st
call mMove m, tx, tx+m.st.0
do sx=1 to m.st.0
dx = tx-1+sx
m.m.dx = m.st.sx
end
return
endProcedure mInsert
/*--- strip all elements of a stem ----------------------------------*/
mStrip: procedure expose m.
parse arg st, opt
if opt == '' then
opt = 'b'
do x=1 to m.st.0
m.st.x = strip(m.st.x, opt)
end
return st
endProcedure mStrip
/* cat the lines of a stem with separator ---------------------------*/
mCat: procedure expose m.
parse arg st, sep
if m.st.0 < 1 then
return ''
res = m.st.1
do sx=2 to m.st.0
res = res || sep || m.st.sx
end
return res
endProcedure mCat
mIni: procedure expose m.
if m.m_ini == 1 then
return
m.m_ini = 1
call utIni
m.m_area.0 = 0
call mNewArea
return
endProcedure mIni
/* copy m end ********************************************************/
/* copy cat begin ****************************************************
**********************************************************************/
/*--- create a new cat ----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -55e55
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader -----------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, rStem
do while m.m.catRd \== ''
if jReadSt(m.m.catRd, rStem) then
return 1
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, wStem
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteSt m.m.catWr, wStem
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading ------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file -------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory---------*/
fileList: procedure expose m.
parse arg m, opt
if oKindOfString(m) then
return oNew('FileList', dsn2Jcl(oAsString(m)), opt)
else
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead if \ catRead(m, rStem) then return 0",
, "jWrite call catWrite m, wStem",
, "jWriteAll call catWriteAll m, rdr; return"
if m.err_os == 'TSO' then
call fileTsoIni
else
call err 'file not implemented for os' m.err_os
return
endProcedure catIni
/* copy cat end ***************************************************/
/* copy fileTso begin ************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.wriMax = 200
if symbol('m.m.defDD') \== 'VAR' then
m.m.defDD = 'CAT*'
m.m.spec = sp
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
call dsnSpec m, m.m.spec
if m.m.dsn ='INTRDR' | wordPos('WRITER(INTRDR)', m.m.attr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', m.m.attr) < 1 | pos('RECFM(V', m.m.attr) > 0)
if opt == m.j.cRead then do
aa = dsnAllo2(m, 'SHR', m.m.defDD)
if pos('(', m.m.dsn) > 0 & m.m.sys == '' then
if sysDsn("'"m.m.dsn"'") <> 'OK' then
call err 'cannot read' m.m.dsn':' sysDsn("'"m.m.dsn"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAllo2(m, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAllo2(m, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call tsoOpen word(aa, 1), 'W'
end
m.m.buf.0 = 0
parse var aa m.m.dd m.m.free
call errAddCleanup 'call jCloseClean' m
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
call errRmCleanup 'call jCloseClean' m
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m, wStem
if m.m.stripT \== '' then do
m.j_b.0 = m.wStem.0
if m.m.stripT == 't' then do bx=1 to m.j_b.0
m.j_b.bx = strip(m.wStem.bx, m.m.stripT)
end
else do bx=1 to m.j_b.0
m.j_b.bx = left(m.wStem.bx, m.m.stripT)
end
wStem = j_b
end
call writeDD m.m.dd, 'M.'wStem'.', , m.m.tso_truncOk == 1
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('sysout(T) writer(intRdr)')
endProcedure fSub
/*--- open file with spec spec, edit it at close --------------------
vw = if contains abbrev of VIEW then view
if contains 0 then do NOT use o2text ------------------*/
fEdit: procedure expose m.
parse arg spec, vw
if spec == '' then
spec = 'new ::f'
else if abbrev(spec, '::') then
spec = 'new' spec
else if abbrev(spec, ':') then
spec = 'new' ':'spec
if pos('0', vw) < 1 then
f = oNew(m.class_FileEdit, spec)
else do
f = oNew(m.class_FileEdit0, spec)
vw = strip(translate(vw, ' ', 0))
end
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy, 1) then
eTy = 'view'
else do
if \ abbrev('EDIT', eTy) then
eAr = m.m.editArgs
eTy = 'edit'
end
/* parm uses a variable not text ||||*/
cx = pos('PARM(', translate(eAr))
cy = pos(')', eAr, cx+5)
if cx > 0 & cy > cx then do
macrParm = substr(eAr, cx+5, cy-cx-5)
eAr = left(eAr, cx+4)'macrParm'substr(eAr, cy)
end
if dsn \== '' then do
call fileTsoClose m
call adrIsp eTy "dataset('"dsn"')" eAr, 4
return
end
fr = m.m.free
dd = m.m.dd
m.m.free = ''
call fileTsoClose m
call adrIsp "LMINIT DATAID(lmmId) ddName("dd") ENQ(SHRW)"
eRc = adrIsp(eTy "dataid("lmmId")" eAr, '*')
lRc = adrIsp("LMFree DATAID("lmmId")", '*')
call tsoFree fr
if (eRc \== 0 & eRc \== 4) | lRc \== 0 then
call err eTy eAr 'rc' eRc', lmFree rc' lRc
return
endProcedure fileTsoEditClose
fileTsoIni: procedure expose m.
if m.fileTso.ini == 1 then
return
m.fileTso.ini = 1
m.file.sep = '.'
m.fileTso.buf = 0
call jIni
um = "call err 'for tso undefined method'"
call classNew "n File u JRW", "m",
, "jOpen call fileTsoOpen m, opt",
, "jReset call fileTsoReset m, arg",
, "jClose call fileTsoClose m",
, "jRead if \ readDD(m.m.dd, 'M.'rStem'.') then return 0",
, "jWrite call fileTsoWrite m, wStem",
, "filePath call dsnSpec m, m.m.spec; return m.m.dsn" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg || copies('.*', pos('*', arg) < 1)" ,
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead do bx=1 to 10 while csiNext(m, rStem'.'bx); end;",
"m.rStem.0=bx-1"
call classNew "n FileEdit0 u File", "m",
, "jClose call fileTsoEditClose m"
call classNew "n FileEdit u FileEdit0, f MAXL v", "m",
, "jOpen call fileTsoOpen m,opt; m.m.maxL=tsoDSIMaxl(m.m.dd)",
, "jWrite call fileTsoWrite m, o2TextStem(wStem, j_b,m.m.maxL)"
return
endProcedure fileTsoIni
/* copy fileTso end ************************************************/
/* copy adrIsp begin *************************************************/
/*--- address ispf with error checking ------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking ----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet --*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
m.tso_errL1 = 'adrTso rc='m.tso_rc 'stmt='m.tso_stmt
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err m.tso_errL1 m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format
replace any ~ by syspref or userid and necessary dots ---------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then /* only remove apostrophs */
return strip(dsn, 'b', "'")
cx = pos('~', dsn)
if cx < 1 then
if addPrefix \== 1 then
return dsn
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
if cx < 1 then
return sp'.'dsn
do until cx == 0
le = left(dsn, cx-1)
if le \== '' & right(le, 1) \== '.' & right(le, 1) \== '/' then
le = le'.'
if cx == length(dsn) then
return le || sp
else
dsn = le || sp'.' ,
|| substr(dsn, cx + 1 + (substr(dsn, cx+1, 1) == '.'))
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format ----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
return copies('*/', withStar \== 0)dsn
parse var dsn sys '/' d2
if sys = '' | sys = sysvar(sysnode) then
return copies('*/', withStar \== 0)d2
else
return dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
**********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') -------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof --------------*/
readDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2 ggRet
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records ----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRetDD
if ggCnt == '' then
ggCnt = value(ggst'0')
if adrTso('execio' ggCnt 'diskW' ggDD '(stem' ggSt')',
, 1 ggRetDD) = 1 then
if wordPos(1, ggRetDD) < 1 then
call err 'truncation on write dd' ggDD
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer --------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ ------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end ----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end -------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
---------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse arg m, spec
upper spec
m.m.dsn = ''
m.m.dd = ''
m.m.disp = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w,'SYSO') then
m.m.disp = w
else if abbrev('CATALOG', w, 3) | abbrev(DELETE, w, 3) then
m.m.disp = di left(w, 3)
else if abbrev(w, 'DD(') then
m.m.dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
m.m.dsn = dsn2Jcl(substr(w, 5, length(w)-5))
else if m.m.dsn == '' & (w = 'INTRDR' ,
| verify(w, ".~'/", 'm') > 0) then
m.m.dsn = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if m.m.dd == '' then
m.m.dd = w
else
leave
end
if pos('/', m.m.dsn) < 1 then
m.m.sys = ''
else do
parse var m.m.dsn m.m.sys '/' m.m.dsn
if m.m.sys == '*' | m.m.sys = sysvar(sysnode) then
m.m.sys = ''
end
parse value subword(spec, wx) with at ':' nw
m.m.attr = strip(at)
m.m.new = strip(nw)
return m
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs -------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, dDi, dDD, timeOut
x = max(1, arg() - 1)
do rt=0
res = dsnAlloc(spec, dDi, dDD, '*')
if \ datatype(res, 'n') then
return res
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'm.tso_trap)
if pos('DATA SET IS ALLOCATED TO ANOTHER', m.tso_trap) < 1 then
return err('allocating' spec'\n'm.tso_trap)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec dsnSpec
dDi default disposition
dDD default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc ----*/
dsnAlloc: procedure expose m.
parse upper arg spec, dDi, dDD, retRc
return dsnAllo2(dsnSpec(dsn_alloc, spec), dDi, dDD, retRc)
/*--- alloc a dsn or a dd, dsnSpec analysed in m --------------------*/
dsnAllo2: procedure expose m.
parse upper arg m, dDi, dDD, retRc
m.tso_dsn.dd = ''
if m.m.dd \== '' then
dd = m.m.dd
else if dDD \== '' then
dd = dDD
else
dd = 'DD*'
if m.m.dsn == '' & m.m.disp == '' & m.m.attr = '' then
return dd /* already allocated only use dd */
dd = tsoDD(dd, 'a') /* ensure it is free'd by errCleanup */
if m.m.disp \== '' then
di = m.m.disp
else if dDi \== '' then
di = dDi
else
di = 'SHR'
if pos('(', m.m.dsn) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if m.m.sys == '' then
rx = tsoAlloc(m.m.dsn, dd, di, m.m.attr, m.m.new, retRc)
else
rx = csmAlloc(m.m.sys'/'m.m.dsn,dd, di, m.m.attr,m.m.new,retRc)
if rx = 0 then
return dd dd
call tsoFree dd, 1, 1 /* over careful? would tsoDD , - suffice? */
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ---------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if m.err_ini \== 1 then
call errIni /* initialises tso_ddAll */
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err_screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err_screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na, dd, disp, rest, nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE*/
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na, dd, disp, rest, , retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose, silent
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
if silent \== 1 ,
| \ (pos('IKJ56247I FILE',m.tso_trap) > 0 ,
& pos('NOT FREED, IS NOT ALLOCATED' ,
, m.tso_trap) > 0) then
call sayNl m.tso_errL1 m.tso_trap
end
call tsoDD dd, '-', 1
end
return 0
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32755 /* 32756 gives bad values in ListDSI | */
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'dsnCreateAtt bad :' a1
end
aU = ' 'translate(atts)
hasOrg = pos(' DSORG(', aU) > 0 | pos(' DSNTYPE(', aU) > 0
hasMbr = pos('(', dsn) > 0
if hasMbr & \ hasOrg then
atts = atts 'dsorg(po) dsntype(library)'
if hasOrg | hasMbr then do
ww = DSORG DSNTYPE
do wx=1 to words(ww)
do forever
cx = pos(' 'word(ww, wx)'(', ' 'translate(res))
if cx == 0 then
leave
cy = pos(')', res, cx)
res = delstr(res, cx, cy+1-cx)
end
end
end
res = res atts
aU = ' 'translate(res)
if pos(' MGMTCLAS(', aU) < 1 then
res = res 'mgmtclas(COM#A091)'
if pos(' SPACE(', aU) < 1 then
res = res 'space(1, 50) cylinders'
return res
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt ----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... ------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
tsoDsiMaxl:
rc = listDsi(arg(1) 'FILE')
if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
return SYSLRECL - 4 * abbrev(sysRecFm, 'V')
endSubroutine tsoDsiMaxL
/* copy adrTso end ***************************************************/
/* copy err begin *** errorhandling, messages, help ***************/
errIni: procedure expose m.
if m.err_ini == 1 then
return
m.err_ini = 1
call utIni
m.err_saySay = 1
m.err_sayOut = 0
m.err_handler = ''
m.err_handler.0 = 0
m.err_cleanup = '\?'
m.err_opt = ''
m.err_nest = 0
parse source m.err_os .
m.tso_ddAll = ''
m.err_ispf = 0
m.err_screen = 0
if m.err_os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err_ispf = 1
address ispExec 'vget (zScreen zScreenD zScreenW) shared'
m.err_screen = zScreen
m.err_screenD = zScreenD
m.err_screenW = zScreenW
end
end
return
endProcedure errIni
/* configure err ----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err_opt, m.err_handler
upper m.err_opt
call errSetSayOut '-'
m.err_handler.0 = 0
if pos('I', m.err_opt) > 0 & m.err_ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/*--- set sayOut and sysSay -----------------------------------------*/
errSetSayOut: procedure expose m.
parse upper arg flags
if flags \== '-' then
m.err_opt = space(translate(m.err_opt, ' ' ,'OS')flags, 0)
m.err_sayOut = pos('O', m.err_opt) > 0
m.err_saySay = pos('S', m.err_opt) > 0 | \ m.err_sayOut
return
endProcedure errSetSayOut
/*--- 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
/* push error handler -----------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err_handler.0 + 1
m.err_handler.0 = ex
m.err_handler.ex = m.err_handler
m.err_handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value -------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler -----------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err_handler.0 < 1 then
call err 'errHandlerPop but err_handler.0='m.err_handler.0
ex = m.err_handler.0
m.err_handler = m.err_handler.ex
m.err_handler.0 = ex - 1
return
endProcedure errHandlerPop
/* pop error handler -----------------------------------------------*/
errHandlerCall:
interpret m.err_handler
m.err_handlerReturned = 0
return ''
endProcedure errHandlerCall
/*--- error routine: abend with message -----------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
ggNx = m.err_nest + 1
m.err_nest = ggNx
m.err_nest.ggNx = ggTxt
if ggNx \== 1 & ggNx \== 2 then do ggNx=ggNx by -1 to 1
say ' error nesting.'ggNx '==>' m.err_nest.ggNx
end
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err_handler <> '' then do
m.err_handlerReturned = 1
ggRet = errHandlerCall()
ggDoR = m.err_handlerReturned
m.err_handlerReturned = 1
if ggDoR then do
m.err_nest = m.err_nest - 1
return ggRet
end
end
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err_opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
m.err_nest = m.err_nest - 1
exit errSetRc(12)
endSubroutine err
/*--- 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 = delStr(m.err_cleanup, cx, length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
m.err_saySay = 1
m.err_sayOut = 0
if m.err_cleanup <> '\?' then do
do while m.err_cleanup <> '\?'
cx = pos('\?', m.err_cleanup, 3)
c1 = substr(m.err_cleanup, 3, cx-3)
m.err_cleanup = substr(m.err_cleanup, cx)
say 'errCleanup doing' c1
interpret c1
end
say 'errCleanup end doing err_cleanup'
end
if m.tso_ddAll <> '' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return errSaySt(splitNl(err_l, 0, errMsg(msg)))
errSaySt: procedure expose m.
parse arg st
if m.err_saysay | \ m.err_sayOut then
call saySt st
if m.err_sayOut & \ ( m.err_saySay & m.j.out == m.j.say) then
call outSt st
return st
endProcedure errSaySt
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
/*--- fill stem st with lines of msg separated by \n ----------------*/
splitNl: procedure expose m.
parse arg st, sx, msg
bx = 1
sx = firstNS(sx, 1)
do lx=sx+1 to sx+999
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
/*--- out msg lines separated by \n ---------------------------------*/
outNL: procedure expose m.
parse arg msg
return outSt(splitNl(err_outNl, 0, msg))
/*--- say msg lines separated by \n ---------------------------------*/
sayNl: procedure expose m.
parse arg msg
return saySt(splitNl(err_outNl, 0, msg))
/*--- say (part of) the lines of a stem -----------------------------*/
saySt: procedure expose m.
parse arg st, fx, tx
do lx=firstNS(fx, 1) to firstNS(tx, m.st.0)
say strip(m.st.lx, 't')
end
return st
endProcedure saySt
/*--- say a trace message if m.trace is set -------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set ------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true ------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1)':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help ----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ---------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err_helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end ****************************************************/
/* copy ut begin ****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_Num = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_uc = translate(m.ut_lc)
m.ut_uc25 = left(m.ut_uc, 25)
m.ut_alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_Num
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_Num /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_space = '05'x' ' /* with space: space and Tab char */
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.ut_numUc = m.ut_num || m.ut_uc
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_Num'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| ----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- strip and returnn first argument not space --------------------*/
firstNS: procedure expose m.
do ax=1 to arg()
if arg(ax) <> '' then
return strip(arg(ax))
end
return ''
endProcedure firstNS
/*--- return current time and cpu usage -----------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds -----------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say time() 'sleeping' secs 'secs'
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say time() 'slept' secs 'secs'
return
endProcedure sleep
/*--- left without truncation ---------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation --------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") ----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase ----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id --------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ---------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
/*--- character to decimal '0140'x --> 256+64=320 -------------------*/
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
endProcedure utc2d
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end *******************************************************/