zOs/REXX/ANAPOST
/* rexx anaPost -------------------------------------------------------
walter 12.11.16
functions:
pre: preProcess ddl before analysis
ana: prostprocess analysis
rec: prostprocess recoveryAnalysis
exe: copy executionJcl from DD exe
what it does
add chkStart at beginning of analysis
disallow unchanged execution of recovery ana
add anaPost after snapshot
map tables to db.ts from unload model comments
add -sta rw AFTER drop tables
History:
12.11.16 Walter remove set sqlid/schema, no rebind if sysEntries <> 0
----------------------*/ /* end of help -------------------------------
24. 8.16 Walter global temporary tables
8. 8.16 Walter new copies, remove unnecessary copies
9. 6.16 Walter new function DDL: overrite ddl: dsSize 4Gfor PBG
avoid segsize 32 alter to UTS/PBG
3. 6.16 Walter in pre do not allow fallback from uts to nonUts
30. 5.16 Walter move -sta rw after drop table: drop seems to work in RO
15. 4.16 Walter do not multiply alters for second and later TS ....
8. 2.16 Walter avoid pieceSize change for ddlchange of UTS
3. 2.16 Walter rebind also function packages / maxRows toEnd auch -
2. 2.16 Walter anapre/post: move alter segSize to end for UTS change
19. 1.16 Walter anapost: fix alter part for indexes
11. 1.16 Walter anapost: rdl from ALL objects
14.12.15 Walter String Constant (label) from 300 to 1500 chars extended
10.11.15 Walter redesign
22. 6.15 Walter lange Table names mit Line overflows
3.11.14 Walter archiviert dby....anO, anP, reO und reP
4. 2.14 Walter spanned unloads fuer TS mit LOBS oder XML
27.11.13 Walter sync bad sequence in recovery only warning
12. 6.13 Walter remove " from drop table names
12. 6.13 Walter fastUnload und Sync
4. 4.13 Walter check auf noUnloads
4. 4.13 Walter checkErr mit override aus option member
. 2.13 Walter neu
---------------------------------------------------------------------*/
parse arg mArg
call ini
say 'anaPost v3.4 12.11.16 arg='space(mArg, 1)
if mArg <> '' then
exit workMain(mArg)
if 1 then
call err 'no arguments'
if 0 then do
call workFun 'PRE', 'DP4G', SV100211 ,
, 'A540769.tmp.text(sv100211)' ,
, 'A540769.TMP.TEXT(QTQZ01OP)' ,
, 0 , 'A540769.TMP.TEXT(QTQZ01PR)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
exit err('tstEnd')
%ANAPOST PRE DP4G DSN.DBXDP4G.DD2(QTQZ0100) +
DSN.DBXDP4G.AOPT(QTQZ0100) +
DSN.DBXDP4G.DDI(QTQZ0100)
end
if 0 then do
call workFun 'ANA', 'DBOF', wf010340 ,
, 'A540769.TMP.TEXT(wf01034A)' ,
, 'A540769.TMP.TEXT(wf01034P)' ,
, 0 , 'A540769.TMP.TEXT(wf01034O)' ,
, 'A540769.TMP.TEXT(wf01034Q)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
exit err('tstEnd')
%ANAPOST ANA DP4G DSN.DBXDP4G.ANA(QTQZ0100) +
DSN.DBXDP4G.AOPT(QTQZ0100) +
DSN.DBXDP4G.ANA(QTQZ0100) +
DSN.DBXDP4G.QUICK(QTQZ0100)
end
if 0 then do
call readDsn 'A540769.WK.TEXT(ANAPOBF2)', tt.
do tx=440 to tt.0
say '***' tx '***' strip(tt.tx) '************'
parse var tt.tx fun dbSy mbr inDsn .
drop m.
call ini
call workFun fun, dbSy, mbr, inDsn, , 0,
, overlay('Q', inDsn, 24)
if 0 then do
call dbAllOut inA
say err 'tstEnd1' ; exit
end
end
say err 'tstEnd2' ; exit
end
if 0 then do
call workMain 'ARC A540769.tmp.##DT##.EXE'
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'CD030341', 'A540769.TMP.TEXT(CD030341)',
, 'A540769.tmp.text(cd03aop1)',
, 0, 'A540769.TMP.TEXT(ANAPOST)' ,
, 'A540769.TMP.TEXT(ANAQUICK)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'QTM2UTS9', 'DSN.DBXDP4G.AN1(QTM2UTS9)' ,
, 'DSN.DBXDP4G.aopt(QTM2UTS9)',
, 0, 'A540769.TMP.TEXT(ANAPOST)' ,
, 'A540769.TMP.TEXT(ANAQUICK)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'DDL', 'DP4G', 'QTM2UTSV' ,
, 'DSN.DBX.DDK(QTM2UTS6)' ,
, , 0, 'A540769.TMP.TEXT(QTM2UTS6)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'ANA', , 'QTM2UTST',
, 'DSN.DBxDP4G.an1(qtm2utsT)' ,
, 'DSN.DBXDP4G.aopt(QTM2UTST)' ,
, 0, 'A540769.TMP.TEXT(ANAPOST)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
/* m.fTst = '2015-01-01-12:30:00' */
call workFun 'REC', , 'TT010331', 'DSN.DBXDE0G.RE1(TT010331)' ,
, 'A540769.TMP.TEXT(AOPT)' ,
, 0, 'A540769.TMP.TEXT(ANAPOREC)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call workFun 'PRE', ,'QTM2UTS6', 'DSN.DBX.DDL(QTM2UTS6)' ,
, 'A540769.TMP.TEXT(AOPT)' ,
, 1, 'A540769.TMP.TEXT(ANAPRE)'
call adrIsp "view dataset('"m.inA.outDsn"')", 4
say err 'tstEnd' ; exit
end
if 0 then do
call genPre 'DSN.DBXDP4G.ANA(CMN001Y)',
, 'A540769.TMP.TEXT(ANAPRE)'
call anaAna aa, 'DSN.DBXDP4G.ANA(WK401010)'
call anaAna aa, 'DSN.DBX.DDL(AGNEST10)'
call anaAna aa, 'DSN.DBX.DDL(WK40105W)'
call err 'tstEnd'
a = 'ANA A540769.TMP.LCTL(DROP1)' Tst
a = 'EXE DSN.DBXDBOF.EXE(TG010231)'
a = 'REC DSN.DBXDBAF.REC(WK40300T) OF WK40300T 130130:113528.6'
a = 'ANA DSN.DBXDP4G.ANA(WK401031)'
exit workMain(a)
end
exit err('never pass here')
/* driver and initialisation *****************************************/
/*--- select work depending on main arguments -----------------------*/
workMain: procedure expose m.
parse upper arg fun dbSys ddl w4 w5 w6 w7 w8 w9
if \ abbrev(dbSys, 'D') | length(dbSys) <> 4 then do
parse upper arg fun ddl w4 w5 w6 w7
dbSys = substr(ddl, 8, 4)
end
mbr = dsnGetMbr(ddl)
if length(mbr) \== 8 & fun \== 'ARC' then
call err 'bad member in ddl' ddl
if fun == 'ANA' & w4 == '' then /* old syntax for ana */
return workFun(fun, dbSys, mbr, ddl, , 1, ddl)
else if fun == 'ANA' & w6 \== '' & w7 = '' then /* new ana */
return workFun(fun, dbSys, mbr, ddl, w4, 1, w5, w6)
else if fun == 'ARC' then
return archive(dbSys, ddl w4 w5 w6 w7)
else if fun == 'DDL' & w4 \== '' & w5 == '' then
return workFun(fun, dbSys, mbr, ddl, , 0, w4)
else if fun == 'PRE' & w5 \== '' & w6 == '' then
return workFun(fun, dbSys, mbr, ddl, w4, 1, w5)
else if fun == 'REC' & w4 == 'OF' & w6 \== '' & wR = '' then do
m.fTst = tst2db2(w6, 'bad anaTimestamp' fTst 'in args' arg(1))
if w5 <> mbr then
call err 'of' w5 'mismatches mbr='mbr
return workFun(fun, dbSys, mbr, ddl, , 1, ddl)
end
else if fun == 'REC' & w5 == 'OF' & w7 \== '' & w8 = '' then do
m.fTst = tst2db2(w7, 'bad anaTimestamp' w8 'in args' arg(1))
if w6 <> mbr then
call err 'of' w6 'mismatches mbr='mbr
return workFun(fun, dbSys, mbr, ddl, , 1, w4)
end
else if fun == 'EXE' then do /* old exe */
call readDsn 'dd(EXE)', e.
call writeDsn ddl '::f', e., ,1
exit 0
end
else
call err "implement fun: '"arg(1)"'"
endProcedure workMain
workFun: procedure expose m.
parse arg m.inA.Fun, m.inA.dbSys, m.inA.mbr, m.inA.inDsn, m.inA.optDsn,
, doArc, m.inA.OutDsn, m.inA.quickDsn
fn = m.inA.fun
call aOptRead inOpt, m.inA.optDsn
m.chOpt.0 = 0
b = jBuf()
m.inA.buf = b
call readDsn m.inA.inDsn, 'M.' || b'.BUF.'
say m.b.buf.0 'records in' m.inA.inDsn
if doArc & m.inA.inDsn == m.inA.outDsn then do
cy = pos('(', m.inA.inDsn) - 1
if cy <= 0 then
call err 'bad inDsn' m.inA.inDsn
else if substr(m.inA.inDsn, cy, 1) == 1 then
call err 'llq ends already with 1 in inDsn' m.inA.inDsn
m.inA.inDsn = overlay(1, m.inA.inDsn, cy)
call writeDsn m.inA.inDsn, 'M.' || b'.BUF.', , 1
arc = 1
end
if m.b.buf.0 < 1 then
call err 'empty analysis' m.inA.inDsn
call AnaAna inA, b
if fn = 'ANA' then
aDb = m.inA.straTrg
else if fn = 'REC' then
aDb = m.inA.straSrc
else
aDb = ''
if aDb \== '' & \ (length(aDb) == 4 & abbrev(aDb, 'D')) then
call err 'bad src/trg ssid in ana:' aDb
if m.inA.dbSys = '' then
m.inA.dbSys = aDb
if m.inA.dbSys = '' then
call err 'no dbSys in args or ana'
else if aDb \== '' & m.inA.dbSys \== aDb then
call err 'strategy src/trg='aDb ,
'mismatches argument dbSys='m.inA.dbSys
if m.inA.conStra \== '' & m.inA.conStra \== m.inA.straCrNm then
call err 'control='m.inA.conStra 'mismatches ana='m.inA.straCrNm
if m.inA.stra \== m.inA.mbr ,
& wordPos(m.inA.stra,'QUICKM RECOVERY') < 1 then
if fn == 'PRE' then
say 'strategy' m.inA.straCrNm 'mismatches' m.inA.inDsn
else
call err 'strategy' m.inA.straCrNm 'mismatches' m.inA.inDsn
cSnap = 0
do ax=1 to m.inA.0
if m.inA.ax.verb = 'AnaPosHea' then
if m.inA.ax.obj \== 'DDL' then
call err 'anaPost' m.inA.ax.obj 'already run'
if m.inA.ax.verb = 'bp.CALL' & m.inA.ax.obj = 'SNAPSHOT' then
cSnap = cSnap + 1
end
if cSnap <> (fn == 'ANA') then
say 'warning fun' fn 'but' cSnap 'snapshots'
m.outA.0 = 0
if fn == 'DDL' then do
call genDdl inA, outA
call writeDsn m.inA.outDsn '::f', 'M.OUTA.', , 1
return 0
end
call sqlConnect m.inA.dbSys, 'e'
call ddlAddParents
if fn == 'PRE' then /* control */
call genPre inA, outA
else do
if fn = 'ANA' then do
if m.inA.conStra == '' then
call err 'no .control in ana'
if m.inOpt.0 > 2 then
if m.inA.noUnload ,
\== ( wordPos('DDLONLY', m.inOpt.opts) > 0) then
call err 'noUnloads but not ddlOnly'
end
else if fn == 'REC' then do
if m.inA.stra \== 'RECOVERY' then
call err 'not a recovery strategy'
end
else
call err 'bad fun' fn
call genPost inA, outA
end
if doArc then do
call archive m.inA.dbSys, m.inA.inDsn, b'.BUF'
call archive m.inA.dbSys, m.inA.outDsn, outA
end
call aOptWrite inOpt, chOpt
call writeDsn m.inA.outDsn '::f', 'M.OUTA.', , 1
call sqlDisconnect
if m.ina.quickDsn \== '' then do
m.quO.0 = 0
call genQUICK quO
call writeDsn m.inA.quickDsn '::f', 'M.QUO.', , 1
end
return 0
endProcedure workFun
ini: procedure expose m.
call errReset 'hi'
call sqlIni
call scanWinIni
call jIni
m.lastSync = 0
qq = date('j') (date('s') time())
m.myJul = word(qq, 1)
m.myTst = tst2db2(subWord(qq, 2))
m.clANode = classNew('n ANode u f VERB v, f OBJ r, f SUB s o',
',f FR v, f TO v')
m.clAON = classNew('n AON u f ATT v, f OLD v, f NEW v')
m.ddl_Types.index = 'IX'
m.ddl_Types.table = 'TB'
m.ddl_Types.tableSpace = 'TS'
m.ddl_Types.view = 'VW'
m.ddl.ix.0 = 0
m.ddl.tb.0 = 0
m.ddl.ts.0 = 0
m.ddl_Types = 'IX TB TS'
m.clDDL = classNew('n Ddl u f QUAL v, f NAME v, f TYPE v' ,
', f PAR r, f PAROLD r, f ACD v, f FUN v' ,
', f ANO s ANode, f ALT s AON')
m.clDdl.ix = classNew('n DdlIx u Ddl, f DBSP v, f PIECESIZE v')
m.clDdl.tb = classNew('n DdlTb u Ddl, f PARTBYSZ v')
m.clDdl.ts = classNew('n DdlTs u Ddl, f DSSIZE v, f SEGSIZE v',
', f NUMPARTS v, f MAXPARTITIONS v, f FREEPAGE v, f MAXROWS v')
m.clDdl.vw = classNew('n DdlVw u Ddl, f FRJO s v')
return
endProcedure ini
tst2db2: procedure expose m.
parse arg i, eMsg
t = 'yz34-56-78-hi.mn.st'
t3 = '34-56-78-hi.mn.st'
j = translate(i, '999999999', '012345678')
if abbrev('999999:999999.9', j, 7) then
return '20'translate(t3'.a' ,
, i || substr('000000.0', length(i)-6), '345678:himnst.a')
else if abbrev('9999-99-99-99.99.99.9999999999', j, 19) then
return i
else if j == '99999999 99:99:99' then
return translate(t, i, 'yz345678 hi:mn:st')
else if j == '99/99/99 99:99' then
return '20'translate(left(t3, 14), i, '56/78/34 hi:mn')'.00'
else if eMsg == '-' then
return '-'
else if eMsg == '' then
call err 'bad timestamp' i
else
call err eMsg
endProcedure tst2db2
/* generate modified analysis ****************************************/
/*--- ddl: modify DDL: dsSize for PBG etc. --------------------------*/
genDDL: procedure expose m.
parse arg aa, oo
say time() strip(sysvar('syscpu')) 'genDDl begin'
call ddlAltPartBySz
do tx=1 to m.ddl.ts.0
t1 = 'DDL.TS.'tx
if m.t1.maxpartitions > 0 & m.t1.dsSize <> '4G' then do
m.t1.fun = 'a'
call ddlAddAlt t1, dsSize, m.t1.dsSize, '4G'
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
laTo = m.aa.1.to
call genChkStart oo, aa, 'DDL', chOpt
do ax=2 to m.aa.0
if wordPos(m.aa.ax.verb, 'CREATE ALTER') > 0 then
laTo = genAlter(oo, b, laTo, aa'.'ax, new)
end
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return 0
endProcedure genDDL
/*--- preAnalysis: modify DDL to avoid drop/recreate etc. -----------*/
genPre: procedure expose m.
parse arg aa, oo
uts2old = 0
/* call ddlAltPartBySz no| changes from new to old| */
do tx=1 to m.ddl.ts.0
t1 = 'DDL.TS.'tx
m.t1.newUts = m.t1.maxPartitions > 0 ,
| (m.t1.segSize > 0 & m.t1.numParts > 0 )
if sql2one("select dbName, name, partitions, maxPartitions" ,
", segSize, dsSize, type, maxRows" ,
", (select max(freePage) from sysibm.sysTablePart p",
"where p.dbName=s.dbName and p.tsName=s.name) freePg",
'from sysibm.sysTablespace s' ,
"where dbName='"m.t1.qual"' and name = '"m.t1.name"'",
,tc , , ,'--') == '-' then do
say t1 m.t1.qual'.'m.t1.name 'not found in' m.aa.dbSys
m.t1.oldUts = 0
end
else do /* attention sometime trailing spaces in catalog */
if m.t1.name <> m.tc.name | m.t1.qual <> m.tc.dbName then
call err 'sql mismatch' o2Text(t1)
m.t1.oldUts = m.tc.type == 'G' | m.tc.type == 'R'
if m.t1.newUts & \ m.t1.oldUts then
m.t1.fun = 'ae' /* old --> UTS */
else if m.t1.newUts & m.t1.oldUts ,
& ( m.tc.segSize <> m.t1.segsize ,
| ddlFilter(dsSize, m.tc.dsSize) ,
<> ddlFilter(dsSize, m.t1.dsSize) ,
| ddlFilter(maxRows, m.tc.maxRows) ,
<> ddlFilter(maxRows, m.t1.maxRows )) then
m.t1.fun = 'ae' /* attribute change of UTS */
else if \ m.t1.newUts & m.t1.oldUts then do
uts2old = uts2old + 1
say '||| ts' m.t1.qual'.'m.t1.name ,
'from UTS to nonUTS'
end
end
if m.t1.fun == '' then
iterate
call mAdd chOpt, 'ts' m.t1.fun m.t1.qual'.'m.t1.name
aForce = m.t1.newUts & \ m.t1.oldUts
if pos('a', m.t1.fun) < 1 then
iterate
call ddlAddAlt t1, maxPartitions, m.tc.maxPartitions,
, m.t1.maxPartitions
call ddlAddAlt t1, segSize, m.tc.segsize, m.t1.segsize, aForce
call ddlAddAlt t1, dsSize , m.tc.dsSize, m.t1.dsSize, aForce
call ddlAddAlt t1, maxRows, m.tc.maxRows, m.t1.maxRows
call ddlAddAlt t1, freePage,
, max(77, m.tc.freePg+11, m.t1.freePage+11), m.t1.freePage
end
if uts2old > 0 then do
say '|||' uts2old 'tablespaces from UTS to nonUTS'
if wordPos('UTS2OLD', m.inOpt.opts) > 0 then do
say '-> allowed because of option "uts2old 1" in Auftrag'
end
else do
say '-> to allow it, set option "uts2old 1" in Auftrag'
call err uts2old 'tablespaces from UTS to nonUTS'
end
end
do xx=1 to m.ddl.ix.0
x1 = 'DDL.IX.'xx
t1 = ddlPar(ddlPar(x1))
if t1 == '' | pos('a', m.t1.fun) < 1 then
iterate
pp = m.x1.piecesize
if pp \== '' & m.t1.newUts & \ m.t1.oldUts then
if translate(right(pp, 1)) == 'G' ,
& strip(left(pp, length(pp) - 1)) > 2 then do
/* piecesize invalid before alter to UTS| */
m.x1.fun = 'ae'
call mAdd chOpt, 'ix' m.x1.fun m.x1.qual'.'m.x1.name
call ddlAddAlt x1, piecesize, '2G', pp
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
laTo = m.aa.1.to
call genChkStart oo, aa, 'PRE', chOpt
do ax=2 to m.aa.0
if wordPos(m.aa.ax.verb, 'CREATE ALTER') > 0 then
laTo = genAlter(oo, b, laTo, aa'.'ax, old)
end
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return
endProcedure genPre
/*--- postAnalysis: modify Analysis revert change from genPre ... ---*/
genPost: procedure expose m.
parse arg aa, oo
say time() strip(sysvar('syscpu')) 'genPost begin'
aFu = m.aa.fun
o1 = '?'
call ddlGenAcd
call ddlAltPartBySz
if aFu = 'ANA' then do
/* copy alters from aOpt to m.ts...alt.* */
do ix=m.inOpt.preBegin+1 to m.inOpt.0 ,
while abbrev(m.inOpt.ix, ' ')
parse var m.inOpt.ix w1 w2 w3 w4 .
if \ abbrev(m.inOpt.ix, ' ') then do
u1 = translate(w1)
call mAdd chOpt, substr(m.inOpt.ix, 5)
o1 = '?'
if wordPos(w1, 'ix ts') < 1 then
call err 'not ix or ts in aOpt' ix':' m.inOpt.ix
else do
if symbol('M.ddl.u1.w3') == 'VAR' then do
o1 = m.ddl.u1.w3
m.o1.fun = w2
if w3 \== m.o1.qual'.'m.o1.name then
call err 'mismatch aOpt' ix':' m.inOpt.ix
end
else if w1 <> 'ix' then
call err w1 w3 'from aOpt missing in ana',
ix':' m.inOpt.ix
end
end
else do
if w3 \== '->' then
call err '-> missing in aOpt' ix':' m.inOpt.ix
if o1 \== '?' then
call ddlAddAlt o1, w1, w2, w4
else
call mAdd chOpt, substr(m.inOpt.ix, 5)
end
end
end
b = m.aa.buf'.BUF'
if m.aa.1.verb \== 'head' then
call err 'not head' o2Text(aa'.'1)
laTo = genAdd(oo, b, m.aa.1.fr, m.aa.1.to)
call genChkStart oo, aa, aFu, chOpt
do ddlAfterX = m.aa.0 by -1 to 2 while wordPos(m.aa.ddlAfterX.verb,
, 'ALTER CREATE DROP') < 1
end
if ddlAfterX = 1 then
say 'warning no DDL changes in analysis'
ddlAfterX = ddlAfterX + 1
ddlAfterX = ddlAfterX + (m.aa.ddlAfterX.verb == 'bp.SYNC')
if ddlAfterX > m.aa.0 then
call err 'ddlAFterX='ddlAFterX '>' m.aa.0'=m.'aa'.0'
genAlterEnd = 0
say time() strip(sysvar('syscpu')) 'genPost selRebi before'
call selRebiPkgs aa
say time() strip(sysvar('syscpu')) 'genPost selRebi after'
toEnd = ''
cSet = 0
do ax=2 to m.aa.0
if ax == ddlAfterX then do
genAlterEnd = genAlterEnd + 1
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
if toEnd <> '' then
call genAlterEnd oo, b, toEnd
end
o = m.aa.ax.obj
if m.aa.ax.verb == 'bp.SYNC' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
call genSync oo, b, aa'.'ax
laTo = m.aa.ax.to
end
else if m.aa.ax.verb = 'bp.CALL' then do
if m.aa.ax.obj = 'SNAPSHOT' then do
ax = genSnapshot(aa, ax, oo, b, laTo)
laTo = m.aa.ax.to
end
else if anaIsRebind(aa, ax) then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = genRebind(oo, b, aa, ax)
laTo = m.aa.ax.to
end
end
else if m.aa.ax.verb == 'SET' & m.aa.ax.obj <> '' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
if cSet = 0 then
call genAdd1 oo, 5, "set current sqlid = 'S100447';"
cSet = cSet + 1
laTo = m.aa.ax.to
end
else if m.aa.ax.verb == 'ALTER' & pos('e', m.o.fun) > 0 then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = ax + 1
ax = ax - (m.aa.ax.verb \== 'bp.SYNC')
laTo = m.aa.ax.to
if wordPos(o, toEnd) < 1 then
toEnd = toEnd o
end
else if m.aa.ax.verb == 'ALTER' then do
laTo = genAdd(oo, b, laTo, m.aa.ax.fr)
ax = genAlterMergePart(0, aa, ax, oo, b, new)
laTo = m.aa.ax.to
end
else if m.aa.ax.verb == 'CREATE' then do
laTo = genAlter(oo,b,laTo, aa'.'ax, new)
end
else if m.aa.ax.verb == 'DROP' then do
aO = m.aa.ax.obj
if pos(m.aO.type, 'TB TS') > 0 then
laTo = genDrop(oo, b, laTo, aa, ax)
end
else if abbrev(m.aa.ax.verb, 'md.') then do
isUL = wordPos(substr(m.aa.ax.verb ,
, lastPos('.', m.aa.ax.Verb)), '.UNLOAD .FUNLD') > 0
do sx=1 to m.aa.ax.sub.0
s1 = aa'.'ax'.SUB.'sx
if m.s1.verb == 'cont' then do
ll = m.s1.obj
laTo = genAdd(oo, b, laTo, m.s1.fr)
call genAdd1 oo, 1, left(ll, 72)
do lx=73 by 68 to length(ll)
call genAdd1 oo, 1, '--++'substr(ll, lx, 68)
end
laTo = m.s1.to
end
else if m.s1.verb == 'bp.SYNC' then do
laTo = genAdd(oo, b, laTo, m.s1.fr)
call genSync oo, b, s1
laTo = m.s1.to
end
else if isUl & m.s1.verb == 'bp.DATA' then do
do sy=1 to m.s1.sub.0
s2 = s1'.SUB.'sy
if m.s2.verb == 'bp.lobCols' then do
laTo = genAdd(oo, b, laTo, m.s2.to)
call genLobCols oo, aa'.'ax, s2
end
end
end
end
end
end
if genAlterEnd \== 1 then
call err 'genAlterEnd' genAlterEnd 'times'
ax = m.aa.0
laTo = genAdd(oo, b, laTo, m.aa.ax.to)
call genRebindAddMiss oo, aa
bx = m.b.0
laTo = genAdd(oo, b, laTo, m.b.0 length(m.b.bx)+1)
call checkL72 oo
return
endProcedure genPost
archive: procedure expose m.
parse arg dbSys, dsn, st
if st \== '' & words(dsn) \== 1 then
call err 'archive('dsn',' st') incompatible'
dt = 'D'translate(345678, left(m.myTst ,10), '1234-56-78'),
|| '.T'translate(123456, substr(m.myTst, 12, 8),'12.34.56')
do dx=1 to words(dsn)
d1 = word(dsn, dx)
mbr = dsnGetMbr(d1)
llq = substr(d1, lastPos('.', d1) + 1)
cx = pos('.##DT##.', d1)
if cx <= 0 then do
if mbr = '' then
call err 'archive' d1 'without member'
llq = left(llq, pos('(', llq) - 1)
oDsn = 'DSN.DBY'dbSys'.'mbr'.'dt'.'llq ,
'::f mgmtClas(com#a049)'
if st == '' then do
call readDsn d1, i.
call writeDsn oDsn, i., , 1
end
else do
call writeDsn oDsn, 'M.'st'.', , 1
end
end
else do
if mbr <> '' | cx + 7 + length(llq) <> length(d1) then
call err 'archive' d1 'with member'
dN = left(d1, cx)dt'.'llq
ar = adrTso("rename '"d1"' '"dN"'", '*')
if ar = 0 then
say 'renamed' d1 'to' dN
else if pos('NOT IN CATALOG', m.tso_trap) > 0 then
say d1 'not in catalog, not renamed'
else
call err 'could not rename' d1 'to' dN'\n'm.tso_trap
end
end
return 0
endProcedure archive
genQuick: procedure expose m.
parse arg out
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
if wordPos(t1, 'DATABASE FUNCTION IX' ,
'PROCEDURE TB TRIGGER TS VW') < 1 then
iterate
do dy=1 to m.d1.0
o = d1'.'dy
v = m.o.acd
/* if pos('d', v) >0 | (pos('a', v) >0 & pos('c', v) <1) then
rv162 is fixed, we can generate also dropped objs | */
call rcmQuickAdd out, m.o.type, m.o.qual, m.o.name
end
end
return
endProcedure genQuick
genRebind: procedure expose m.
parse arg o, b, aa, ax
ay = ax+1
az = aa'.'ay'.SUB.1'
rb = m.az.verb
if \ anaIsRebind(aa, ax) | \ abbrev(rb, 'rebind.') then
call err 'not a rebind' aa ax m.aa.ax.verb m.az.verb
k = m.az.obj
p = selPkgOne(k)
if \ abbrev(p, '-') then
if \ ( (rb == 'rebind.pkg' & pos(m.p.type, ' F') > 0) ,
| (rb == 'rebind.tri' & m.p.type == 'T') ) then
call err rb 'but pkg type='m.p.type 'for' k
if m.p.doRb == 'no' | m.p.doRb == 'sysEnt>0' then do
if abbrev(p, '-') then
call genAddCont o, '--noRebind' substr(p, 2) k
else
call genAddCont o, '--noRebind necessary' m.p.vot k
do aq=ay+1 while m.aa.aq.verb == 'bp.SYNC'
end
return aq-1
end
if wordPos(m.p.doRb, 'last creT new7') > 0 then do
if m.p.missing then do
r = '--rebindMiss' m.p.doRb m.p.vot k 'in anaPost'
say r
call genAddCont o, r
end
call genAdd o, b, m.aa.ax.fr, m.aa.ax.to
m.p.gen = 1
return ax
end
else
call err 'bad doRb='m.p.doRb 'for pkg' k
endProcedure genRebind
genRebindAddMiss: procedure expose m.
parse arg o, aa
do px=1 to m.rebi.0
p = 'REBI.'px
if m.p.gen == 1 | m.p.doRb == 'no' then
iterate
k = strip(m.p.collid)'.'strip(m.p.name) ,
|| ':'strip(m.p.version)
if m.p.gen == 2 then
call err 'duplicate pkg' k
m.p.gen = 2
call genAddCont o,'--rebindAdd' m.p.doRb m.p.vot k 'by anaPost'
call mAdd o, '-- cre='m.p.timestamp 'las='m.p.lastUsed ,
, '.CALL DSN PARM('m.aa.dbSys')' ,
, '.DATA'
if pos(m.p.type, ' F') > 0 then
call mAdd o, ' REBIND PACKAGE( -' ,
, ' ' strip(m.p.collid)'.'strip(m.p.name) ,
|| '.('strip(m.p.version)'))'
else if m.p.type == 'T' then
call mAdd o, ' REBIND TRIGGER PACKAGE( -' ,
, ' ' strip(m.p.collid)'.'strip(m.p.name)')'
else
call err 'implement rebind type='m.p.type 'for' k
call mAdd o, '.ENDDATA '
call genSyncTx o, ".SYNC ? 'REBIND PACKAGE'"
call mAdd o, ' '
end
return
endProcedure genRebindAddMiss
/*--- find all packages to rebind
from list of ddl objects, after parOld is added to ix --------*/
selRebiPkgs: procedure expose m.
parse arg aa
cr.0 = 0 /* group the dependencies by creator */
m.rebiM0 = 0
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
do dy=1 to m.d1.0
o = d1'.'dy
if t1 == 'IX' then do /* rebind everybody using table */
if m.o.parOld == '' then do
/* for test only, try to guess name of dropped table ?????? */
n = 'T'substr(m.o.name, 2, length(m.o.name)-3)'A1'
m.o.parOld = ddlGetNew('TB', m.o.qual, n)
end
if m.o.par \== '' then
call selRebiPkgAdd m.o.par
if m.o.parOld \== '' & m.o.par \== m.o.parOld then
call selRebiPkgAdd m.o.parOld
end
else if t1 == 'TRIGGER' ,
| ( wordPos(t1, 'FUNCTION PROCEDURE TB TS VW') > 0 ,
& pos(m.o.acd, ' d,a d, ') <= 0) then
/* everything that is not dropped without recreate
really new objects are not in packDep yet */
call selRebiPkgAdd o
end
end
/* build the where condition for sysPackDep */
bTy.ALIAS = "bType = '0'"
bTy.FUNCTION = "bType = 'F'"
bTy.IX = "bType = 'I'"
bTy.PROCEDURE = "bType = 'O'"
bTy.TB = "bType in ('G', 'M', 'T')"
bTy.TRIGGER = "bType = 'E'"
bTy.TS = "bType in ('P', 'R')"
bTy.VW = "bType = 'V'"
sDep = "union all select dLocation, dCollid, dName, dContoken" ,
"from sysibm.syspackdep" ,
"where dType not in ('O', 'P')"
s = ''
do cx = 1 to cr.0
c1 = cr.cx
s2 = ''
s3 = ''
do cy=1 to words(cr.c1)
t2 = word(cr.c1, cy)
s2 = s2 || cr.c1.t2
s3 = s3 "or (bName in ("substr(cr.c1.t2,3)") and" bTy.t2")"
end
s = s sDep "and bqualifier = '"c1"' and bName in" ,
"("substr(s2, 3)") and (" substr(s3, 4) ")"
end
if s = '' then do
say 'no objects found that may have package dependencies'
m.rebi.0 = 0
return
end
say '???packSel' s
m.packDepSql = "select p.collid, p.name, p.version, p.type" ,
", p.valid || p.operative || p.type vot" ,
", p.contoken, p.timestamp, p.timestamp, p.lastUsed" ,
", case when sysEntries <> 0 then 'sysEnt>0'",
"when lastUsed>current date-10 days then 'last'",
"when timestamp>current timestamp-7 days then 'creT'",
"when not exists (select 1" ,
"from sysibm.syspackage r" ,
"where r.location=p.location and r.collid=p.collid",
"and r.name = p.name" ,
"and r.timestamp > p.timestamp" ,
"and r.timestamp <= current timestamp - 7 days)",
"then 'new7' else 'no' end doRb",
"from sysibm.sysPackage p"
sql = "with d1 as (" substr(s, 11) ")" ,
", d as ( select dLocation, dCollid, dName, dContoken" ,
"from d1",
"group by dLocation, dCollid, dName, dContoken )",
m.packDepSql "join d" ,
"on dLocation = location and dCollid = collid",
"and dName = name and dConToken = conToken"
call sql2St sql, rebi
/* the index to packages to rebind
and count pkg by reasons not to bind */
do rx=1 to m.rebi.0
m.rebi.rx.missing = 0
k = strip(m.rebi.rx.collid)'.'strip(m.rebi.rx.name) ,
|| ':'strip(m.rebi.rx.version)
dr = m.rebi.rx.doRb
cL = 'last creT new7 no sysEnt>0'
if symbol('c.dr') == VAR then
c.dr = c.dr + 1
else do
c.dr = 1
if wordPos(dr, cL) < 1 then
cL = cL dr
end
/*say k m.rebi.rx.doRb m.rebi.rx.vot */
m.rebi.k = 'REBI.'rx
end
cM = m.rebi.0 'dependent packages'
do cx=1 to words(cL)
c1 = word(cL, cx)
if symbol('c.c1') == 'VAR' then
cM = cM',' c.c1 c1
end
say cM
return
endProcedure selRebiPkgs
/*--- add one dependency, grouped by creator ------------------------*/
selRebiPkgAdd: procedure expose m. cr.
parse arg o
q = m.o.qual
n = m.o.name
t = m.o.type
if q = '' | n = '' then
call err 'empty qual or name' o2Text(o)
if cr.t.q.n == 1 then
return
if symbol('cr.q') \== 'VAR' then do
cr.q = ''
cx = cr.0 + 1
cr.0 = cx
cr.cx = q
end
if symbol('cr.q.t') \== 'VAR' then do
cr.q = cr.q t
cr.q.t = ''
end
cr.q.t = cr.q.t", '"n"'"
cr.t.q.n = 1
return
endProcedure selRebiPkgAdd
/*--- return pkg info, select for sysPack if not already done -------*/
selPkgOne: procedure expose m.
parse arg k
if symbol('m.rebi.k') == 'VAR' then
return m.rebi.k
parse arg co '.' pk ':' ve
if symbol('m.rebiCoPk.co.pk') == 'VAR' then do
r = '-not in sysPackage'
m.r.doRb = 'no'
return r
end
say 'selecting missing package' co'.'pk
m.rebiCoPk.co.pk = 1
m.rebiM0 = m.rebiM0 + 1
rm = 'REBIM'm.rebiM0
sql = m.packDepSql "where location ='' and collid = '"co"'" ,
"and name = '"pk"'"
call sql2St sql, rm
do rx=1 to m.rm.0
km = strip(m.rm.rx.collid)'.'strip(m.rm.rx.name) ,
|| ':'strip(m.rm.rx.version)
if symbol('m.rebi.km') == 'VAR' then
iterate
m.rebi.km = rm'.'rx
m.rm.rx.missing = 1
end
return selPkgOne(k)
endProcedure selPkgOne
genChkStart: procedure expose m.
parse arg o, m, fun, ch
call mAdd o, '--## anaPost modifying analysis' m.myTst ,
, '--## dbSys =' m.m.dbSys ,
, '--## fun =' fun ,
, '--## in =' m.m.inDsn ,
, '--## ' m.m.straCrNm m.m.anaTst,
, '--## out =' m.m.outDsn
if fun = 'PRE' & m.ch.0 > 0 then
call mAdd o, '--##* overwriting new values from ddl' ,
, '--##* by old values from' m.m.dbSys ,
, '--##* attribute old -> new',
, '--##*'
if fun = 'ANA' & m.ch.0 > 0 then
call mAdd o, '--##* overwriting old values from' m.m.dbSys ,
, '--##* by new values from ddl' ,
, '--##* attribute old -> new',
, '--##*'
if wordPos(fun, 'PRE ANA') > 0 then
do ix=1 to m.ch.0
call mAdd o, '--## ' m.ch.ix
end
if fun = 'REC' then
call mAdd o, '--## recovery =' m.m.straCrNm m.m.anaTst,
, '--## of' m.m.mbr m.fTst ,
, '.CONNECT' m.m.dbSys ,
, '||||Achtung |||||||||||||||||||||||||||||||||||||||',
, ' diese Recovery Analyse darf nicht so laufen; ',
, ' wie sie hier generiert ist| ',
, ' recovery unloads sind zu ueberpruefen ; ',
, ' und/oder nur als ddl vorlage zu benutzen ; ',
, ' ; abend ; abend; abend; abend; abend; ',
, '|||||||||||||||||||||||||||||||||||||||||||||||||||',
, '.DISCONN'
m.lastSync = 3
if fun = 'PRE' | fun = 'DDL' then
return
call madd o, '--##begin chkstart: avoid duplicate runs' ,
, '.CALL IKJEFT01 INDDN(SYSTSIN) OUTDDN(SYSTSPRT)' ,
'SYSLIB NONAPF' ,
, ' .DATA' ,
, ' %chkStart dbSys='m.m.dbSys '+' ,
, ' 'fun'='m.m.straCrNm m.m.anaTst '+'
if fun == 'ANA' then
call mAdd o, ' ddl='m.m.outDsn
else
call mAdd o, ' ddl='m.m.outDsn '+' ,
, ' of='m.m.mbr m.m.anaTst
call mAdd o, ' .ENDDATA' ,
, ".SYNC 3 'checkStart' " ,
, '--##end chkStart: avoid duplicate runs'
return
endProcedure genChkStart
genDrop: procedure expose m.
parse arg o, i, laTo, aa, ax
if m.aa.fun \== 'ANA' then
return laTo
dOb = m.aa.ax.obj
if m.dOb.type == 'TS' then do
dTs = dOb
dTb = ''
end
else if m.dOb.type == 'TB' then do
dTb = dOb
dTs = ddlPar(dOb)
end
ul = ''
if dTs \== '' then
ul = ddlGetUnl(dTs)
if ul == '' then
if dTb \== '' then
ul = ddlGetUnl(dTb)
else do tx=1 to m.ddl.tb.0 while ul = ''
if ddlPar('DDL.TB.'tx) == dTs then
ul = ddlGetUnl('DDL.TB.'tx)
end
nm = m.dOb.type m.dOb.qual'.'m.dOb.name
if ul == '' then do
if m.aa.noUnload then
say 'drop' nm 'not unloaded ok because noUnload'
else
call err 'drop' nm 'but no Unload'
return laTo
end
if \ posLess(m.ul.to, m.aa.ax.fr) then
call err 'drop' nm '@'m.aa.ax.fr 'before unload @'m.ul.to
ay = ax - 1
if ay < 1 | m.aa.ay.verb \== 'bp.SYNC' then
call err 'no syncPoint before drop' nm':' m.aa.ax.fr
ay = ax + 1
if ay > m.aa.0 | m.aa.ay.verb \== 'bp.SYNC' then
call err 'no syncPoint after drop' nm':' m.aa.ax.fr
call mAdd o,,left('--##begin anaPost -dis for' nm, 80) ,
, ' .CALL DSN PARM('m.aa.dbSys')' ,
, ' .DATA' ,
, ' -DIS DB('m.dTs.qual') SPACE('m.dTs.name')' ,
'LIMIT(*)' ,
, ' .ENDDATA' ,
, left('--##end anaPost -dis for' nm, 80) ,
, ''
if m.dOb.type \== 'TB' then
return laTo
laTo = genAdd(o, i, laTo, m.aa.ax.to)
call mAdd o,,left('--##begin anaPost -sta for' nm, 80) ,
, ' .CALL DSN PARM('m.aa.dbSys')' ,
, ' .DATA' ,
, ' -STA DB('m.dTs.qual') SPACE('m.dTs.name')' ,
'ACCESS(RW)' ,
, ' .ENDDATA' ,
, left('--##end anaPost -sta for' nm, 80) ,
, ''
return laTo
endProcedure genDrop
genSnapshot: procedure expose m.
parse arg aa, ax, o, i, laTo
ax = ax+1
if m.aa.ax.verb <> 'bp.ALLOC' ,
| \ abbrev(m.aa.ax.obj, 'FI(RCVRFILE)') then
call err '.ALLOC FI(RCVRFILE) expected after snapshot'
ix = 1 + word(m.aa.ax.fr, 1)
li = strip(m.i.ix)
qx = pos("'", li, 5)
if \ abbrev(li, "DA('") | qx < 5 then
call err "DA('...' expected after .alloc in snapshot"
rDs = substr(li, 5, qx-5)
if dsnGetMbr(rDs) <> m.aa.stra then
call err 'stra='m.aa.stra '<> member in rcvrfile' rds
ax = ax+1
if m.aa.ax.verb <> 'bp.DATA' then
call err '.DATA expected after snapshot'
ax = ax+1
if m.aa.ax.verb <> 'bp.FREE' | m.aa.ax.obj <> 'FI(RCVRFILE)' then
call err '.FREE expected after snapshot'
ax = ax+1
if m.aa.ax.verb <> 'bp.SYNC' then
call err '.SYNC expected after snapshot'
laTo = genAdd(o, i, laTo, m.aa.ax.fr)
call genSync o, i, aa'.'ax
cx = lastPos('.', rDs)
cy = pos('(', rDs, cx + 1)
if cx <= 0 | cy <= cx then
call err 'bad recovery dsn' rDs
oDs = left(rDs, cx)'REC'substr(rDs, cy)
call mAdd o,,'--##begin anaPost on snapshot analyse' ,
, '.CALL IKJEFT01 INDDN(SYSTSIN) OUTDDN(SYSTSPRT)' ,
'SYSLIB NONAPF' ,
, ' .DATA' ,
, ' %anaPost rec' m.aa.dbSys rDs '+' ,
, ' ' oDS '+' ,
, ' of' m.aa.stra m.aa.anaTst ,
, ' .ENDDATA' ,
, '--##end anaPost on snapshot analyse'
call genSyncTx o, ".SYNC ? 'anaPost of snapshot'"
return ax
endProdedure genSnapshot
genLobCols: procedure expose m.
parse arg o, mdl, lb
lobs = m.lb.obj
tb = m.mdl.obj
call sqlQuery 1, "select name, colType from sysibm.sysColumns",
"where tbCreator = '"m.tb.qual"' and tbName = '"m.tb.name"'" ,
"order by case when colType like '%LOB%'" ,
"or colType like '%XML%' then 1 else 0 end, colno"
lft = ' ('
do fx=1 while sqlFetch(1, f1)
call mAdd o, lft m.f1.name m.f1.colType
lft = ' ,'
end
if fx <= 1 then do
call mAdd o, '||| no cols |||||||'
call aOptErr 'post.noCols', 'no columns in' ,
m.tb.qual'.'m.tb.name
end
call mAdd o, ' )', ' SPANNED YES' , '--UNLOAD--LOBCOLS end'
call sqlClose 1
return ix
endProcedure genLobCols
genSyncTx: procedure expose m.
parse arg out, tx
tx = strip(tx)
parse var tx tV tN tT
if tV \== '.SYNC' then
call err 'bad syncpoint text' tx
if datatype(tn, 'n') & tn > m.lastSync then
m.lastSync = tn
else do
m.lastSync = m.lastSync + 1
tx = tV m.lastSync tT
end
tT = strip(tT)
if tT <> '' then
if \ (abbrev(tT, "'") & pos("'", tT, 2) = length(tT)) then
tx = subWord(tx, 1, 2) "'"strip(translate(tt, ' ', "'"))"'"
if length(tx) > 70 then do
tx = space(tx, 1)
if length(tx) > 70 then
tx = left(tx, 66)"...'"
end
call mAdd out, tx
return 0
endProcedure genSyncTx
genSync: procedure expose m.
parse arg out, in, an
ix = word(m.an.fr, 1)
if abbrev(m.in.ix, '--##.SYNC') then
return genSyncTx(out, substr(m.in.ix, 5))
else
return genSyncTx(out, m.in.ix)
endProcedure genSync
/*--- generate DDL with altered attributes, add semicolon -----------*/
genAlter: procedure expose m.
parse arg out, in, laTo, aNo, col, ign, rm
o = m.aNo.obj
if pos('a', m.o.fun) <= 0 then
return laTo
/* say m.o.type m.o.qual'.'m.o.name m.o.fun */
if m.aNo.sub.1.verb \== 'ddlHead' then
call err 'no ddlHead' o2text(aNo'.SUB.1') 'in' o2text(aNo)
head = aNo'.SUB.1'
if posLess(laTo, m.aNo.fr) then
laTo = genAdd(out, in, laTo, m.aNo.fr)
parse var m.aNo.to tL tC
if genAlterHd(out, in, head, aNo, col, ign, rm) then
call genAdd out, in, tL tC-1, tL tC
return tL tC
endProcedure genAlter
/*--- generate DDL with altered attributes, without semicolon
if create add missing altered attributes ---------------*/
genAlterHd: procedure expose m.
parse arg out, in, head, aNo, col, ign, rm
o = m.aNo.obj
/* say m.o.type m.o.qual'.'m.o.name m.o.fun */
done = 0
laTo = m.aNo.sub.1.to
part = ''
do sx = 2 to m.aNo.sub.0
s1 = aNo'.SUB.'sx
if laTo <> m.s1.fr then
call genAlterHdAddTo laTo, m.s1.fr
laTo = m.s1.to
v1 = substr(m.s1.verb, 4)
if m.s1.verb == 'part' then do
part = s1
end
else if \ abbrev(m.s1.verb, 'at.') | wordPos(v1, ign) > 0 ,
| symbol('m.o.alt.'v1) \== 'VAR' then do
call genAlterHdAddTO m.s1.fr, m.s1.to
end
else do
a1 = m.o.alt.v1
done.v1 = 1
if m.a1.col \== '-' & wordPos(v1, rm) < 1 then do
call genAlterHdAddTo
call genAdd1 out, 9, v1 m.a1.col
end
end
end
parse var m.aNo.to tL tC
if substr(m.in.tL, tC-1, 1) \== ';' then
call err ', expected at end of' o2text(aNo)
if laTo <> tL tc-1 then
call genAlterHdAddTo laTo, tL tC-1
if m.aNo.verb == 'CREATE' then do
do ax=1 to m.o.alt.0 /* add altered attributes */
a1 = o'.ALT.'ax
v1 = m.a1.att
if m.a1.col \== '-' & done.v1 \== 1 then do
call genAlterHdAddTO
call genAdd1 out, 9, v1 m.a1.col
end
end
end
return done
endProcedure genAlterHd
genAlterHdAddTo: /* add alter and partition part */
parse arg addFrX, addToX
if head \== '' then do
call genAdd out, in, m.head.fr, m.head.to
head = ''
end
if part \== '' then do
call genAdd out, in, m.part.fr, m.part.to
part = ''
end
if addFrX \== '' then
call genAdd out, in, addFrX, addToX
done = 1
return
endSubroutine genAlterHdAddTo
/*--- merge alter Parts and alter attributes
swallow syncpoints ----------------------------------------*/
genAlterMergePart: procedure expose m.
parse arg inDir, qq, qx, out, in, col ,ign, rm
aa = qq'.'qx
if inDir then
aa = m.aa
o1 = m.aa.obj
if m.aa.sub.1.verb \== 'ddlHead' then
call err 'no ddlHead' o2text(aa'.SUB.1') 'in' o2text(aa)
head = aa'.SUB.1'
if \ genAlterHd(out, in, head, aa, col, ign, rm) then
return qx
parse var m.aa.to toL toC
if substr(m.in.toL, toC-1, 1) \== ';' then
call err 'not ; at end of alter:' m.aa.to':' m.in.toL
if m.aa.verb \== 'ALTER' | m.aa.sub.1.verb \== 'ddlHead' ,
| m.aa.sub.2.verb \== 'part' then do
call genAdd out, in, toL toC-1, m.aa.to
return qx
end
do qx = qx+1 to m.qq.0
aa = qq'.'qx
if inDir then
aa = m.aa
if m.aa.verb = 'bp.SYNC' then
iterate
if m.aa.verb \== 'ALTER' | m.aa.sub.1.verb \== 'ddlHead' ,
| m.aa.sub.2.verb \== 'part' | m.aa.obj \== o1 then
leave
call genAlterHd out, in, , aa, col, ign, rm
end
call genAdd1 out, 6, ';'
qx = qx - 1
aa = qq'.'qx
if inDir then
aa = m.aa
return qx - (m.aa.verb = 'bp.SYNC')
endProcedure genAlterMergePart
/*--- append remaining alters ---------------------------------------*/
genAlterEnd: procedure expose m.
parse arg oo, b, toEnd
attEnd = 'MAXPARTITIONS SEGSIZE DSSIZE MAXROWS PIECESIZE'
/* segSize AFTER maxParts for migration to PGB| */
call mAdd oo, '----- moved alter TS to end of DDL ------'
do ox=1 to words(toEnd)
o = word(toEnd, ox)
done = 0
do vx=1 to m.o.aNo.0
v1 = m.o.aNo.vx
if m.v1.verb \== 'ALTER' then
iterate
vx = genAlterMergePart(1, o'.ANO', vx,
, oo, b, new, , attEnd)
done = 1
end
if done then
call genSyncTx oo, ".SYNC ? 'alter",
m.o.type m.o.qual'.'m.o.name"'"
done = 0
do wx=1 to words(attEnd)
w1 = word(attEnd, wx)
if symbol('m.o.alt.w1') == 'VAR' then do
a2 = m.o.alt.w1
n = m.a2.new
if n = '-' & w1 = maxRows then
n = 255
if n \== '-' then do
done = 1
if m.o.type = 'IX' then
call mAdd oo, '-- alter index',
m.o.qual'.'m.o.name ,
, '-- ' m.a2.att n';',
, '-- not allowed here'
else
call mAdd oo, ' alter tablespace',
m.o.qual'.'m.o.name ,
, ' ' m.a2.att n';'
end
end
end
if done then
call genSyncTx oo, ".SYNC ? 'alter",
m.o.type m.o.qual'.'m.o.name"'"
end
return
endProcedure genAlterEnd
/*--- add to o from i (fLi fCh) to i (tLi tCh) ----------------------*/
genAdd: procedure expose m.
parse arg o, i, fLi fCh, tLi tCh
if fLi >= tLi then do
if posLess(tLi tCh, fLi fCh) then
call err 'fr after to' fLi fCh',' tLi tCh
call genAdd1 o, fCh, substr(m.i.fLi, fCh, tCh-fCh)
end
else do
call genAdd1 o, fCh, substr(m.i.fLi, fCh)
ox = m.o.0
do ix = fLi + 1 to tLi - 1
ox = ox+1
m.o.ox = m.i.ix
end
if left(m.i.tLi, tCh-1) <> '' then do
ox = ox + 1
m.o.ox = left(m.i.tLi, tCh-1)
end
m.o.0 = ox
if ix <> tLi then
call err 'mismatch'
end
return tLi tCh
endProcedure genAdd
genAdd1: procedure expose m.
parse arg o, ch, tx
ox = m.o.0
if tx = '' then
return
else if ox < 1 then
ox = ox + 1
else if m.o.ox = '' then
nop
else if ch <= 1 then
ox = ox + 1
else if substr(m.o.ox, ch) <> '' then
ox = ox + 1
else if pos(substr(m.o.ox, ch-1, 1), ' ;+-*<>') < 1 ,
& pos(left(tx, 1), ' ;+ /<>') < 1 then
ox = ox + 1
else do
m.o.ox = left(m.o.ox, ch-1)tx
return
end
m.o.0 = ox
m.o.ox = left('', ch-1)tx
return
endProcedure genAdd1
genAddCont: procedure expose m.
parse arg o, tx
ox = m.o.0
ox = ox + (m.o.ox <> '')
if length(tx) <= 72 then do
m.o.ox = tx
end
else do
tx = strip(tx, 't')
if length(tx) <= 72 then
m.o.ox = tx
else if \ abbrev(strip(tx), '--') then
call err 'overflow in non comment:' tx
else do
m.o.ox = left(tx, 72)
do cx = 73 by 68 to length(tx)
ox = ox + 1
m.o.ox = '--++'substr(tx, cx, 68)
end
end
end
m.o.0 = ox
return
genAddCont
/*--- check no line in the stem is longer 72 ------------------------*/
checkL72: procedure expose m.
parse arg st
do sx=1 to m.st.0
if length(m.st.sx) > 72 then do
m.st.sx = strip(m.st.sx, 'T')
if length(m.st.sx) > 72 then
if \ (length(m.st.sx) <= 80,
& abbrev(strip(m.st.sx), '--')) then
call err 'line overflow' st'.'sx m.st.sx
end
end
return
endProcedure checkL72
/* analyse an analysis ***********************************************/
/*--- analyse an analysis ==> gen list of aNodes etc. ---------------*/
anaAna:procedure expose m.
parse arg m
sQ = scanOpen(scanSqlOpt(scanSqlReset(m'.SCSQL', m.m.buf, 72 22),
, m.ut_alfa'#@$'))
call jPosBefore m.m.buf, 1
sR = scanOpen(scanSqlOpt(scanSqlReset(m'.SCREA', m.m.buf '-', 0),
, m.ut_alfa'#@$'))
m.m.conStra = ''
m.m.stra = ''
m.m.straSrc = ''
m.m.straTrg = ''
m.m.noUnload = 0
ax = 1
a = aNodeClear(m'.'ax, 'head', , scanPos(sR))
do forever
if \ abbrev(m.sR.src, '--') then do
if scanLit(sR, '.CONTROL SN(') then do
if \ scanUntil(sR, ')') then
call scanErr sR, 'bad .control'
parse var m.sR.tok cr ',' st
if cr = '' | st = '' then
call scanErr sR, 'bad creator/name in .control'
if m.m.conStra \== '' then
call scanErr sR, 'duplicate .control'
m.m.conStra = strip(cr)'.'strip(st)
end
else if m.sR.src <> '' then
leave
call scanNl sR, 1
end
else if abbrev(m.sR.src, '--##') ,
| pos('*** END ANALYSIS HEADER **', t1) > 0 then do
leave
end
else if abbrev(m.sR.src, '-- RMA') then do
call anaRma m, sR
end
else do
if \ scanLit(sR, '--') then
call scanErr sR, 'bad header line'
call scanNl sR, 1
t1 = strip(m.sR.tok)
if abbrev(t1, 'RMA') then
call scanErr sR, 'RMA in header'
if pos('CA-DB2', t1) > 0 then do
cx = pos(' Analysis Report ', t1)
if cx < 0 then
call scanErr sR, 'Analysis Report missing'
m.m.RCMVers = word(t1, 1)
t2 = space(subWord(substr(t1, cx), 3, 4), 1)
m.m.anaTst = tst2db2(t2, '-')
if m.m.anaTst == '-' then
call scanErr sR, 'bad timestamp' t2
say 'RC/M vers='m.m.rcmVers 'anaTst='m.m.anaTst
end
else if abbrev(t1, 'Strategy ==> ') then do
m.m.stra = word(t1, 3)
cx = wordPos('Description', t1)
if cx <= 2 | word(t1, cx+1) \== '===>' then
call scanErr sR, 'strategy description expected'
m.m.straDesc = strip(subWord(t1, cx+2))
if \ (scanNl(sR, 1) ,
& abbrev(m.sR.tok, '--Creator ==> ') ) then
call scanErr sR, 'strategy creator expected'
m.m.straCrNm = word(m.sR.Tok, 3)'.'m.m.stra
cx = pos(' Src SSID ===> ', m.sR.Tok)
if cx < 1 then
call scanErr sR, 'strategy src ssid expected'
m.m.straSrc = word(substr(m.sR.Tok, cx + 15), 1)
say 'strategy='m.m.straCrNm ,
'srcSSID='m.m.straSrc 'desc='m.m.straDesc
end
else if abbrev(t1, 'Target SSID ') then do
if word(t1, 3) \=='===>' then
call scanErr sR, 'bad SSID'
m.m.straTrg = word(t1, 4)
end
end
end
do forever
if abbrev(m.sR.src, '-- RMA') then
call anaRMA m, sR
else if m.sR.src = '--' | m.sR.src = '' then
call scanNl sR, 1
else
leave
end
if m.m.stra = '' | m.m.straSrc m.straTrg = '' then
call scanErr sR, 'strategy header incomplete'
else if scanEnd(sR) then
call err 'end of file in header'
m.a.to = scanPos(sR)
ax = ax + 1
a = aNodeClear(m'.'ax)
do forever
r = 0
if scanSpaceOnly(sR) | scanNl(sR) then
iterate
if scanEnd(sR) then do
m.m.0 = ax - 1
return 1
end
m.a.fr = scanPos(sR)
if scanCom(sR) then do
if abbrev(m.sR.tok, '--##') then
r = anaModel(a, sR, m.sR.tok)
end
else if scanLook(sR, 1) == '.' then do
r = anaBP(m, ax, sR, 0)
end
else do
call scanSetPos sQ, m.a.fr
r = anaDdl(a, sQ)
call scanSetPos sR, scanPos(sQ)
end
if r then do
m.a.to = scanPos(sR)
ax = ax + 1
a = aNodeClear(m'.'ax)
end
end
endProcedure anaAna
anaRMA: procedure expose m.
parse arg m, s
if abbrev(m.s.src, '-- RMA233W NO UNLOADS') then
m.m.noUnload = 1
else if \ abbrev(m.s.src, '-- RMA') then
call scanErr s, 'not RMA'
say m.s.src
do while scanNl(s, 1) & abbrev(m.s.src, '-- ')
end
return
endProcedure anaRMA
/*--- analyze ca batchProcessor statement ---------------------------*/
anaBP: procedure expose m.
parse arg mm, mx, s, nst
m = mm'.'mx
call ANodeClear m, , ,scanPos(s)
call scanNl s, 1
parse var m.s.tok v r
upper v
m.m.verb = 'bp'v
m.m.obj = translate(strip(r))
if v \== '.DATA' then do
do while right(strip(m.s.tok), 1) == '+'
if \ scanNl(s, 1) then
call scanErr s, 'end in bp +' v
end
end
else do
my = mx-1
if m.mm.my.verb=='bp.CALL' & abbrev(m.mm.my.obj,'DSN PA') then
call anaBPRebind m, s
dx = m.m.sub.0 + 1
do forever
l1 = scanLook(s)
w1 = translate(word(l1, 1))
if \ abbrev(w1, '.') then do
if w1 == '--UNLOAD--LOBCOLS' ,
& l1 <> '--UNLOAD--LOBCOLS end' then do
s1 = ANodeClear(m'.SUB.'dx, 'bp.lobCols',
, subWord(l1, 2), scanPos(s))
dx = dx + 1
call scanNl s, 1
e2 = 'expected after lobCols'
if \(scanSqlId(scanSkip(s)) & m.s.val=='FROM')then
call scanErr s, 'from' e2
if \ (scanSqlId(scanSkip(s)) ,
& m.s.val == 'TABLE') then
call scanErr s, 'from table' e2
if \(scanSqlQuId(scanSkip(s)) & m.s.val.0 ==2)then
call scanErr s, 'from table ct.tb' e2
if scanSqlId(scanSkip(s)) then
if m.s.val \== 'HEADER' then
call scanBack s, m.s.tok
else
call scanNl s, 1
m.s1.to = scanPos(s)
end
else if \ scanNl(s, 1) then
call scanErr s, 'end in .data'
end
else if w1 == '.ENDDATA' then
leave
else if anaBP(m'.SUB', dx, s, nst+1) then do
dx = dx + 1
end
end
m.m.sub.0 = dx-1
call scanNl s, 1
end
m.m.to = scanPos(s)
return 1
endProcedure anaBP
anaBPRebind: procedure expose m.
parse arg m, s
pFr = scanPos(s)
if \ scanSqlId(scanSkipTso(s)) | m.s.val \== 'REBIND' then
return
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'bad rebind'
tri = m.s.val == 'TRIGGER'
eAR = 'expected after rebind ...'
if tri then
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'bad rebind trigger'
if m.s.val \== 'PACKAGE' then
call scanErr s, 'bad rebind ... package'
if \ scanLit(scanSkipTso(s), '(') then
call scanErr s, '(' eAR 'package'
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'collection' eAR '('
col = m.s.val
if \ scanLit(scanSkipTso(s), '.') then
call scanErr s, '.' eAR '(col'
if \ scanSqlId(scanSkipTso(s)) then
call scanErr s, 'package' eAR '(col.'
pkg = m.s.val
if \ scanLit(scanSkipTso(s), '.') then
vers = ''
else do
if \ scanLit(scanSkipTso(s), '(') then
call scanErr s, '(' eAR '(col.pkg.'
/* warning version may start with a digit, not and indent| */
if \ scanUntil(scanSkipTso(s), ')') then
call scanErr s, 'version' eAR '(col.pkg.('
vers = strip(m.s.tok)
if \ scanLit(scanSkipTso(s), ')') then
call scanErr s, ')' eAR '(col.pkg.(version'
end
if \ scanLit(scanSkipTso(s), ')') then
call scanErr s, ')' eAR '(col.pkg.(version'
if tri <> (vers == '') then
call scanErr s, 'rebind tri='tri 'but vers='vers
call aNodeAdd m'.SUB', 'rebind.'word('pkg tri', tri+1),
, col'.'pkg':'vers, pFr, scanPos(s)
return 1
endProcedure anaBPRebind
scanSkipTso: procedure expose m.
parse arg m
do forever
call scanSpaceOnly m
if substr(m.m.src, m.m.pos) <> '-' ,
& substr(m.m.src, m.m.pos) <> '+' then
return m
if \ scanNl(m, 1) | word(m.s.src, 1) == '.ENDDATA' then
return m
end
endProcedure scanSkipTso
/*--- analyze RC/M Model statements ---------------------------------*/
anaModel: procedure expose m.
parse arg m, s, li
parse upper var li bg md o1 oR .
if md == 'ANAPOST' & o1 = 'MODIFYING' then do
if \ (scanNl(s, 1) & translate(scanLook(s, 14)) ,
== '--## DBSYS ') then
call scanErr s, 'line 1 after anaPost'
if scanNl(s, 1) then
l1 = translate(scanLook(s))
m.m.verb = 'AnaPosHea'
if space(subWord(l1, 1, 3), 1) == '--## FUN =' then
m.m.obj = word(l1, 4)
else if left(l1, 14) == '--## ANALYS' ,
| left(l1, 14) == '--## RECOVE' then /* very old */
m.m.obj = left(word(l1, 2) , 3)
else
call scanErr s, 'line 2 after anaPost'
do while scanNl(s, 1),
& ( abbrev(m.s.src, '--## ') ,
| abbrev(m.s.src, '--##* ') | m.s.src = '' )
end
if m.m.obj == 'rec' & \ abbrev(m.s.src, '.DISCONN ') then
call scanErr s, 'no disconn after anaPost recovery'
return 1
end
else if bg \== '--##BEGIN' then do
call scanErr s, 'no model begin'
end
else if wordPos(md, 'CHKSTART: ANAPOST') > 0 then do
m.m.verb = strip(left(md, 8))
call scanNl s, 1
end
else if o1 \== 'OBJ' then do
call scanErr s, 'no OBJ in model begin'
end
else do
parse var md mCr '.' mPr '.' mMdl
if mMdl = '' then
call scanErr s, 'bad model'
m.m.verb = 'md.'mCr'.'mPr'.'mMdl
ll = anaModelOverflow(m, s, m.m.fr)
parse var ll . . . ty ':' cr '.' nm ':'
if wordPos(strip(ty), 'INDEX TABLE TABLESPACE') < 1 then
call scanErr s, 'bad model begin objType' oR
o = ddlGetNew(strip(ty), strip(cr), strip(nm))
m.m.obj = o
call mAdd o'.ANO', m
if \ scanCom(s) then
call scanErr s, 'second model line missing'
parse upper var m.s.tok cc t2 q2 '.' n2 ':'
if cc \== '--##' then
call scanErr s, 'second model line bad'
else if t2 \== 'DBTS' then
call scanErr s, 'second model bad objType' o1
else if m.o.type == 'TB' then
call ddlLink o, 'PAR', 'TS', strip(q2), strip(n2)
else if \ (m.o.type == 'IX' | ( m.o.type == 'TS' ,
& q2 == m.o.qual & n2 == m.o.name) ) then
call scanErr s, 'second model line dbTs <> dbTs'
call scanNl s
end
do forever
li = scanLook(s)
parse upper var li bg m2 .
if bg == '--##' | bg == '--##SYNC' ,
| bg == '' | bg == '--' then
/* ????? | bg == '' | abbrev(strip(li), '-- LOAD FROM ') ??? */
call scanNl s, 1
else if bg == 'LOCK' then do
call scanSqlStop s
end
else if mMdl == 'UNLOAD$R' then do
return 1
end
else if abbrev(bg, '.') then do
if anaBp(m'.SUB', m.m.sub.0 + 1, s, 0) then
m.m.sub.0 = m.m.sub.0 + 1
end
else if bg == '--##.SYNC' then do
bPos = scanPos(s)
ll = anaModelOverflow(m, s)
s1 = ANodeAdd(m'.SUB', 'bp.SYNC', subWord(ll, 2),
, bPos, scanPos(s))
end
else if bg \== '--##END' then
call scanErr s, 'bad model line bg='bg'|'
else if md \== m2 then
call scanErr s, 'mismatches end for model' md
else do
call anaModelOverflow m, s, scanPos(s)
return 1
end
end
endProcedure anaModel
/*--- if a comment overflows 72 characters,
ana will put it on the next line,
without marking it as comment => exe fails
here we mark the continuation with --++
and piece the whole comment together ---------------------*/
anaModelOverflow: procedure expose m.
parse arg m, s, pFr
ll = left(m.s.src, 72)
do lx=1 to 3
if \ scanNl(s, 1) then
leave
one = left(m.s.src, 72)
cx = verify(one, ' ')
if cx < 1 then do
call scanNl s, 1
leave /* empty line might occur at end of overflow*/
end
else if substr(one, cx, 1) == '.' then
leave /* probably batch process command */
else if substr(one, cx, 2) \== '--' then
ll = ll || one
else if substr(one, cx, 4) == '--++' then
ll = ll || substr(one, cx+4)
else
leave
end
ll = strip(ll, 't')
if lx > 1 & pFr \== '' then
s1 = aNodeAdd(m'.SUB', 'cont', ll, pFr, scanPos(s))
return ll
endProcedure anaModelOverflow
/*--- analyze sql DDL statement -------------------------------------*/
anaDdl: procedure expose m.
parse arg m, s
if \ scanSqlId(scanSkip(s)) then do
if scanLit(s, ';') then
return 0
call scanErr s, 'no id to start ddl'
end
v = m.s.val
m.m.verb = v
if wordPos(v, 'ALTER CREATE DROP') > 0 then
call anaACD m, s
else if v == 'SET' then
call anaSet m, s
else if wordPos(v, 'COMMENT COMMIT LABEL RENAME') > 0 then do
/* say 'ignoring' scanPos(s) m.s.tok scanLook(s, 50) */
call scanSqlStop s
return 0
end
else
call scanErr s, 'implement verb' v
call scanSqlStop s
return 1
endProcedure anaDdl
/*--- analyze sql SET statments -------------------------------------*/
anaSet: procedure expose m.
parse arg m, s
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'id expected after set'
if m.s.val == 'SCHEMA' | m.s.val == 'CURRENT_SCHEMA' then
m.m.obj = 'SCHEMA'
else if m.s.val == 'CURRENT' then
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'id expected after set current'
else if m.s.val == 'SQLID' | m.s.val == 'SCHEMA' then
m.m.obj = m.s.val
return
endProcedure anaSet
/*--- analyze sql DDL alter/create/drop -----------------------------*/
anaACD: procedure expose m.
parse arg m, s
v = m.m.verb
s1 = aNodeAdd(m'.SUB', 'ddlHead', , m.m.fr)
types = 'ALIAS DATABASE FUNCTION INDEX PROCEDURE' ,
'SEQUENCE SYNONYM TABLE TABLESPACE TRIGGER VIEW'
do sx=1
if \ scanSqlId(scanSkip(s)) then
call scanErr s, v 'type/prelude expected'
if wordPos(m.s.val, types) > 0 then
leave
if v <> 'CREATE' | sx >= 5 then
call scanErr s, 'after' v 'expected one of' types
m.s1.obj = strip(m.s1.obj m.s.val)
end
ty = m.s.val
if \ scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then
call scanErr s, 'name expected after' v ty
if v == 'CREATE' & ty == 'TABLESPACE' then
nm = m.s.val
else do
if m.s.val.0 == 1 then
m.m.obj = ddlGetNew(ty, , m.s.val.1)
else
m.m.obj = ddlGetNew(ty, m.s.val.1, m.s.val.2)
call mAdd m.m.obj'.ANO', m
end
m.s1.to = scanPos(scanSkip(s))
if ty == 'INDEX' then
call anaDdlIx m, s
else if ty == 'TABLE' then
call anaDdlTb m, s, m.s1.obj
else if ty == 'TABLESPACE' then
call anaDdlTs m, s, nm
else if ty == 'VIEW' then
call anaDdlVw m, s
else if wordPos(ty, 'PROCEDURE TRIGGER') > 0 then do
if scanSqlBeginEnd(s) then
call scanBack s, ';'
end
return
endProcedure anaACD
/*--- analyze sql DDL for index -------------------------------------*/
anaDdlIx: procedure expose m.
parse arg m, s
o = m.m.obj
if m.m.verb == 'CREATE' then do
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'ON' then
call scanErr s, 'ON expected'
call anaDdlLinkQuId o, s, 2, par, 'TB'
end
else if m.m.verb \== 'DROP' then do
call anaDDlPart m, s
end
do while scanSqlForId(s, 'PIECESIZE')
id = m.s.val
if id \== 'PIECESIZE' then
call scanErr s, 'piecesize expected'
call anaDdlSetNumUnit o, s, id
call aNodeAdd m'.SUB', 'at.'id, ,m.s.idBef,
, scanPos(scanSkip(s))
end
return 1
endProcedure anaDdlIx
/*--- analyze sql DDL for table -------------------------------------*/
anaDdlTb: procedure expose m.
parse arg m, s, subTy
o = m.m.obj
do while scanSqlForId(s, 'IN PARTITION')
id = m.s.val
if id == 'IN' then do
call anaDdlLinkQuId o, s, 2, par, 'TS'
iterate
end
if id == 'PARTITION' then do
id = 'PARTBYSZ'
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'BY' then
iterate
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'SIZE' then
iterate
m.o.id = ''
if scanSqlId(scanSkip(s)) then do
if m.s.val \== 'EVERY' then do
call scanBack s, m.s.tok
end
else do
call anaDdlSetNumUnit o, s, id
m.o.id = 'every' m.o.id
end
end
m.o.id = 'by size' m.o.id
end
else
call scanErr s, 'bad forId'
call aNodeAdd m'.SUB', 'at.'id, , m.s.idBef,
, scanPos(scanSkip(s))
end
if m.m.verb == 'CREATE' & m.o.PAR == '' then
if subTy <> 'GLOBAL TEMPORARY' then
call scanErr s, 'IN db.ts missing'
return
endProcedure anaDdlTb
/*--- analyze sql DDL for tableSpace --------------------------------*/
anaDdlTs: procedure expose m.
parse arg m, s, nm
o = m.m.obj
if m.m.verb \== 'CREATE' then
call anaDDlPart m, s
cNum = 'NUMPARTS MAXPARTITIONS SEGSIZE FREEPAGE MAXROWS'
do while scanSqlForId(s, 'in dsSize' cNum)
id = m.s.val
if id == 'IN' then do
if m.m.verb \== 'CREATE' | o \== '' then
call scanErr s, 'in: duplicate or not in Create'
if \ scanSqlQuId(scanSkip(s)) & m.s.val.0 <> 1 then
call scanErr s, 'db name expected'
o = ddlGetNew('TS', m.s.val, nm)
m.m.obj = o
call mAdd o'.ANO', m
end
else if o == '' then
call scanErr s, id 'before in'
else if id == 'DSSIZE' then
call anaDdlSetNumUnit o, s, dsSize
else if wordPos(id, cNum) > 0 then
call anaDdlSetNum o, s, id
else
call scanErr s, 'bad forId'
call aNodeAdd m'.SUB', 'at.'id, , m.s.idBef,
, scanPos(scanSkip(s))
end
if o == '' then
call scanErr s, 'in db missing in' m.m.verb 'ts'
return
endProcedure anaDdlTs
/*--- analyze sql ddl from create to ddlType ------------------------*/
/*--- analyze sql ddl Alter Part ... --------------------------------*/
anaDdlPart: procedure expose m.
parse arg m, s
pFr = scanPos(s)
if translate(scanLook(s, 6)) \== 'ALTER ' then
return
if \ scanSqlId(s) | m.s.val \== 'ALTER' then
call scanErr s, 'why not alter?'
if translate(scanLook(scanSkip(s), 10)) \== 'PARTITION ' then
return
if \ scanSqlId(s) | m.s.val \== 'PARTITION' then
call scanErr s, 'why not partition?'
if \ scanSqlNum(scanSkip(s)) | verify(m.s.tok,'0123456789')>0 then
call scanErr s, 'bad partition number'
call scanSkip s
call aNodeAdd m'.SUB', 'part', , pFr, scanPos(scanSkip(s))
return
endProcedure anaDdlPart
/*--- analyze sql ddl for view --------------------------------------*/
anaDdlVw: procedure expose m.
parse arg m, s
o = m.m.obj
do while scanSqlForId(s, 'FROM JOIN')
if scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then do
call mAdd o'.FRJO', m.s.val
do forever
call scanSqlDeId(scanSkip(s))
if \ scanLit(scanSkip(s), ',') then
leave
if scanSqlQuId(scanSkip(s)) | m.s.val.0 > 2 then
call mAdd o'.FRJO', m.s.val
else
leave
end
end
end
return 1
endProcedure anaDdlVw
/*--- analyze sql ddl qualified ID and link -------------------------*/
anaDdlLinkQuId: procedure expose m.
parse arg m, s, ll, att, cl
if \ scanSqlQuId(scanSkip(s)) | m.s.val.0 <> ll then
call scanErr s, 'quId with' ll 'quals expected after' att
else if ll == 2 then
call ddlLink m, att, cl, m.s.val.1, m.s.val.2
else
call scanErr s, 'bad ll='ll
return
endProcedure anaDdlLinkQuId
/*--- analyze sql ddl number with unit and set ----------------------*/
anaDdlSetNumUnit: procedure expose m.
parse arg m, s, att
if \ scanSqlNumUnit(scanSkip(s)) then
call scanErr s, 'number Unit expected after' att
else if m.m.att == '' then
m.m.att = space(m.s.val, 0)
else
call scanErr s, att 'already set'
return
endProcedure anaDdlSetNumUnit
/*--- analyze sql ddl number and set --------------------------------*/
anaDdlSetNum: procedure expose m.
parse arg m, s, att
if \ scanSqlNum(scanSkip(s)) then
if att = 'SEGSIZE' then
m.s.val = anaDDlFixSegsize(m, s, att, sp)
else
call scanErr s, 'number expected after' att
else if m.m.att == '' then
m.m.att = space(m.s.val, 0)
else if att == 'FREEPAGE' then
m.m.att = max(m.s.val, m.m.att)
else
call scanErr s, att 'already set'
return
endProcedure anaDdlSetNum
/*--- fix segsize without number ------------------------------------*/
anaDdlFixSegsize: procedure expose m.
parse arg m, s, att
parse value scanPos(s) with pL pC
say s
say m.s.rdr
ii = m.s.rdr'.BUF'
say m.ii.0
say m.ii.pL
if left(m.ii.pL, 2) == ' ' then
m.ii.pl = overlay(0, m.ii.pL)
else
call scanErr s, 'cannot fix segsize;'
say '||fixSegSize; at' pL pC':'m.ii.pL
return 0
nn = strip(m.ii.PL)
endProcedure anaDdlFixSegsize
anaIsRebind: procedure expose m.
parse arg aa, ax
if m.aa.ax.verb \== 'bp.CALL' ,
| translate(word(m.aa.ax.obj, 1)) \== 'DSN' then
return 0
ay = ax + 1
return translate(word(m.aa.ax.obj, 1)) == 'DSN',
& m.aa.ay.verb == 'bp.DATA' ,
& abbrev(m.aa.ay.sub.1.verb, 'rebind.')
endProcedure anaIsRebind
/* aOpt: handle option member ****************************************/
/*--- read aOpt (if it exists) --------------------------------------*/
aOptRead: procedure expose m.
parse arg m, m.m.dsn
m.m.0 = 0
if m.m.dsn <> '' then
if sysDsn("'"m.m.dsn"'") == 'OK' then
call readDsn m.m.dsn, 'M.'m'.'
if m.m.0 >= 1 & translate(word(m.m.1, 1)) \== 'DBX' then
call err 'bad first line in' m.m.dsn '1:' m.m.1
m.m.opts = ''
if m.m.0 >= 2 then
m.m.opts = translate(space(m.m.2, 1))
m.m.aOpt = ''
if m.m.0 >= 3 then
if translate(word(m.m.3, 1)) \== 'AOPT' then
call err 'aOpt expected in' m.m.dsn '3:' m.m.3
else
m.m.aOpt = translate(space(subword(m.m.3, 2), 1))
do ix=1 to m.m.0 while \ abbrev(m.m.ix, 'anaPost pre ')
end
m.m.preBegin = ix
return
endProcedure optRead
/*--- write aOpt (if it exists) -------------------------------------*/
aOptWrite: procedure expose m.
parse arg m, ch
ox = m.m.preBegin
m.m.ox = 'anaPost pre' m.myTst
do ix=1 to m.ch.0
ox = ox + 1
m.m.ox = ' ' m.ch.ix
end
if m.m.dsn <> '' then
call writeDsn m.m.dsn '::f', 'M.'m'.', ox, 1
return
endProcedure aOptWrite
/*--- issue an warning or abend with an error
depening on option in aOpt ------------------------------------*/
aOptErr: procedure expose m.
parse arg key, eMsg
say 'aOptErr key='key
say 'warning:' eMsg
return
if m.opt \== 1 then do /* try to read option file */
m.opt = 1
dsn = translate(m.myddl)
bx = pos('ANA(', dsn)
if bx < 1 then
call err 'ana( not found in' dsn"\n"eMsg
dsn = overlay('OPT(', dsn, bx)
if bx+12 = length(dsn) then
dsn = left(dsn, length(dsn)-2)')'
syD = sysDsn("'"dsn"'")
if syD \== 'OK' then
call err dsn '->' syD"\n"eMsg
call readDsn dsn, 'M.OPT.'
end
do ox=1 to m.opt.0
if translate(word(m.opt.ox, 1)) == translate(key) then do
say 'ignoring error' eMsg
say ' because option' strip(m.opt.ox)
return 1
end
end
call err 'no option' key 'in' dsn"\n"eMsg
endProcedure aOptErr
/* ANode class *******************************************************/
ANodeClear: procedure expose m.
parse arg m
call oClear(oMutate(m, m.clANode))
parse arg , m.m.verb, m.m.obj, m.m.fr, m.m.to
return m
endProcedure ANodeClear
aNodeAdd: procedure expose m.
parse arg a, verb, obj, fr, to
m.a.0 = m.a.0 + 1
return aNodeClear(a'.'m.a.0, verb, obj, fr, to)
endProcedure aNodeAdd
/* DDL class *********************************************************/
ddlGetNew: procedure expose m.
parse arg ty, qu ., nm .
if symbol('m.ddl_types.ty') == 'VAR' then
ty = m.ddl_types.ty
if symbol('m.ddl.ty.qu.nm') == 'VAR' then
return m.ddl.ty.qu.nm
if symbol('m.ddl.ty.0') == 'VAR' then
m.ddl.ty.0 = m.ddl.ty.0 + 1
else do
m.ddl_types = m.ddl_types ty
m.ddl.ty.0 = 1
end
if symbol('m.clddl.ty') == 'VAR' then
n = oClear(oMutate('DDL.'ty'.'m.ddl.ty.0, m.clddl.ty))
else
n = oClear(oMutate('DDL.'ty'.'m.ddl.ty.0, m.clddl))
m.ddl.ty.qu.nm = n
m.n.type = ty
m.n.qual = qu
m.n.name = nm
return n
endProcedure ddlGetNew
ddlLink: procedure expose m.
parse arg o, f, ty, qu, nm
l = ddlGetNew(ty, qu, nm)
if m.o.f == '' then
m.o.f = l
else if l \== m.o.f then do
a = m.o.f
call aOptErr 'post.link.'m.o.type'.'f,
, 'old objLink' m.o.type':'m.o.qual'.'m.o.name'*'f,
|| '=>'a'='m.a.qual'.'m.a.name '<>' ty':'qu'.'nm
end
return
endProcedure ddlLink
ddlPar: procedure expose m.
parse arg o
if o == '' | m.o.par == '' then
return ''
return m.o.par
endProcedure ddlPar
ddlAddAlt: procedure expose m.
parse arg f, a, aO, aN, aForce
o = ddlFilter(a, aO)
n = ddlFilter(a, aN)
say m.f.type m.f.qual'.'m.f.name '==>' m.f.acd,
', fun='m.f.fun 'add' a':' aO'='o '->' aN'='n
if aForce == 1 then
call mAdd chOpt, ' ' a '? ->' n
else if o = n then
return
else
call mAdd chOpt, ' ' a o '->' n
m.f.alt.0 = m.f.alt.0 + 1
ff = oClear(oMutate(f'.ALT.'m.f.alt.0, m.clAON))
m.f.alt.a = ff
m.ff.att = a
m.ff.old = o
m.ff.new = n
return
endProcedure ddlAddAlt
/*--- alter tables: drop partition by size clause ------------------*/
ddlAltPartBySz: procedure expose m.
do tx=1 to m.ddl.tb.0
t1 = 'DDL.TB.'tx
if m.t1.partBySz \== '' then do
m.t1.fun = 'a'
call ddlAddAlt t1, partBySz, m.t1.partBySz , '-'
end
end
return
endProcedure
ddlFilter: procedure expose m.
parse arg a, v
if v = '' then
return '-'
if a=dsSize then do
if abbrev(v, 0) then
return '-'
if dataType(v, 'n') then
return (v % 1048576) || 'G'
else
return space(v, 0)
end
if wordPos(a, maxPartitions segSize) > 0 & v=0 then
return '-'
if a = maxRows & v = 255 then
return '-'
return v
endProcedure ddlFilter
ddlGetUnl: procedure expose m.
parse arg o
do vx=1 to m.o.aNo.0
ul = m.o.aNo.vx
if abbrev(m.ul.verb, 'md.') then
if wordPos(substr(m.ul.verb, lastPos('.', m.ul.Verb)) ,
, '.UNLOAD .FUNLD') > 0 then
return ul
end
return ''
endProcedure ddlGetUnl
ddlAddParents: procedure expose m.
do ox=1 to m.ddl.ix.0
o = 'DDL.IX.'ox
if '-' == sql2one("select tbCreator, tbName",
"from sysibm.sysIndexes",
"where creator='"m.o.qual"' and name='"m.o.name"'",
, q, , , '--') then
say 'warning no ix' m.o.qual'.'m.o.name 'in DB2'
else
m.o.parOld = ddlGetnew('TB', m.q.tbcreator, m.q.tbname)
end
return /* we do not need parents of tb yet ?????? */
do ox=1 to m.ddl.tb.0
o = 'DDL.TB.'ox
if m.o.par \== '' then
iterate
if '-' == sql2one("select dbName, tsName ,type",
"from sysibm.sysTables",
"where creator='"m.o.Qual"' and name='"m.o.name"'",
, q, , , '--') then
say 'warning no tb' m.o.qual'.'m.o.name 'in DB2'
else if pos(m.q.type, 'AGV') < 1 then
m.o.par = ddlGetnew('TS', m.q.dbName, m.q.tsName)
end
return
endProcedure ddlAddParents
/*--- fill field acd with a=alter, c=create and d=drop --------------*/
ddlGenAcd: procedure expose m.
do dx=1 to words(m.ddl_types)
t1 = word(m.ddl_types, dx)
d1 = 'DDL.'t1
do dy=1 to m.d1.0
o = d1'.'dy
alt = ' '
cre = ' '
drop = ' '
do ax=1 to m.o.ANO.0
a1 = m.o.ano.ax
if m.a1.verb == 'ALTER' then
alt = 'a'
else if m.a1.verb == 'CREATE' then
cre = 'c'
else if m.a1.verb == 'DROP' then
drop = 'd'
end
m.o.acd = alt || cre || drop
say m.o.type m.o.qual'.'m.o.name '==>' m.o.acd,
|| ', fun='m.o.fun', o='o
end
end
return
endProcedure ddlGenAcd
/* positions *********************************************************/
posLess: procedure expose m.
parse arg l1 l2, r1 r2
if l1 = r1 then
return l2 < r2
else
return l1 < r1
/* debug *************************************************************/
dbAllOut: procedure expose m.
parse arg ana
m.o.0 = 0
l = 9999
do dx=1 to m.ana.0
call dbOut o, ana'.'dx, '', l
end
do dx=1 to words(m.ddl_types)
d1 = 'DDL.'word(m.ddl_types, dx)
do dy=1 to m.d1.0
call dbOut o, d1'.'dy, '', l
end
end
tDsn = userid()'.tmp.texv(anaPost)'
call writeDsn tDsn, 'M.O.', , 1
/* call adrIsp "view dataset('"tDsn"')", 4 */
return
dbOut: procedure expose m.
parse arg o, a, pr, l
call mAdd o, pr || o2Text(a, l)
if objCLass(a) == m.clANode then
do sx=1 to m.a.sub.0
call dbOut o, a'.SUB.'sx, pr' ', l
end
if oKindOf(a, m.clDdl) then do
do sx=1 to m.a.aNo.0
call mAdd o, pr' 'a'.ANO.'sx'=>'m.a.aNo.sx
end
do sx=1 to m.a.alt.0
call dbOut o, a'.ALT.'sx, pr' ', l
end
end
return
call out left('', o)'db' o2Text(db)
call mdlsOut db'.MDL', o+2
do sx=1 to m.db.ts.0
call tsOut m.db.ts.sx, o+2
end
/* scan extensions ***************************************************/
/*--- scan until one of the given ids -------------------------------*/
scanSqlForId: procedure expose m.
parse arg s, ids
upper ids
do forever
m.s.idBef = scanPos(s)
if \ scanSqlClass(s) then
return 0
if m.s.sqlClass == ';' then do
call scanBack s, ';'
return 0
end
if m.s.sqlClass == 'i' then
if wordPos(m.s.val, ids) > 0 then
return 1
if m.s.sqlClass == '(' then
call scanSqlSkipBrackets s, 1
end
return 0
endProcedue scanSqlForId
/*--- scan over begin ...; ... end ----------------------------------*/
scanSqlBeginEnd: procedure expose m.
parse arg s
lv = 0
do while scanSqlClass(s)
if m.s.sqlClass == 'i' then do
if m.s.val == 'BEGIN' | m.s.val = 'CASE' then
lv = lv + 1
else if m.s.val \== 'END' then
nop
else if lv < 1 then
call scanErr s, 'unpaired END'
else
lv = lv - 1
end
else if m.s.sqlClass == ';' & lv == 0 then
return 1
else if m.s.sqlClass == '(' then
call scanSqlSkipBrackets s, 1
end
if lv > 0 then
call scanErr s, 'eof with' lv 'unpaired BEGINs'
return 0
endProcedue scanSqlBeginEnd
/* copy rcm begin ******** caDb2 RC/Migrator *************************/
/*--- add an objecct including explodes to quickmigrate input -------*/
rcmQuickAdd: procedure expose m.
parse arg o, aTy, qu, na
ty = rcmQuickType(aTy)
if ty == 'DB' then
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty '=' na
else
call mAdd o, ' ' m.rcm_QuickT2QUICK.ty qu na
call rcmQuickAdaEI o, ty, 'DB' , 'EXPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'T' , 'IMPLODE TABLESPACE'
call rcmQuickAdaEI o, ty, 'DB TS' , 'EXPLODE TABLE'
call rcmQuickAdaEI o, ty, 'DB TS T' , 'EXPLODE INDEX'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE VIEW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE SYNONYM'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE TRIGGER'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_T'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQTB_S'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_VW'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_I'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_V'
call rcmQuickAdaEI o, ty, 'DB TS T V' , 'EXPLODE MQVW_S'
call rcmQuickAdaEI o, ty, 'I' , 'IMPLODE MQVW_VW'
return
endProcedure rcmQuickAdd
rcmQuickAdaEI: procedure expose m.
parse arg o, ty, types, l1 lR
if wordPos(ty, types) > 0 then
call mAdd o, ' ' left(l1, 11) lR
return
endProcedure rcmQuickAdaEI
rcmQuickType: procedure expose m.
parse upper arg ty
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call rcmQuickTyp1 'DATABASE' , 'DB'
call rcmQuickTyp1 'INDEX' , 'I IX'
call rcmQuickTyp1 'TABLE' , 'T TB'
call rcmQuickTyp1 'TABLESPACE' , 'TS'
call rcmQuickTyp1 'TRIGGER' , 'TG'
call rcmQuickTyp1 'VIEW' , 'V VW'
call rcmQuickTyp1 'PROCEDURE PROCEDUR', 'PR SP'
if symbol('m.rcm_quickA2T.ty') == 'VAR' then
return m.rcm_quickA2T.ty
call err 'rcmQuickType type='ty 'not implemented'
endProcedure rcmQuickType
rcmQuickTyp1: procedure expose m.
parse upper arg dTy qTy ., t aa
m.rcm_quickT2DB2.t = dTy
if qTy == '' then
m.rcm_quickT2QUICK.t = dTy
else
m.rcm_quickT2QUICK.t = qTy
m.rcm_quickA2T.dTy = t
if qTy \== '' then
m.rcm_quickA2T.qTy = t
m.rcm_quickA2T.t = t
do ax=1 to words(aa)
a = word(aa, ax)
m.rcm_quickA2T.a = t
end
return
endProcedure
/* copy rcm end ******** caDb2 RC/Migrator *************************/
/* copy time begin ****************************************************
timestamp format yz34-56-78-hi.mn.st.abcdef
11.12.14 wk: added lrsn2uniq
11.05.13 wk: numeric digits transparent: in jeder Procedure drin
time2jul, tst externalisiert
**********************************************************************/
/*--- timestamp to julian -------------------------------------------*/
time2jul: procedure expose m.
parse arg yyyy '-' mm '-' dd '-'
if yyyy < 1100 then
yyyy = 11 || right(yyyy, 2, 0)
/* date function cannot convert to julian, only from julian
use b (days since start of time epoch) instead */
return right(yyyy, 2) ,
|| right(date('b', yyyy || mm || dd, 's') ,
- date('b', yyyy-1 || '1231', 's') , 3, 0)
endProcedure time2jul
/*--- current timestamp ---------------------------------------------*/
timestampNow: procedure expose m.
parse value date('s') time('l') with y 5 m 7 d t
return y'-'m'-'d'-'translate(t, '.', ':')
/*--- timestamp expand: expand to timestamp of 26 chars -------------*/
timestampExp: procedure expose m.
parse arg tst .
if length(tst) < m.timeStamp_Len then
return overlay(tst, m.timeStamp_01)
else
return left(tst, timeStamp_Len)
endProcedure tiemstampExp
/*--- timestamp check return '' if correct or error text ------------*/
timestampcheck: procedure expose m.
parse arg tst
if length(tst) < m.timestamp_d0Len | \ abbrev(m.timestamp_11,
, translate(tst, '111111111', '023456789')) then
return 'bad timestamp' tst
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss '.' u
if mo < 1 | mo > 12 then
return 'bad month in timestamp' tst
if dd < 1 | dd > 3 || substr('101010110101', mo, 1) then
return 'bad day in timestamp' tst
if mo = 2 then
if dd > date('d', yyyy'0301', 's') - 32 then
return 'bad day in timestamp' tst
if hh > 23 & \ abbrev(24 00 00 000000, hh mm ss u) then
return 'bad hour in timestamp' tst
if mm > 59 then
return 'bad minute in timestamp' tst
if ss > 59 then
return 'bad second in timestamp' tst
return ''
endProcedure timestampCheck
/*--- timestamp to days since 1.1.0001 ------------------------------*/
timestamp2days: procedure expose m.
parse arg yyyy '-' mo '-' dd '-' hh '.' mm '.' ss
numeric digits 20
return date('b', yyyy || mo || dd, 's') ,
+ (((hh * 60) + mm) * 60 + ss) / 86400
/*--- days since 1.1.0001 (with time+microsecs) to timestamp --------*/
timeDays2tst: procedure expose m.
parse arg d
numeric digits 20
r = min(format(d // 1 * 86400, 5, 6), 86399.999999)
s = trunc(r)
t = date('s', trunc(d), 'b')
return left(t, 4)'-'substr(t, 5, 2)'-'right(t, 2) ,
|| '-' || right((s % 3600), 2, 0) ,
|| '.' || right((s // 3600 % 60), 2, 0) ,
|| '.' || right((s // 60), 2, 0) ,
|| substr(r, 6)
endProcedure timeDays2tst
/*--- timestamp diff in days ----------------------------------------*/
timestampDiff: procedure expose m.
parse arg t1, t2
numeric digits 20
return timestamp2days(t1) - timestamp2Days(t2)
/*--- convert 2 digit year to 4 digit -------------------------------*/
timeYear24: procedure expose m.
parse arg s
y = left(date('S'), 4)
s4 = left(y, 2)right(s, 2, 0)
if s4 > y + 30 then
return (left(y, 2) - 1)substr(s4, 3)
else if s4 > y - 70 then
return s4
else
return (left(y, 2) + 1)substr(s4, 3)
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...Y=24) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr(m.ut_uc25, (y // 25) + 1, 1)
/*--- convert 1 char year Y (A=0...y=24) to year --------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, m.ut_uc25) - 1
if j < 0 then
call err 'timeY2Year bad input' i
y = left(date('S'), 4)
r = y - y // 25 + j
if r > y + 4 then
return r - 25
else if r > y - 21 then
return r
else
return r + 25
endProcedure timeY2Year
/*--- convert 2 or 4 digit year Y (A=10...T=29) ----------------------*/
timeYear2Z: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST', ((y+10) // 20) + 1, 1)
/*--- convert 1 char year Z (A=10...T=29) to year --------------------*/
timeZ2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeZ2Year bad input' i
y = left(date('S'), 4)
r = y - y // 20 + j
if r > y + 4 then
return r - 20
else if r > y - 16 then
return r
else
return r + 20
endProcedure timeZ2Year
/*--- convert numeric month to M (Jan=B=1, dec=12=M) ----------------*/
timeMonth2M: procedure expose m.
parse arg m
return substr('BCDEFGHIJKLM', m, 1)
/*--- convert M to numeric Month (Jan=B=1, dec=12=M) ----------------*/
timeM2Month: procedure expose m.
parse arg m
p = pos(m, 'BCDEFGHIJKLM')
if p= 0 then
call err 'bad M month' m
return right(p, 2, 0)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
if m.time_ini == 1 then
return
m.time_ini = 1
numeric digits 25
/* offsets documented in z/OS Data Areas Vol.1 */
cvtOH = '00000010' /* cvt control block Address */
cvtext2O = x2d('00000560') /* offset to extension 2 */
cvtldtoO = x2d('00000038') /* offset to timezone */
cvtlsoO = x2d('00000050') /* offset to leapSeconds */
/* CVT CB address + extention2 */
cvtExt2A = C2D(STORAGE(cvtOH,4)) + cvtext2O
/* cvtLdto timeZone address +offset */
m.time_Zone = c2d(STORAGE(d2x(cvtext2A+cvtldtoO, 8), 8))
m.time_StckUnit = 1e-6 / 256 / 16
/* cvtLso LeapSecs address +offset */
m.time_Leap = c2d(STORAGE(d2x(cvtext2A+cvtlsoO, 8), 8))
m.time_LZT_TAI10_us16 = (m.time_zone - m.time_leap) % 256
m.time_UQDigits = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678'
/* find lrsn of day 0, 0 out last 6 bits */
m.time_UQZero = x2d(left(timeTAI102Lrsn( ,
'2004-12-31-00.00.22.000000'), 14)) % 64 * 64
m.timeStamp_01 = '0001-01-01-00.00.00.000000'
m.timeStamp_11 = '1111-11-11-11.11.11.111111'
m.timeStamp_99 = '9999-12-31-23.59.59.999999'
m.timeStamp_len = length(m.timestamp_11)
m.timeStamp_d0Llen = m.timestamp_len - 7
return
endSubroutine timeIni
/*--- TAI10 timestamp yyyy-mm.... -> stckE value char(16)
BLSUETID is described in z/OS MVS IPCS Customization -------*/
timeTAI102stckE: procedure expose m.
/* timestamp must include microSeconds |||*/
parse arg year'-'mo'-'da'-'hh'.'mm'.'secs
tDate = mo'/'da'/'year hh':'mm'.'secs
ACC=left('', 16, '00'x)
ADDRESS LINKPGM "BLSUETID TDATE ACC"
RETURN acc
endProcedure timeTAI102stckE
timeTAI102lrsn: procedure expose m.
parse arg tst
return c2x(left(timeTAI102StckE(tst), 10))
timeLZT2stckE: procedure expose m.
parse arg tst
numeric digits 23
s =timeTAI102StckE(tst)
return d2c(c2d(left(s, 8)) - m.time_lzt_TAI10_us16,8) ||substr(s,9)
endProcedure timeLZT2stckE
timeLZT2lrsn: procedure expose m.
parse arg tst
return c2x(left(timeLZT2StckE(tst), 10))
/*--- expand lrsn to 20 hexDigits -------------------------------*/
timeLrsnExp: procedure expose m.
parse arg s
return left(copies('00', length(s) <= 12 & \abbrev(s, 0))s, 20,0)
/*--- expand stcK(e) to 16 Byte ---------------------------------*/
timeStckExp: procedure expose m.
parse arg s
return left(copies('00'x, length(s) <= 8 & s >> '09'x)s, 16,'00'x)
/*--- conversion from StckE Clock Value to TAI10 Timestamp
BLSUETOD is described in z/OS MVS IPCS Customization --------*/
timeStckE2TAI10: PROCEDURE expose m.
parse arg stck /* must be 16 characters ||||| */
TDATE = left('' , 26)
ADDRESS LINKPGM "BLSUETOD stck TDATE"
/* return format : mo/dd/yyyy hh:mm:ss.uuuuuu */
/* Timestamp format: yyyy-mm-dd-hh.mm.ss.uuuuuu */
parse var TDATE mo '/' dd '/' yyyy hh ':' mm ':' secs
RETURN yyyy'-'mo'-'dd'-'hh'.'mm'.'secs
endProcedure timeStckE2TAI10
/*--- conversion from Lrsn Clock Value to TAI10 Timestamp ----------*/
timeLrsn2TAI10:
return timeStckE2TAI10(x2c(arg(1))'000000000000'x)
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeStckE2LZT: procedure expose m.
parse arg s
numeric digits 23
return timeStckE2TAI10(d2c(c2d(left(s, 8)) ,
+ m.time_LZT_TAI10_us16, 8) || substr(s, 9))
endProcedure timeStckE2LZT
/*--- conversion from Lrsn Clock Value to LZT Local Zurich Time -----*/
timeLrsn2LZT: procedure expose m.
parse arg lrsn
return timeStckE2LZT(x2c(lrsn) || '000000000000'x)
/* convert a lrsn to the uniq variable *******************************/
timeLrsn2uniq: procedure expose m.
parse arg lrsn
/* unique are bits 0:41 of the TodClock value
minus 31.12.2004 represented
by base 35 by 'ABC...YZ01..8'
*/
lrsn = left(timeLrsnExp(lrsn), 14)
numeric digits 20
diff = x2d(lrsn) - m.time_UQZero
if diff < 0 then
return'< 2005'
return right(i2q(diff % 64, m.time_UQDigits), 8, 'A')
endProcedure timeLrsn2Uniq
/* convert a uniq variable to lrsn ***********************************/
timeUniq2lrsn: procedure expose m.
parse arg uniq
numeric digits 20
u1 = q2i(left(uniq, 8, 'A'), m.time_UQDigits) * 64
lrsn = '00'right(d2x(u1 + m.time_UQZero), 12, 0)'000000'
return lrsn
endProcedure uniq2lrsn
/*--- translate a number in q-system to decimal
arg digits givs the digits corresponding to 012.. in the q sysem
q = length(digits) -------------------------------------------*/
q2i: procedure expose m.
parse arg v, digits
b = length(digits)
i = 0
do x = 1 to length(v)
q = substr(v, x, 1)
r = pos(q, digits)
if r < 1 then
call err 'bad digit' q 'in' v 'valid digits' digits
i = i * b + r - 1
end
return i
endProcedure q2i
/*--- translate a decimal number to q-system - inverse of q2i -------*/
i2q: procedure expose m.
parse arg i, digits
if i = 0 then
return left(digits, 1)
b = length(digits)
v = ''
do while i > 0
v = substr(digits, 1 + (i // b), 1) || v
i = i % b
end
return v
endProcedure i2q
/* copy time 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 scanRead begin ***********************************************
Scan: scan an input: with multiple lines
==> all of scan
returns: true if scanned, false otherwise
m.m.tok ==> last token
m.m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.m.pos ==> scan position
m.m.src ==> scan source
**********************************************************************/
scanReadIni: procedure expose m.
if m.scanRead_ini == 1 then
return
m.scanRead_ini = 1
call jIni
ts = classNew('n ScanRes u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'oReset return scanReadReset(m, arg)',
, 'scanNL return scanReadNL(m, unCond)',
, 'scanCom return scanSBCom(m)',
, 'scanInfo return scanReadInfo(m)',
, 'scanPos return scanReadPos(m)',
, "jOpen call scanReadOpen m, arg(3)" ,
, "jClose call scanReadClose m" ,
, 'isWindow 0',
, "jRead if scanType(m) == '' then return 0;" ,
"m.rStem.1 = oClaCopy('"ts"', m, ''); m.rStem.0 = 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead if \ editRead(m, rStem) then return 0",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r=='' then return 0" ,
"; m.rStem.1 = r; m.rStem.0 = 1"
return
endProcedure scanReadIni
scanOpen: procedure expose m.
parse arg m
interpret objMet(m, 'jOpen')
return m
endProcedure scanOpen
scanClose: procedure expose m.
parse arg m
interpret objMet(m, 'jClose')
return m
endProcedure scanClose
/*--- scan over white space, nl, comments ...------------------------*/
scanSpNlCo: procedure expose m.
parse arg m
res = 0
do while scanSpaceOnly(m) | scanCom(m) | scanNl(m)
res = 1
end
m.m.tok = left(' ', res)
return res
endProcedure scanSpNlCo
/*--- scan next line ------------------------------------------------*/
scanNL: procedure expose m.
parse arg m, unCond
interpret objMet(m, 'scanNL')
/*--- scanNl until line starts with trg -----------------------------*/
scanNlUntil: procedure expose m.
parse arg s, trg
do until scanLook(s, length(trg)) == trg
if \ scanNl(s, 1) then
return 0
end
return 1
endProcedure scanNlUntil
/*--- scan one comment ----------------------------------------------*/
scanCom: procedure expose m.
parse arg m
interpret objMet(m, 'scanCom')
/*--- go back the current token -------------------------------------*/
scanBack: procedure expose m.
parse arg m, tok
if m.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.m.pos - length(tok)
if substr(m.m.src, cx, length(tok)) \== tok then
return scanErr(m, 'cannot back "'tok'" value') + sauerei
m.m.pos = cx
return
endProcedure scanBack
/*--- return position in simple format ------------------------------*/
scanPos: procedure expose m.
parse arg m
interpret objMet(m, 'scanPos')
endProcedure scanPos
/*--- set position to position in arg to-----------------------------*/
scanBackPos: procedure expose m.
parse arg m, to
cur = scanPos(m)
wc = words(cur)
if wc <> words(to) ,
| subWord(cur, 1, wc-1) <> subWord(to, 1, wc-1) then
call scanErr m 'cannot back from' cur 'to' to
m.m.pos = word(to, wc)
return
endProcedure scanBackPos
/*--- begin scanning the lines of a reader --------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpt(oNew(m.class_ScanRead, rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr m.m.strip .
return oMutate(m, m.class_ScanRead)
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
return scanSetPos0(m, (line0 == '') 1, line0)
endProcedure scanReadOpen
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.rdr
m.m.atEnd = 'closed'
return m
endProcedure scanReadClose
/*--- scan over next newLine
if unCond \== 1 only if we are already at endOfLine
return true if we scanned a NL -----------------------------*/
scanReadNL: procedure expose m.
parse arg m, unCond
m.m.tok = ''
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.src, m.m.pos)
r = m.m.rdr
if \ jRead(r) then do
m.m.atEnd = 1
m.m.pos = 1 + length(m.m.src)
return 0
end
if m.m.strip == '-' then
m.m.src = m.r
else /* strip trailing spaces for vl32755 inputs ,
use only if nl space* is equivalent to nl */
m.m.src = strip(m.r, 't')
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
return 1
endProcedure scanReadNl
/*--- postition scanner to lx px (only with jBuf)
after rdr is positioned to line before ----------------------*/
scanSetPos: procedure expose m.
parse arg m, lx px
call jPosBefore m.m.rdr, lx
return scanSetPos0(m, lx px)
/*--- postition scanner to lx px
after rdr is positioned to line before -------------------------*/
scanSetPos0: procedure expose m.
parse arg m, lx px, line0
call scanReset m, line0
call scanNl m
m.m.lineX = lx
m.m.pos = px
return m
endProcedure scanSetPos0
/*--- reset scanner fields ------------------------------------------*/
scanReset: procedure expose m.
parse arg m, m.m.src
m.m.pos = 1
m.m.tok = ''
m.m.scanIsBasic = 0
m.m.atEnd = 0
m.m.lineX = 0
m.m.val = ''
m.m.key = ''
return m
endProcedure
scanTextCom: procedure expose m.
parse arg m, untC, untWrds
if \ m.m.scanNestCom then
return scanText(m, untC, untWrds)
else if wordPos('*/', untWrds) > 0 then
return scanText(m, untC'*/', untWrds)
res = scanText(m, untC'*/', untWrds '*/')
if res then
if scanLook(m, 2) == '*/' then
call scanErr m, '*/ without preceeding comment start /*'
return res
endProcedure scanTextCom
scanText: procedure expose m.
parse arg m, untC, untWrds
res = ''
do forever
if scanUntil(m, untC) then do
res = res || m.m.tok
if m.m.pos > length(m.m.src) then do
/* if windowing we need to move the window| */
if scanNl(m, 0) then
if right(res, 1) \==' ' & scanLook(m, 1)\==' ' then
res = res' '
iterate
end
end
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then do
m.m.tok = res
return 1
end
end
if scanCom(m) | scanNl(m, 0) then do
if right(res, 1) \== ' ' & scanLook(m, 1) \== ' ' then
res = res' '
end
else if scanString(m) then
res = res || m.m.tok
else if scanChar(m, 1) then
res = res || m.m.tok
else if scanEnd(m) then do
m.m.tok = res
return res \== '' /* erst hier NACH scanCom, scanNl */
end
else
call scanErr m, 'bad pos'
end
endProcedure scanText
scanReadPos: procedure expose m.
parse arg m, msg
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(substr(m.m.src, m.m.pos, 40), 't')
if scanEnd(m) then
msg = msg'\natEnd after'
else
msg = msg'\npos' m.m.pos 'in'
return msg 'line' m.m.lineX':' strip(m.m.src, 't')
endProcedure scanReadInfo
/*--- use scan sqlEdit macro --> temporarily here -------------------*/
/*--- read next line from edit data ---------------------------------*/
editRead: procedure expose m.
parse arg m, rStem
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.rStem.1 = ll
m.rStem.0 = 1
return 1
endProcedure editRead
/*--- search loop in edit macro -------------------------------------*/
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
/* line 1 col 0, otherwise first word is skipped*/
if adrEdit("cursor =" max(trunc(lx), 1) 0, 12) = 12 then
return -1
do while adrEdit("seek" cmd opts, 4) = 0 /* find each command*/
call adrEdit "(fx) = cursor"
if m.debug then do
call adrEdit "(LI) = LINE" fx
call debug 'scanSqlSeekId after' lx 'found' cmd 'at' fx li
end
call jReset m.m.rdr, fx
call jOpen m, '<'
m.m.lineX = fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
call jClose m
end
return -1
endProcedure scanSqlSeekId
/* copy scanRead end *************************************************/
/* copy scanWin begin *************************************************
scan the the concatenation of the lines of a reader
any token my be split over several line
except the end-of-line-comment-token
**********************************************************************/
scanWinIni: procedure expose m.
if m.scanWin.ini = 1 then
return
m.scanWin.ini = 1
call scanReadIni
call classNew 'n ScanWin u ScanRead', 'm',
, "oReset call scanWinReset m, arg, arg2",
, "jOpen call scanWinOpen m, arg(3)",
, "jClose call scanReadClose m",
, 'scanNL return scanWinNl(m, unCond)',
, 'scanCom return scanWinCom(m)',
, 'scanInfo return scanWinInfo(m)',
, 'scanPos return scanWinPos(m)',
, 'isWindow 1'
return
endProcedure scanWinIni
/*--- instanciate a new window scanner ------------------------------*/
scanWin: procedure expose m.
parse arg rdr, wOpts
return oNew(m.class_ScanWin, rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanSqlOpt(scanWinOpt(oMutate(m, m.class_ScanWin), winOpt))
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiLi wiBa
if pos('@', cuLe) > 0 then
parse var cuLe cuLe '@' m.m.cutPos
else
m.m.cutPos = 1
cuLe = word(cuLe 72, 1)
m.m.cutLen = cuLe /* fix recLen */
wiLe = cuLe * (1 + word(wiLi 5, 1))
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + wiLe
m.m.winTot = m.m.posLim + wiLe
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, line0
call jOpen m.m.rdr, '<'
if line0 == '' then
return scanSetPos0(m, 1 1)
if length(line0) // m.m.cutLen \== 0 then
line0 = line0||left('', m.m.cutLen - length(line0)//m.m.cutLen)
return scanSetPos0(m, (1 - length(line0) % m.m.cutLen) 1, line0)
endProcedure scanWinOpen
/*--- move the source window: cut left side and append at right side
return number of characters cut at left -----------------------*/
scanWinRead: procedure expose m.
parse arg m
dlt = 0
if m.m.atEnd then
return 0
if m.m.pos >= m.m.posLim then do /* cut left side */
dlt = m.m.pos - ((m.m.pos-1) // m.m.cutLen + 1 + m.m.posMin)
call assert 'dlt >= 0 & dlt // m.m.cutLen = 0','dlt m.m.cutLen'
m.m.src = substr(m.m.src, dlt+1)
m.m.pos = m.m.pos - dlt
m.m.lineX = m.m.lineX + dlt % m.m.cutLen
end
r = m.m.rdr
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(r) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.r, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot',
, 'm.m.winTot length(m.m.src) m.m.src'
return dlt
endProcedure scanWinRead
/*--- return position of next line start ----------------------------*/
scanWinNLPos: procedure expose m.
parse arg m
return m.m.pos + m.m.cutLen - ((m.m.pos - 1) // m.m.cutLen)
/*--- scan comment --------------------------------------------------*/
scanWinCom: procedure expose m.
parse arg m
call scanWinRead m
if m.m.scanComment \== '' then do
cl = length(m.m.scanComment)
if scanLook(m, cl) == m.m.scanComment then do
np = scanWinNlPos(m)
if np = m.m.pos then
np = np + m.m.cutLen
if np >= m.m.pos + cl then do
m.m.tok = substr(m.m.src, m.m.pos, np - m.m.pos)
m.m.pos = np
return 1
end
end
end
if m.m.scanNestCom then
if scanLit(m, '/*') then do
tk = substr(m.m.src, m.m.pos, m.m.cutLen + 2)
call scanTextCom m, , '*/'
if \ scanLit(m, '*/') then
call scanErr m, 'nested comment after /* not finished'
if pos('*/', tk) < 1 then
m.m.tok = left(tk, m.m.cutLen - 5)'...*/'
else
m.m.tok = left(tk, pos('*/', tk) + 1)
return 1
end
m.m.tok = ''
return 0
endProcedure scanWinCom
/*--- scan nl -------------------------------------------------------*/
scanWinNL: procedure expose m.
parse arg m, unCond
call scanWinRead m
m.m.tok = ''
if unCond \== 1 then
return 0
np = scanWinNLPos(m)
if np = m.m.pos then
return 0
if unCond == '?' then
return 1
m.m.tok = substr(m.m.pos, np-m.m.pos)
m.m.pos = np
return 1
endProcedure scanWinNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
ps = m.m.pos - 1
return (m.m.lineX + (ps % m.m.cutLen)) (ps // m.m.cutLen + 1)
endProcedure scanWinPos
/*--- return a description of the current scan position -------------*/
scanWinInfo: procedure expose m.
parse arg m
p = scanWinPos(m)
if scanEnd(m) then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
p = word(p, 1)
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't') ,
|| '\n'res 'line' p':' strip(substr(m.m.src,
, 1 + (p - m.m.lineX) * m.m.cutLen, m.m.cutLen), 't')
endProcedure scanWinInfo
/* copy scanWin end ************************************************/
/* copy scanSql begin ************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanSqlReset: procedure expose m.
parse arg m, r, scanWin, stmtOpt
call scanSqlStmtOpt scanSqlOpt(m), strip(stmtOpt)
if scanWin \== 0 then
return scanWinReset(m, r, scanWin)
else if r \== '' then
return scanReadReset(m, r)
else
return scanSrc(m, m.m.src)
endProcedure scanSqlReset
scanSqlOpt: procedure expose m.
parse arg m
return scanOpt(m, m.ut_alfa'$#@', '0123456789_' , '--', 1)
endProcedure scanSqlOpt
/*--- scan a sql token put class in m.sqlclass:
'i': ordinary identifier e.g. Name
'd': delimited identifier e.g. "Delimited"
'q': qualified identifier e.g. abc."efg"
'u': integer units e.g. 8G
'n': number e.g. -234 or .2e3
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
---------------------------------------------------------------*/
scanSqlClass: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpNlCo(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanLit(m, "'", "x'", "X'") then do
if \ scanStrEnd(m, "'") then
call scanErr m, 'ending apostroph missing'
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m, 1) then do
if m.m.val.0 > 1 then
m.m.sqlClass = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlClass = 'd'
else
m.m.sqlClass = 'i'
end
else if scanSqlNumPM(m) then do
if m.m.tok == '-' | m.m.tok == '+' then
m.m.sqlClass = m.m.tok
else
m.m.sqlClass = 'n'
end
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanEnd(m) then do
m.m.sqlClass = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlClass
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br \== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlClass(m) & m.m.sqlClass \== ';'
if m.m.sqlClass = '(' then br = br + 1
else if m.m.sqlClass \== ')' then iterate
else if br > 1 then br = br - 1
else return 1
end
call scanErr m, '; or eof, but' br 'closing ) expected'
endProcedure skipBrackets
/*--- scan an ordinary sql identifier e.g. abc, ef_12 ---------------*/
scanSqlId: procedure expose m.
parse arg m
if \ scanName(m) then
return 0
m.m.val = translate(m.m.tok)
return 1
endProcedure scanSqlId
/*--- scan a delimited or ordinay sql identifier --------------------*/
scanSqlDeId: procedure expose m.
parse arg m
if scanSqlId(m) then
return 1
if \ scanString(m, '"') then
return 0
m.m.val = strip(m.m.val, 't')
return 1
endProcedure scanSqlDeId
/*--- scan a qualified sql identifier -------------------------------*/
scanSqlQuId: procedure expose m.
parse arg m, starOk
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx == 1 then
return 0 /* sometimes last qual may be '*' */
if starOk \== 1 | \ scanLit(m, '*') then
call scanErr m, 'id expected after .'
else if scanLit(scanSkip(m), '.') then
call scanErr m, 'dot after id...*'
else
leave
end
m.m.val.qx = m.m.val
res = res'.'m.m.val
rto = rto'.'m.m.tok
if \ scanLit(scanSkip(m), '.') then
leave
call scanSpace m
end
m.m.val.0 = qx
m.m.val = substr(res, 2)
m.m.tok = substr(rto, 2)
return 1
endProcedure scanSqlQuId
/*--- scan a sql number, Ignore After -------------------------------*/
scanSqlNumIA: procedure expose m.
parse arg m
if \ scanSqlNumPM(m) then
return 0
else if m.m.tok == '+' | m.m.tok == '-' then
call scanErr m, 'no sqlNum after +-'
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, + or -, ignore after -----------------------*/
scanSqlNumPM: procedure expose m.
parse arg m
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSkip m
end
else
si = ''
cx = scanNumUSPos(m)
if cx == 0 then do
m.m.val = si
m.m.tok = si
return si \== ''
end
m.m.tok = si || substr(m.m.src, m.m.pos, cx-m.m.pos)
m.m.val = translate(m.m.tok)
m.m.pos = cx
return 1
endProcedure scanSqlNumIA
/*--- scan a sql number, check After --------------------------------*/
scanSqlNum: procedure expose m.
parse arg m
if arg() \== 1 then
return err('old interface scanSqlNum') / 0
return scanCheckNumAfter(m, scanSqlNumIA(m))
endProcedure ScanSqlNum
/*--- scan a sql number with a unit which may follow without space --*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNumIA(m) then
return 0
nu = m.m.val
sp = scanSpace(m)
if scanSqlId(m) then do
if units == '' | wordpos(m.m.val, units) > 0 then
nu = nu m.m.val
else if both | \ sp then
call scanErr m, 'bad unit' m.m.val 'after' nu
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'bad unit after number' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/*--- find next statement, after scanSqlStmtOpt -----------------------
m.m.stop contains delimiter, will be changed by
terminator?; or --#terminator */
scanSqlStmtOpt: procedure expose m.
parse arg m, m.m.stop
if m.m.stop == '' then
m.m.stop = ';'
return m
endProcedure scanSqlStmtOpt
scanSqlStop: procedure expose m.
parse arg m
res = ''
fuCo = copies(m.m.scanComment'#SET', m.m.scanComment \== '')
u1 = '''"'left(m.m.scanComment, m.m.scanComment \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, u1 ,fuCo)
else
scTx = scanTextCom(m, u1||left(m.m.stop,1), m.m.stop fuCo)
if scTx then
res = res || m.m.tok
if fuCo \== '' then
if scanLook(m, length(fuCo)) == fuCo then do
if scanCom(m) then do
tx = m.m.tok
if word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1 then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else
say 'ignoring --##SET at' scanInfo(m)
end
iterate
end
if m.m.stop \== '' then
call scanLit m, m.m.stop
res = strip(res)
if length(res)=11 ,
& abbrev(translate(res), 'TERMINATOR') then do
m.m.stop = substr(res, 11, 1)
res = ''
end
return res
end
endProcedure scanSqlStop
scanSqlStmt: procedure expose m.
parse arg m
do forever
res = scanSqlStop(m)
if res <> '' then
return res
if scanEnd(m) then
return ''
end
endProcedure scanSqlStmt
/*-- return next sqlStmt from rdr ( or string or '' = j.in) ---------*/
scanSqlIn2Stmt: procedure expose m.
parse arg rdr, wOpt
s = scanSqlIn2Scan(rdr, m'.SCAN_SqlIn2Stmt', wOpt)
res = scanSqlStmt(scanOpen(s))
call scanReadClose s
return res
endProcedure scanSqlIn2Stmt
/*-- reset s as scanSql from rdr ( or string or '' = j.in) ----------*/
scanSqlIn2Scan: procedure expose m.
parse arg m, s, wOpt, sOpt
if m \== '' & wOpt == '' then
if oKindOfString(m) then
wOpt = 0
return scanSqlReset(s, in2File(m), wOpt, sOpt)
endProcedure scanSqlIn2Scan
/*-- create a new scanSqlStmtRdr ------------------------------------*/
scanSqlStmtRdr: procedure expose m.
parse arg rdr, wOpt, sOpt
return oNew('ScanSqlStmtRdr', rdr, wOpt, sOpt)
/*-- reset a new scanSqlStmtRdr
must be called from jReset to allow jRead ------------------*/
scanSqlStmtRdrReset: procedure expose m.
parse arg m, rdr, wOpt, sOpt
call scanSqlIn2Scan rdr, m'.SCAN', wOpt, sOpt
return oMutate(m, m.class_ScanSqlStmtRdr)
endProcedure scanSqlStmtRdrReset
/* copy scanSql 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 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 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 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 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 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 *******************************************************/