zOs/REXX/DDLCHECK
/* rexx ----------------------------------------------------------------
synopsis:
DDLCHECK SEL dsnSpec dbSys view objs+
http://chw20025641/host/db2wiki/pmwiki.php?n=Main.DbxDdlCheck
history:
13. 1.16 Walter new docu link
--------------- end of help */ /*-------------------------------------
23.11.15 Walter fix column line
18.11.15 Walter mit DBX Komaptibel gemacht
13. 7.15 Walter new interface
8. 5.15 Walter kidi63 ==> klem43
17. 4.15 Walter creator für Stephan wieder raus
24.10.14 Walter creator für Stephan in RZ2
10.01.14 Walter wieder csm.div
22.11.13 Walter S22 fuer DVBP
25. 9.13 Walter erlaube cat oq <-> o fuer overwrites
6. 8.13 Walter ix fuer spezialfall
18. 7.13 Walter fix sqlDisconnect und insert gp (null verschluckt n|)
28. 6.13 Walter db fuer Selektion - alle TS, kein check auf db selber
20. 6.13 Walter pieceSize Logik mit 2 Defaults
3. 6.13 Walter neu
----------------------------------------------------------------------*/
parse arg mArg
call errReset hi
call wshIni
call csvIni
m.myRexxLib = 'DSN.DB2.EXEC'
m.myRexxMbr = 'DDLCHECK'
m.spezialLib = 'DSN.DBX.SPEZIAL'
m.tDdlSel = 'OA1P.tQZ120DdlSel'
m.vDdlPre = 'OA1P.vQZ120Ddl'
m.m.toFree = ''
call mPut m'.SPEZIALTYPE.db', 'DB'
call mPut m'.SPEZIALTYPE.ts', 'TS'
call mPut m'.SPEZIALTYPE.t' , 'TB'
call mPut m'.SPEZIALTYPE.i' , 'IX'
m.spezialFallDBs = ''
m.v8order = 'order by cast(pa as varchar(1000) ccsid ebcdic)' ,
', cast(att as varchar(12) ccsid ebcdic)' ,
', cast(cat as varchar(2) ccsid ebcdic)'
if 0 then
say '???ddlCheck' m.myRexxLib'('m.myRexxMbr')'
m.tstO = ''
m.spezialOut = ''
if mArg == '' then
if m.err.ispf then
if adrEdit('macro (mArg)', '*') = 0 & mArg == '' then
mArg = 'checke2v'
if 0 & mArg = '' then do /* test cases */
if 0 then
mArg = 'dp4g t oa1p.tqz120ddlsel'
else if 0 then do
call qForm aa, csvRdr(file('A540769.TMP.TEXV(DDLEINS)'))
call err endTest
end
else if 0 then do
say '???? calling ddlCheck ....'
call dsnAlloc '~tmp.texv(sel1) dd(xsel)'
res = ddlChecK('SEL dd(XSEL) DX0G OA1P.vQZ120DdlChec8' ,
'ts:KS09A1P.A831A ts:KS09A1P.A863A ts:KS09A1P.A863H')
say '???? ddlCheck result =' res
exit
end
else if 1 then do
say '???? calling ddlCheck ....'
res = ddlCheck('check ~tmp.texv(ddlChe3) rzx/dx0g rz2/dbof ',
'ts:TG01A1P.A051%')
/* 'ts:BP02A1P.A204%') */
/* res = ddlCheck('check ~tmp.texv(ddlChe2) rz8/dx0g rz2/dbof ',
't:OA1A.TMF150A1 t:OA1P.TMF15% t:OA%.TNI250%') */
say '???? ddlCheck result =' res
call outSt splitNl(xx, 'qualityCheck' res)
call adrIsp "view dataset(tmp.texv(ddlche3))", 4
exit
end
else if 0 then
mArg = 'sel ~tmp.texv(ddlCheck) dbaf' m.vDdlPre'Chec8' ,
't:OA1A.TMF150A1 t:OA1A.TMF160A1 t:OA%.TNI250%',
'ts:BE0%.A010% ts:BE0%.A10%',
'v:OA1A.VMF150% i:OA1A.IMF160% i:OA%.INI250%'
end
if pos('?', mArg) > 0 | mArg = '' then
exit help()
call scanSrc s, mArg
fun = scanRetWord(s, ,1)
if fun == 'CHECK' then do
dsn = scanRetWord(s, , , 'dsnSpec')
xRzDb = scanRetWord(s, , , 'rz/db2Subsystem')
parse var xRzdb xRz '/' xDbSys
yRzDb = scanRetWord(s, , , 'rz/db2Subsystem')
parse var yRzdb yRz '/' yDbSys
if xRzDb == 'RZ2/DVBP' then
xRz = 'S22'
if yRzDb == 'RZ2/DVBP' then
yRz = 'S22'
rest = scanLook(s)
/* say 'check to dsn='dsn
say ' from prototype rz='xRz 'dbsys='xDbSys
say ' from production rz='yRz 'dbsys='yDbSys
say ' rest' rest */
rX = selectOne(m, xRz, xDbSys, m.vDdlPre'Chec8', xSel, rest)
rY = selectOne(m, yRz, yDbSys, m.vDdlPre'CheS8', ySel, rest)
call pipe '+F', file(dsn)
sum = qForm(m, rX, rY, xRzDb, yRzDb)
call pipe '-'
call tsoFree m.m.toFree
return sum
end
else if fun == 'SEL' then do
dsn = scanRetWord(s, , , 'dsnSpec')
dbSys = scanRetWord(s, , , 'db2 system')
view = scanRetWord(s, , , 'view to select from')
parse var view vCr '.' vw
/* say 'select to dsn='dsn
say ' from dbSys='dbSys 'view='view */
call sqlConnect dbSys
o = jOpen(file(dsn), '>')
/* m.tstO = o ?????????? test
call jWrite o, '*** mArg='mArg
call jWrite o, '*** sql=select * from' view m.v8order */
call insSels s
call jWriteAll o, csvWrt(sqlRdr('select * from' view m.v8order))
call jClose o
call sqlDisconnect
end
else if fun == 'DDLX' then do
if adrEdit('macro (spec) PROCESS', '*') \== 0 then
exit err(' }not used as editmacro rc='rc )
call editMacroXS ut2lc(spec)
end
else if fun == 'EDITXS' then do
call editMacroXS ut2lc(strip(scanLook(s)))
end
else do
if length(fun) <= 4 then do
cI = 'A'
cO = 'V'
m.s.pos = 1
end
else if abbrev(fun, 'CHECK') & length(fun) == 8 ,
& substr(fun, 7, 1) == 2 then do
cI = substr(fun, 6, 1)
cO = substr(fun, 8, 1)
end
else
call err 'i}bad fun' fun 'in args' mArg
if cI == 'A' then
i = ''
else if cI == 'E' then
i = oNew('EditRead', 1)
else if cI == 'I' then
i = file('dd(checkIn')
else
call err ' }bad input' cI 'fun='fun 'args='mArg
if cO == 'V' then do
o = fEdit('::v','v macro('m.myRexxMbr') parm(editXS)')
end
else if cO == 'O' then do
o = file('dd(checkout)')
m.o.tso_truncOk = 1
end
else
call err ' }bad output' cO 'fun='fun 'args='mArg
call checkLocal s, i, o
end
exit 0
/*--- eXlude S lines, that are not followed by an error --------------
ddlX (w ! c)? o?
w: do NOT eXclude =- (old or dropped) s-lines
c: do NOT eXclude +- (created or dropped) s-lines
o: hide o or a (overwrites or advice) lines
---------------------------------------------------------------------*/
editMacroXS: procedure expose m.
parse arg sp
call scanSrc se, sp
if scanLit(scanSkip(se), 'w', 'c') & m.se.tok == 'w' then
showNewOld = '=-'
else
showNewOld = '+-'
if scanLit(scanSkip(se), 'o') then
catIgn = 'o a'
else
catIgn = ''
if \ scanEnd(scanSkip(se)) then
call scanErr se, "bad macro argument '"sp"'," ,
"w c o or nothing expected"
call adrEdit 'reset'
call adrEdit '(ll) = lineNum .zl'
fnd = 0
do lx=ll by -1 to 4
call adrEdit '(li) = line' lx
cat = strip(substr(li, 5, 2))
if abbrev(cat, 's') then do
if cat == 's' & pos(left(li, 1), showNewOld) < 1 ,
& \ fnd then
call adrEdit 'xstatus' lx '= x'
fnd = 0
end
else if wordPos(strip(cat), catIgn) > 0 then
call adrEdit 'xstatus' lx '= x'
else
fnd = 1
end
return
endProcedure editMacroXS
checkLocal: procedure expose m.
parse arg s, i, o
if i \== '' then do
call scanReadReset s2, i
call scanReadOpen s2, m.s.src
m.s2.pos = m.s.pos
s = s2
end
fun = scanRetWord(s, ,1)
if length(fun) <> 4 | \ abbrev(fun, 'D') then do
fun = ''
call scanBack s, m.s.tok
end
call sqlConnect fun
call insArgSels s
if \ scanEnd(s) then
call scanErr s, 'db, t, ts, ... or end expected'
view = 'OA1P.VQZ120DDLCHESU8'
call pipe '+F', o
call qFormOne m, sqlRdr('select * from' view m.v8order), 'test tit'
call sqlDisconnect
call pipe '-'
return
endProcedure checkLocal
insSels: procedure expose m.
parse arg s
call sqlUpdate 1, 'delete from' m.tDdlSel, 'w'
/* say m.sql.1.updateCount 'rows deleted from' vCr'.'tDdlSel */
cTy = ''
do while scanWord(scanSkip(s))
parse var m.s.val ty ':' cr '.' nm
/* if m.tstO \=='' then
call jWrite m.tstO, '****insSels v='m.s.val */
if ty == cTy & cCr == cr then do
cNm = cNm nm
end
else do
if cTy \== '' then
call insType cTy, cCr, cNm
cTy = ty
cCr = cr
cNm = nm
end
end
if cTy == '' then
call err ' }no selections'
call insType cTy, cCr, cNm
/* if m.tstO \=='' then
call jWrite m.tstO, '****insSels end cTy='cTy */
return
endProcedure insSels
insArgSels: procedure expose m.
parse arg s
call scanOpt s, , , '--'
types = 'db t tb ts i ix v'
call sqlUpdate 1, 'delete from' m.tDdlSel, 'w'
/* say m.sql.1.updateCount 'rows deleted from' vCr'.'tDdlSel */
ty = ''
do forever
do while scanLit(scanSkip(s), ',')
end
if \ scanName(s) then
leave
if wordPos(ut2lc(m.s.tok), types) < 1 then do
call scanBack s, m.s.tok
leave
end
ty = ut2lc(m.s.tok)
if wordPos(ty, 'tb ix') > 0 then
ty = left(ty, 1)
call scanLit scanSkip(s), '='
if \ scanWhile(scanSkip(s), m.ut_alfNum'_%*?\') then
call scanErr s, 'qualifier for' ty 'expected'
qu = translate(m.s.tok)
nm = ''
do forever
do while scanLit(scanSkip(s), '.')
end
if \ scanWhile(scanSkip(s), m.ut_alfNum'_%*?\') then
leave
if length(m.s.tok) <= 2 then
if verify(m.s.tok, '%_*?', 'm') = 0 then do
call scanBack s, m.s.tok
leave
end
nm = nm translate(m.s.tok)
end
if ty == 'db' | nm <> '' then
call insType ty, translate(translate(qu), '%_', '*?') ,
, translate(translate(nm), '%_', '*?')
else
call scanErr s, 'no names for type='ty
end
if ty == '' then
call err 'i}no selections'
return
endProcedure insArgSels
insType: procedure expose m.
parse arg ty, qu, nm
/* if m.tstO \=='' then
call jWrite m.tstO, '****insType('ty',' qu',' nm')' */
f1 = "sysibm.sys"
if ty == 'db' then
call insOne 'ts', f1"Tablespace", dbName, name,
, sqlPredList(dbName, qu nm)
else if ty == 'i' then
call insOne 'i', f1"Indexes", "creator", "name",
, sqlPredList(creator, qu) ,
, sqlPredList(name , nm)
else if ty == 't' then
call insOne 't', f1"Tables", "creator", "name" ,
, "type not in ('A', 'V') and" ,
sqlPredList(creator, qu) ,
, sqlPredList(name , nm)
else if ty == 'ts' then
call insOne 'ts', f1"TableSpace", "dbName", "name" ,
, sqlPredList("dbName", qu) ,
, sqlPredList("name" , nm)
else if ty == 'v' then
call insOne 'v', f1"Tables", "creator", "name" ,
, "type in ('V') and" ,
sqlPredList(creator, qu) ,
, sqlPredList(name , nm)
else
call err 'bad insType' ty
return
endProcedure insType
sqlPredList: procedure expose m.
parse arg col, list
pEq = ''
pLi = ''
do wx=1 to words(list)
w1 = word(list, wx)
if verify(w1, '%_', 'm') = 0 then
pEq = pEq", '"w1"'"
else
pLi = pLi "or" col "like '"w1"' escape '\'"
end
if pEq = '' then
p = ''
else if words(pEq) = 2 then
p = col "=" substr(pEq, 3)
else
p = col "in ("substr(pEq, 3)")"
if pLi = '' then
return p
if p <> '' then
p = p 'or'
p = p substr(pLi, 5)
if pos(' or ', p) > 0 then
p = '('p')'
return p
endProcedure sqlPredList
insOne: procedure expose m.
parse arg ty, tb, qu, nm, pQu, pNm
sq = "insert into" m.tDdlSel "select '"ty"'," qu"," nm ,
"from" tb "where" pQu
if pNm <> '' then
sq = sq "and" pNm
call sqlUpdate 1, sq, 100
/* say m.sql.1.updateCount '???rows inserted by' sq */
return
endProcedure insOne
selectOne: procedure expose m.
parse arg m, rz, dbSys, vw, dd, rest
upper rz
if rz <> '' & rz <> sysvar(sysnode) then do
call dsnAlloc rz"/"userid()".TMP."dd" DD("dd") new ::v"
call csmExRx rz, m.myRexxLib, ,'%'m.myRexxMbr ,
'SEL dd('dd')' dbSys vw rest
m.m.toFree = m.m.toFree dd
return csvRdr(file('dd('dd')'))
end
else do
parse var vw cr '.' nm
call sqlConnect dbSys
call scanSrc sOne, rest
call insSels sOne
o = jOpen(jBuf(), '>')
call jWriteAll o, sqlRdr('select * from' vw m.v8Order)
call sqlDisconnect
call jCLose o
return o
end
endProcedure selectOne
qFormOne: procedure expose m.
parse arg m, xR, xTit
call jOpen xR, '<'
call out right('help' ,
'http://chw20025641/host/db2wiki/pmwiki.php?n=Main.DbxDdlCheck',72)
call out ' '
rzdb = sysvar(sysnode)'/'m.sql_dbSys
call out 'ddlCheck' rzdb timestampNow()
call out ' '
call out qFormOn2('ty', 'ca', 'creator.name', 'attribute',
, 'value'rzDb, 'standard', 'path')
do while jRead(xR)
call out qFormOn1(m.xR)
end
call jClose xR
return
endProcedure qFormOne
qFormOn1: procedure expose m.
parse arg i
return qFormOn2(m.i.ty, m.i.cat, m.i.qu || '.' || m.i.nm ,
, m.i.att, m.i.val, m.i.std, m.i.pa)
qFormOn2: procedure expose m.
parse arg ty, cat, qn, att, val, std, pa
if abbrev(att, 'count ') & verify(val, '0123456789') = 0 then
val =rigPad(val, 6)
return lefPad(lefPad(lefPad(lefPad(lefPad(left(' 'ty, 3) cat, 6),
qn, 27) att, 40) val, 54) std, 67) pa
endProcedure qFormOn2
/*--- format a compare list x=new, y=old (prod) ---------------------*/
qForm: procedure expose m.
parse arg m, xR, yR, xTit, yTit
xJ = jRead(jOpen(xR, '<'))
yJ = jRead(jOpen(yR, '<'))
m.m.stats = ''
call out right('help' ,
'http://chw20025641/host/db2wiki/pmwiki.php?n=Main.DbxDdlCheck',72)
call out left('*ty ca object', 47) left('rows' yTit, 13) 'size'
call out ' ty ca name attribute ',
left(xTit, 13) 'standard ' yTit
call out ' '
do forever
xI = m.xR
yI = m.yR
if \ xJ then
if \ yJ then
leave
else
cuNewOld = '-'
else if \ yJ then
cuNewOld = '+'
else if m.xI.pa \== m.yI.pa then
cuNewOld = plusEqMinus(m.xI.pa, m.yI.pa)
else if abbrev(m.xI.cat, 's') then /* first a structure */
if abbrev(m.yI.cat, 's') then
cuNewOld = '='
else
cuNewOld = '+'
else if abbrev(m.yI.cat, 's') then
cuNewOld = '-'
else /* then a list of atts*/
cuNewOld = plusEqMinus(m.xI.att, m.yI.att)
if cuNewOld == '+' then
cI = xI
else
cI = yI
cPs = m.cI.pa
if m.cI.ty == 'c' then /* remove column from path */
if abbrev(word(cPs, words(cPs)), 'c=') then
cPs = subword(cPs, 1, words(cPs) - 1)
else
call err 'bad c= in path' qFormL0(cI)
if laPs \== cPs then do
if \ abbrev(m.cI.cat, 's') then
call err cuNewOld 'cat=s% expected not' qFormL0(cI)
laPs = cPs
laNewOld = cuNewOld
call out qFormS1(m, cuNewOld, cI)
end
else if abbrev(m.cI.cat, 's') then do
call err cuNewOld 'cat=s% not first' qFormL0(cI)
end
else if cuNewOld == '=' then do /* compare val of att */
if qFormDoOut(xI, yI) then
call out qFormL1(m, laNewOld, cuNewOld, xI, yI)
if m.xI.std \== m.yI.std then
call err 'std \==' qFormL0(xI) '\==' qFormL0(yI)
end
else do /* only one */
if qFormDoOut(cI) then
call out qFormL1(m, laNewOld, cuNewOld, cI)
end
if cuNewOld \== '-' then
xJ = jRead(xR)
if cuNewOld \== '+' then
yJ = jRead(yR)
end
call jClose xR
call jClose yR
do dx=1 to words(m.spezialFallDbs)
d1 = word(m.spezialFallDbs, dx)
call out ' '
call out left('special rules from' m.spezialLib'('d1') ',80,'*')
call outSt spezialFall'.'d1
end
return statsSum(m, 'n pq p - oq iq sb + =')
endProcedure qForm
plusEqMinus: procedure
parse arg l, r
if l == r then
return '='
else if l << r then
return '+'
else
return '-'
endProcedure plusEqMinus
/*--- piecesize has 2 stdValues 2G and 4G,
hide 4G valueS that do not change production --------*/
qFormDoOut: procedure expose m.
parse arg xI, yI
if yI \== '' & m.xI.cat \== m.yI.cat then do
if wordPos(m.xI.cat, 'o oq') > 0 ,
& wordPos(m.yI.cat, 'o oq') > 0 then do
m.xI.cat = 'oq'
m.yI.cat = 'oq'
end
else
call err 'cat \==' qFormL0(xI) '\==' qFormL0(yI)
end
if m.xI.att \== 'piecesize' then
return 1
if m.xI.val \= 0 & m.xI.val \= 2097152 & m.xI.val \= 4194304 then
return 1
if yI == '=' then
return 0
return m.xI.val \== m.yI.val
endProcedure formDoOut
qFormL0: procedure expose m.
parse arg i1
return 'ty='m.i1.ty 'qu='m.i1.qu 'nm='m.i1.nm 'cat='m.i1.cat ,
'att='m.i1.att 'val='m.i1.val 'std='m.i1.std 'pa='m.i1.pa
endProcedure qFormL0
qFormS1: procedure expose m.
parse arg m, newOld, i1
if m.i1.cat \== 's' then
call statsAdd m, newOLD, m.i1.cat, i1
call statsAdd m, newOld, newOld, i1
if abbrev(m.i1.pa, 'db=') then do
db = substr(word(m.i1.pa, 1), 4)
call spezialFall db, 'DB', db
t1 = m.i1.ty
if symbol('m.m.spezialType.t1') == VAR then
call spezialFall db, m.m.spezialType.t1, m.i1.qu, m.i1.nm
end
return ,
lefPad(lefPad(lefPad( ,
newOld || left(m.i1.ty, 2) left(m.i1.cat, 2) ,
strip(m.i1.qu)'.'strip(m.i1.nm), 47) ,
m.i1.val, 61) m.i1.std, 100) m.i1.pa
endProcedure qFormS1
/*--- format one compare line ---------------------------------------*/
qFormL1: procedure expose m.
parse arg m, stNO, cuNO, nO, oO
if (oO == '') == (cuNo=='=') | (stNO \== '=' & stNo \== cuNO) then
call err 'bad call qFormL1('m',' stNO',' cuNO',' nO',' oO')'
if cuNO == '='then do
if m.nO.att \== m.oO.att then
call err 'newOld' stNO 'but att <>'
if m.nO.std \== m.oO.std then
call err 'newOld' stNO 'but std <>' ,
'\n new' m.nO.ty m.nO.cat m.nO.nm m.nO.att ,
'std='m.nO.std c2x(m.nO.std) ,
'\n old' m.oO.ty m.oO.cat m.oO.nm m.oO.att ,
'std='m.oO.std c2x(m.oO.std)
nVal = m.nO.val
oVal = m.oO.val
aO = nO
end
else do
if stNo == '=' then
parse var m.nO.std cStd ',' .
else
cStd = '---'
if cuNO == '+' then do
nVal = m.nO.val
oVal = cStd
end
else do
oVal = m.nO.val
nVal = cStd
end
end
call statsAdd m, stNO, m.nO.cat, nO, nVal, oVal
vNm = ''
if m.nO.ty == 'c' then
vNm = m.nO.nm
return ,
lefPad(lefPad(lefPad(lefPad(lefPad( ,
left(' 'm.nO.ty, 3) left(m.nO.cat, 4) vNm, 20) ,
m.nO.att, 33) ,
nVal, 47) m.nO.std, 61) oVal, 100) m.nO.pa
endProcedure qFormL1
qFormLine: procedure expose m.
parse arg i1
return ,
lefPad(lefPad(lefPad(lefPad(lefPad(lefPad(,
left(m.i1.ty, 2) m.i1.qu, 11) m.i1.nm, 28),
m.i1.cat, 32) m.i1.att, 45) ,
m.i1.val, 59) m.i1.std, 73)
endProcedure qFormLine
statsAdd: procedure expose m.
parse arg m, newOld, c1, i1, xVal, yVal
if wordPos(c1, m.m.stats) < 1 then do
m.m.stats = m.m.stats c1
m.m.stats.c1 = 0
end
m.m.stats.c1 = m.m.stats.c1 + 1
if m.m.stats.c1 <= 3 then do
t = newOld || left(m.i1.ty, 2) left(m.i1.cat, 2),
m.i1.qu'.'m.i1.nm
if abbrev(m.i1.cat, 's') then
t = t 'rows='m.i1.val 'size='m.i1.std
else
t = t m.i1.att xVal'<'m.i1.std'>'yVal
call mPut m'.STATS.'c1'.'m.m.stats.c1, t
end
return
endProcedure statsAdd
statsSum: procedure expose m.
parse arg m, lst
ly = words(lst)
lst = lst m.m.stats
done = ''
m1 = ''
m2 = ''
ox = 0
if m.spezialFallDbs <> '' then
m1 = ', special'
do lx=1 to words(lst)
c1 = word(lst, lx)
if wordPos(c1, done) > 0 | wordPos(c1, m.m.stats) < 1 then
iterate
m1 = m1',' m.m.stats.c1'*'c1
done = done c1
do cx=1 to min(3, m.m.stats.c1) while lx<=ly & ox < 5
ox = ox + 1
m2 = m2'\n||' m.m.stats.c1.cx
end
end
return '||' substr(m1, 3)m2 || m.spezialOut
endProcedure statsSum
spezialFall: procedure expose m.
parse arg db, ty, qu, nm
if 1 == m.spezialDone.db.ty.qu.nm then
return
m.spezialDone.db.ty.qu.nm = 1
st = spezialFall'.'db
if symbol('m.st.0') <> 'VAR' then do
dsn = m.spezialLib"("db")"
sy = sysDsn("'"dsn"'")
if sy <> 'OK' then do
m.st.0 = 0
if sy <> 'MEMBER NOT FOUND' then
call err 'spezialFall library' dsn':' sy
end
else do
call readDsn dsn, 'M.'st'.'
m.spezialFallDBs = m.spezialFallDBs db
end
end
if m.st.0 < 1 then
return
offs = 999
found = 0
do sx = 1 to m.st.0
fx = verify(m.st.sx, ' ')
if fx = 0 | fx > 72 then
iterate
if substr(m.st.sx, fx, 1) = '*' then
iterate
if fx <= offs then do
offs = fx
m.st.sx = left(m.st.sx, 72)
n = ''
if pos('.', m.st.sx) > 0 then
parse upper var m.st.sx t q '.' n .
else
parse upper var m.st.sx t q .
if t \== ty | m.spezialDonL.db.sx == 1 then
iterate
if t == 'DB' then
found = match(strip(db), strip(q))
else if wordPos(t, 'TS TB IX') > 0 then
found = match(strip(qu)'.'strip(nm),
, strip(q)'.'strip(n))
else
call err 'spezialFall' db 'line' sx 'ungueltig:' m.st.sx
if found then
m.spezialDonL.db.sx = 1
end
if found then
m.spezialOut = m.spezialOut'\n|-' left(m.st.sx, 78)
end
return
/* copy wsh ab hier ??????????????????? */
/* rexx ****************************************************************
wsh: walter's rexx shell version 5.0
interfaces: 27.20.15
edit macro: for adhoc evaluation or programming
either block selection: q or qq and b or a
oder mit Directives ($#...) im Text
wsh i: tso interpreter
batch: input in dd wsh
docu: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.Wsh
syntax: http://chw20025641/host/db2wiki/pmwiki.php?n=Main.WshSyn
|||achtung $@.sqlRdr() funktioniert nicht nur $@..[sqlRdr() $]
||| sqlSel schreib ]$#out |||||
||| einheitliches sql select/rdr syntax in wsh (mit ftab oder ohne|)
|||sql select aus rz2 muss wie csmExRx erfolgen (via WSH) ||||
--- history ------------------------------------------------------------
16. 1.15 f: get/put read/write in/out Object/Strings transparent weiter
*********/ /*** end of help ********************************************
17.11.14 f: iirz2p ==> plex Buchstaben
17.06.14 f: %tS %tT und %tN mit MicroSekunden
16.06.14 csmCopy auch für LoadModule usw.
30.05.14 fix sql4obj fuer rcm profex
14.04.14 class vor obj, mit lazy
19.03.14 ii = installation Info
9.01.14 walter: redesign formatting (fmt eliminiert), csm.div.p0.exec
3.12.13 walter: db2 interface radikal geputzt
3.10.13 walter: uCount fuer TSO <-> unitCount fuer Csm
23. 9.13 walter: ws2 syntax
6. 2.13 w.keller csmCopy aendert mgmtClas für neue lokale Files
23. 1.13 w.keller sqlErrHandler sowie sqlRx und sql
11. 6.12 w.keller sqlUpdComLoop
23. 5.12 w.keller fix sqlStmt: drop accepts -204
31. 3.12 w.keller sql Query interface incl. sql über CSM
10. 2.12 w.keller div catTb* und eLong
2. 6.11 w.keller sql error with current location and dsnTiar
2. 5.11 w.keller sqlStmt etc..
16. 3.11 w.keller basic new r '' ==> r m.class_O
28. 2.11 w.keller compFile by exprBlock, fix $@do forever, |
7. 2.11 w.keller cleanup block / with sqlPush....
2. 2.11 w.keller simplified syntax, ast for blocks, ? for help
19. 6.10 w.keller open/close stacked mit jUsers, framed eliminiert
19. 5.10 w.keller class wird direkt erzeugt ohne temporary
18. 4.10 w.keller scanUtilInto ==> testCase noch einbauen
17. 4.10 w.keller oMutate in fileTsoList eingebaut
14. 1.10 w.keller batch interface no longer dies on openIfNotYet
CSM.RZ1.P0.EXEC korrigiert
***********************************************************************/
if 0 then do
do y = left(date('s'), 4) - 17 to left(date('s'), 4) + 7
say y timeYear2Y(y) timeY2Year(timeYear2Y(y))
end
do y = left(date('s'), 4) - 69 to left(date('s'), 4) + 30
say y timeYear24(substr(y, 3))
end
d = date('s')
say d 'b' date('b', d , 's')
say d 'b' date('b', 20150101, 's') 'jul' date('j')
say d 'l14' date('b', 20150101, 's') - date('b', 20140101, 's')
say d 'l16' date('b', 20170101, 's') - date('b', 20160101, 's')
exit
end
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
m.myLib = 'A540769.WK.REXX'
m.myVers = 'v50 27.10.15'
call wshLog
parse arg spec
isEdit = 0
if spec = '' & m.err.ispf then do /* z/OS edit macro */
isEdit = adrEdit('macro (spec) NOPROCESS', '*') == 0
if isEdit then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
m.editDsn = dsnSetMbr(d, m)
if spec = '' & abbrev(m.editDsn, 'A540769.WK.REXX(WS') ,
& length(dsnGetMbr(m.editDsn)) <= 4 then do
spec = 't'
isEdit = 0
end
end
end
spec = strip(spec)
if spec = '?' then
return help()
else if translate(word(spec, 1)) == 'T' then
return wshTst(subword(spec, 2))
else if spec <> '' & \ abbrev(spec, '$#') then
spec = '$#'spec
rest = ''
inp = ''
out = ''
call wshIni
if m.err.os == 'TSO' then do
if isEdit then do
parse value wshEditBegin(spec) with inp out
end
else if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = file('dd(wsh)')
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = file('dd(out)')
end
end
else if m.err.os == 'LINUX' then do
inp = file('&in')
out = file('&out')
end
else
call err 'implement wsh for os' m.err.os
m.wshInfo = 'compile'
m.wsh_exitCC = 0
call compRun spec, inp, out, wshInfo
if isEdit then
call wshEditEnd
exit m.wsh_exitCC
wshLog: procedure expose m.
parse arg msg, st
lNm = 'tss.ska.db2.wshlog'
f1 = dsnAlloc('dd(log) mod' lNm '::f', , , '*')
if datatype(f1, 'n') then do
lN2 = lNm'.R' || ( random() // 19)
f1 = dsnAlloc('dd(log) old' lN2 '::f', , , '*')
if datatype(f1, 'n') then do
say 'could not allocate log' lNm lN2
return
end
end
parse source . . s3 .
o.1 = m.myLib'('s3')' word(m.myVers, 1) sysvar(sysnode) ,
'j='mvsvar('symdef', 'jobname') ,
'u='userid() date('s') time()
if msg <> '' then
o.2 = left(msg, 80)
ox = 1 + (msg <> '')
if st <> '' then do sx=1 to m.st.0
ox = ox+1
o.ox = left(m.st.sx, 80)
end
call writedd log, o., ox
call tsoClose log
call tsoFree log
return
endProcedure wshLog
/*--- test hook ----------------------------------------------------*/
wshHook_T: procedure expose m.
parse arg cmp
rest = strip(scanLook(m.cmp.scan))
call compEnd cmp
return wshTst(rest)
endProcedure wshHook_t
wshTst: procedure expose m.
parse arg rest
m.tst_csm = 1
if rest = '' then do /* default */
say funits(3e7, 'd')
call err tstEnd
call csmcopy 'CMN.DIV.P0.DB2J.#000197.LLB' ,
, 'RZ1/A540769.TST.LXB'
return 0
call csmcopy 'RZ1/A540769.TST.PS' ,
, 'RZ4/A540769.TST.PO3(EINS)'
return 0
call csmcopy 'RZ1/A540769.TST.LCTL(BBB)',
, 'RZ4/A540769.TST.PS'
return 0
call csmcopy 'A540769.WK.LLB' ,
, 'RZ1/A540769.TST.LLB'
call csmCopL 'RZ4/A540769.WK.JCL(QZ*)',
, 'RZ1/A540769.TST.yCL'
return 0
call tstfTst
call sqlConnect DBAF
call catColCom 'cmnBatch', 'DSN_PGROUP_TABLE',
, 'cmnBatch', 'DSN_PGROUP_TABLE_new'
call sqlDisConnect
return 0
end
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if wx > 2 then
c = c 'call tstTotal;'
say 'wsh interpreting' c
interpret c
exit 0
endProcedure wshTst
/*--- i hook: interpret user input: rexx, expr, data or shell -------*/
wshHook_I: procedure expose m.
parse arg cmp
inp = strip(scanLook(m.cmp.scan))
call scanClose m.cmp.scan
mode = '*'
do forever
if pos(left(inp, 1), '/;:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '/' then
exit 0
mode = translate(mode, ';', ':')
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = ';' then
interpret inp
else if mode = '*' then
interpret 'say' inp
else do
call errReset 'h', 'say "******* intercepting error";',
'call errSay ggTxt; return "";'
call oRun compile(comp(jBuf(inp)), mode)
call errReset 'h'
end
end
say 'enter' mode 'expression, / for end, ; or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- sql hook -----------------------------------------------------*/
wshHook_S: procedure expose m.
parse arg cmp
s = m.cmp.scan
ki = '='
call scanVerify s, m.comp_chSpa
if scanVerify(s, m.comp_chKind) then
ki = left(m.s.tok, 1)
call scanChar s
rest = m.s.tok
call scanNl s
dbSy = word(rest, 1)
if abbrev(dbSy, '-') | \ (length(dbSy) = 4 ,
| (length(dbsy) = 8 & substr(dbSy,4,1) == '/')) then
dbSy = ''
else
rest = subWord(rest, 2)
res = compAST(cmp, 'P', ' f', '',
, compAstAddOp(cmp, compUnit(cmp, ki, '$#'), '@'))
call mAdd res, compAst(cmp, ';', ,
, compAst(cmp, '+', "call sqlConnect '"dbSy"'",
"; if \ sqlStmts( , 'rb ret', '"rest"') then m.wsh_exitCC=8" ,
"; call sqlDisConnect;" ))
return res
endProcedure wshHook_s
wshEditBegin: procedure expose m.
parse arg spec
dst = ''
li = ''
m.wsh.editHdr = 1
pc = adrEdit("process dest range Q", 0 4 8 12 16)
if pc = 16 then
call err 'bad range must be q'
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
/* say 'range' rFi '-' rLa */
end
else do
rFi = ''
/* say 'no range' */
end
if pc = 0 | pc = 4 then do
call adrEdit "(dst) = lineNum .zDest"
/* say 'dest' dst */
dst = dst + 1
end
else do
/* say 'no dest' */
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
/* say '$#out' dst */
call adrEdit "(li) = line" dst
m.wsh.editHdr = 1
end
end
m.wsh.editDst = dst
m.wsh.editOut = ''
if dst \== '' then do
eo = jOpen(jbufText(), '>')
m.wsh.editOut = eo
call adrEdit '(recl) = LRECL'
m.eo.maxL = recL
if m.wsh.editHdr then
call jWrite eo, left(li, 50) date('s') time()
end
if rFi == '' then do
call adrEdit "(zLa) = lineNum .zl"
if adrEdit("find first '$#' 1", 4) = 0 then do
call adrEdit "(rFi) = cursor"
call adrEdit "(li) = line" rFi
if abbrev(li, '$#out') | abbrev(li, '$#end') then
rFi = 1
if rFi < dst & dst \== '' then
rLa = dst-1
else
rLa = zLa
end
else do
rFi = 1
rLa = zLa
end
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
m.wsh.editIn = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite m.wsh.editIn, li
end
call errReset 'h',
, 'return wshEditErrH(ggTxt, ' rFi',' rLa')'
return jClose(m.wsh.editIn) m.wsh.editOut
endProcedure wshEditBegin
wshEditEnd: procedure expose m.
call errReset 'h'
if m.wsh.editOut == '' then
return 0
call jClose(m.wsh.editOut)
lab = wshEditInsLinSt(m.wsh.editDst, 0, , m.wsh.editOut'.BUF')
call wshEditLocate max(1, m.wsh.editDst-7)
return 1
endProcedure wshEditEnd
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
call adrEdit 'locate ' max(1, min(ln, la - 37))
return
endProcedure wshEditLocate
wshEditErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errCleanup
call errReset 'h'
call splitNl err, errMsg(' }'ggTxt)
call mMove err, 1, 2
isScan = 0
if wordPos("pos", m.err.4) > 0 ,
& pos(" in line ", m.err.4) > 0 then do
parse var m.err.4 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.err.4 " line " lin":"
pos = 0
end
isScan = lin \== ''
end
m.err.1 = '***' m.wshInfo 'error ***'
if m.wshInfo=='compile' & isScan then do
do sx=1 to m.err.0
call out m.err.sx
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', err)
call wshEditLocate rFi+lin-25
end
else do
if m.wsh.editOut \== '' then do
do sx=1 to m.err.0
call jWrite m.wsh.editOut, m.err.sx
end
lab = wshEditInsLinSt(m.wsh.editDst, 0, ,
, m.wsh.editOut'.BUF')
call wshEditInsLinSt m.wsh.editDst, m.wsh.editHdr,
, msgline, err
call wshEditLocate max(1, m.wsh.editDst-7)
end
else do
do sx=1 to m.err.0
say m.err.sx
end
end
end
call errCleanup
exit
endSubroutine wshEditErrH
wshEditInsLinCmd: procedure
parse arg wh
if dataType(wh, 'n') then do
if adrEdit("label" wh "= .a", 0 8 12) \= 12 then
return 'line_before .a ='
else
return 'line_after .zl ='
end
else if left(wh, 1) == '.' then
return 'line_before' wh '='
else
return wh
endProcedure wshEditInsLinCmd
wshEditInsLin: procedure
parse arg wh, type
cmd = wshEditInsLinCmd(wh)
do ax=3 to arg()
li = strip(arg(ax), 't')
/* if li == '' then nein, leere Zeilen doch anzeigen | */
if translate(type) = 'MSGLINE' then do while length(li) > 72
sx = lastPos(' ', li, 72)
if sx < 10 then
sx = 72
one = left(li, sx)
li = ' 'strip(substr(li, sx))
call adrEdit cmd type "(one)"
end
call adrEdit cmd type "(li)", 0 4
end
return cmd
endProcedure wshEditInsLin
wshEditInsLinSt: procedure expose m.
parse arg wh, pl, type, st
if wh == '' then do
do ox=1 to m.st.0
say m.st.ox
end
return ''
end
wh = wh + pl
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
/*** end wsh, begin all copies ****************************************/
/*** abub compatibility ***********************************************/
loadCols: procedure expose m.
if (\ in()) | word(m.in, 1) <> 'LOAD' then
call err 'not load but' m.l1
do while in() & strip(m.in) \== '('
end
if strip(m.in) \== '(' then
call err '( not found in load:' m.in
m.in = '-'
do while in() & strip(m.in) \== ')'
call out m.in
end
if strip(m.in) \== ')' then
call err ') not found in load:' m.in
return 1
endProcedure
/*** end abub compatibility *******************************************/
/* copy tstAll begin *************************************************/
/*----------- neu, noch versorgen |||||-------------------------------*/
tstRts: procedure expose m.
call wshIni
call sqlConnect dbaf
call sqlQuery 3, "select * from sysibm.sysTableSpaceSTats" ,
"where dbName = 'MF01A1A' and name = 'A150A'",
"order by partition asc"
do while sqlFetch(3, rr)
say f('@.DBNAME%-8C.@NAME%-8C @PARTITION %4C' ,rr)
end
call sqlDisconnect
endProcedure tstRts
tstWiki:
call mapReset docs, 'k'
call addFiles docs, 'n', '/media/wkData/literature/notes'
call addFiles docs, 'd', '/media/wkData/literature/docs'
in = jOpen(file('wiki.old'), '<')
out = jOpen(file('wiki.new'), '>')
abc = '(:abc: %l%'
do cx=1 to length(m.ut_lc)
c1 = substr(m.ut_lc, cx, 1)
abc = abc '[[#'c1 '|' c1']]'
end
call jWrite out, abc ':)'
inTxt = 0
li = m.i
do lx=1 while jReadVar(in, i)
if 0 then
say length(m.i) m.i
if m.i = '' then
iterate
li = m.i
do forever
bx = pos('[=', li)
if bx < 1 then
leave
ex = pos('=]', li)
if ex <= bx then
call err '=] before [= in' lx li
li = left(li, bx-1)substr(li,bx+2, ex-bx-2)substr(li,ex+2)
end
li = strip(li)
if abbrev(li, '|') then do
w = word(substr(li, 2), 1)
call jWrite out, '[[#'w']] {$:abc}'
call jWrite out, '|||' substr(li, 2)
inTxt=1
iterate
end
if \ inTxt then do
call jWrite out, li
iterate
end
if \ (abbrev(li, '->') | abbrev(li, '#') ,
| abbrev(li, '[')) then do
call jWrite out, '-<' li
iterate
end
cx = 1
if substr(li, cx, 2) == '->' then
cx = verify(li, ' ', 'n', cx+2)
hasCross = substr(li, cx, 1) == '#'
if hasCross then
cx = verify(li, ' ', 'n', cx+1)
ex = verify(li, ']:\, ', 'm', cx)
ex = ex - (substr(li, ex, 1) \== ']')
hasBr = substr(li, cx, 1) == '['
if \ hasBr then
w = substr(li, cx, ex+1-cx)
else if substr(li, ex, 1) == ']' then
w = substr(li, cx+1, ex-1-cx)
else
call err 'br not closed' substr(w, cx+1, ex-1-cx) 'in' lx li
hasPdf = right(w, 4) == '.pdf'
if hasPdf then
w = left(w, length(w)-4)
if verify(w, '#?', 'm') > 0 then do
w = translate(w, '__', '#?')
say '*** changing to' w 'in' lx li
end
o = '-< {def+'w'}'
o = '-< [['w']]'
k = translate(w)
if k.k == 1 then
say '*** doppelter key' k 'in:' lx left(li,80)
k.k = 1
dT = ''
if mapHasKey(docs, k) then do
parse value mapGet(docs, k) with dT dC dN
call mapPut docs, k, dT (dC+1) dN
do tx=1 to length(dT)
t1 = substr(dT, tx, 1)
o = o '[[Lit'translate(t1)':'word(dN, tx) '|' t1 ']]'
end
end
qSeq = 'nd'
qq = left(qSeq, 1)
qx = 0
do forever
qx = pos('@'qq, li, qx+1)
if qx < 1 then do
qq = substr(qSeq, 1 + pos(qq, qSeq), 1)
qx=0
if qq = '' then
leave
else
iterate
end
if pos(qq, dT) < 1 then do
say '*** @'qq 'document not found:' lx li
iterate
end
do qb = qx-1 by -1 while substr(li, qb, 1) == ' '
end
do qe = qx+2 by 1 while substr(li, qe, 1) == ' '
end
if substr(li, qb, 1) == '.' & substr(li, qe, 1) == '.' then
li = left(li, qb)substr(li, qe+1)
else
li = left(li, qb) substr(li, qe)
end
o = o':' strip(substr(li, ex+1+(substr(li,ex+1,1)==':')))
if 0 then say left(li, 30) '==>' left(o, 30)
call jWrite out, o
end
dk = mapKeys(docs)
do dx=1 to m.dk.0
parse value mapGet(docs, m.dk.dx) with dT dC dN
if dC < 1 then
say '*** document not used:' dT dC dn
end
call jClose in
call jClose out
return
endProcedure tstWiki
addFiles: procedure expose m.
parse arg m, ty, file
fl = jOpen(fileList(file(file)), '<')
do while jRead(fl)
nm = substr(m.fl, lastPos('/', m.fl)+1)
k = translate(left(nm, pos('.', nm)-1))
if \ mapHasKey(m, k) then do
call mapAdd m, k, ty 0 nm
end
else do
parse value mapGet(m, k) with dT dC dN
call mapPut m, k, dT || ty 0 dN nm
end
end
call jClose fl
return
endProcedure addFiles
tstAll: procedure expose m.
say 'tstAll ws2 25.2.13...............'
call tstBase
call tstComp
call tstDiv
if m.err.os = 'TSO' then do
call tstZos
call tstTut0
end
return 0
endProcedure tstAll
/****** tstZos ********************************************************/
tstZOs:
call tstTime
call tstTime2Tst
call tstII
call sqlIni
call tstSqlRx
call tstSql
if m.tst_csm \== 0 then
call tstSqlCsm
call scanReadIni
call tstSqlC
call tstSqlCsv
call tstSqlRxUpd
call tstSqlUpd
call tstSqlUpdPre
call tstSqlE
call tstSqlB
call tstSqlO1
call tstSqlO2
call tstSqlStmt
call tstSqlStmts
call tstSqlUpdComLoop
call tstSqls1
call tstSqlO
call tstSqlFTab
call tstSqlFTab2
call tstSqlFTab3
call tstSqlFTab4
call tstsql4obj
call tstTotal
return
endProcedure tstZOs
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
tstLmdTiming:
parse arg lev
say timing() lev
call lmdBegin abc, lev
c = 0
do while lmdNext(abc, st.)
c = c + st.0
end
call lmdEnd abc
say timing() lev 'with group - without reading' c
call adrIsp 'lmdinit listid(lmdId) level('lev')'
do c=0 while adrIsp('lmdlist listid(&lmdId) dataset(abc)', 8) = 0
end
call adrIsp 'lmdfree listid(&lmdId)'
say timing() lev 'with list' c
return
endProcedure lmdTiming
tstCsi: procedure expose m.
if 0 then do
call lmd 'A540769.*K'
call tstCsiCla 'A540769.WK.REXX'
call tstCsiCla 'A540769.AAA.DATASETS'
call tstCsiCla 'A540769.RRR.DATASETS'
end
if 0 then do
call tstCsiOpNx 'A540769.WK.*E*'
call tstCsiOpNx 'A540769.AAA.DATASETS'
call tstCsiOpNx 'A540769.RRR.DATASETS'
end
if 1 then do
call tstCsiNxCl 'A540769.WK.**'
call tstCsiNxCl 'DBTF.M*.**'
call tstCsiNxCl 'DBTF.BE*.**'
end
return
tstCsi: procedure expose m.
/* call lmd 'A540769.*K' */
call tstCsi1 'A540769.WK.REXX'
call tstCsi1 'A540769.AAA.DATASETS'
call tstCsi1 'A540769.RRR.DATASETS'
return
tstCsiCla:
parse arg ds
say ds '-->' csiCla(ds)
return
tstCsiOpNx: procedure expose m.
parse arg ds
m = 'NUE123'
s = 'res89'
flds = 'devtyp volser mgmtclas comudsiz NOBYTTRK UDATASIZ HARBA'
say 'csiOpen' ds
call csiOpen m, ds, flds
do while csiNext(m, s)
say m.s 'dev' c2x(m.s.devTyp) ,
'vol' m.s.volSer 'cla' m.s.mgmtclas,
'comuDsiz' m.s.comuDsiz 'noBytTrk' m.s.noBytTrk,
'udatasiz' c2x(m.s.udatasiz) ,
'harba' c2x(m.s.harba)
end
return
tstCsiNxCl: procedure expose m.
parse arg ds
m = 'ABC123'
s = 'efg89'
flds = 'devtyp volser mgmtclas'
say 'csiOpen' ds
call csiOpen m, ds, flds
say timing() 'begin'
do i=1 while csiNext(m, s)
nn = csiArcTape(m.s.volser, m.s.mgmtClas, m.s.devtyp, m.s)
/* oo = csiCla(strip(m.s))
if oo <> nn then
say nn '<>' oo m.s
*/ if i // 1000 = 0 then
say timing() i nn m.s
end
say timing() (i-1) nn m.s
return
endProcedure tstCsiNxCl
listCatClass: procedure expose m.
parse upper arg dsn
rt = adrTso("listcat volume entry('"dsn"')", 4)
/* say 'listct rc =' rt 'lines' m.tso_trap.0 */
cl = ''
vo = ''
if word(m.tso_trap.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
else if pos('NOT FOUND', m.tso_trap.1) > 0 then
return 'notFound'
else if word(m.tso_trap.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' m.tso_trap.1
do tx=2 to m.tso_trap.0 while vo = '' ,
& left(m.tso_trap.tx, 1) = ' '
/* say m.tso_trap.tx */
p = pos('MANAGEMENTCLASS-', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+16), 1), 'l', '-')
p = pos('VOLSER--', m.tso_trap.tx)
if p > 0 then
vo = strip(word(substr(m.tso_trap.tx, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', m.tso_trap.tx)
dt = strip(word(substr(m.tso_trap.tx, p+8), 1), 'l', '-')
end
/* say 'lc' cl 'vo' vo 'dt' dt 'dsn' dsn */
if vo = '' then
call out '??? err no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl = '' then
res = 'tape'
else
res = cl
if abbrev(res, 'ar') \= abbrev(dt, "X'0") ,
| abbrev(res, 'ta') \= abbrev(dt, "X'7") ,
| (left(res, 1) >= 'A') \= abbrev(dt, "X'3") then
call out 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
tstMbrList: procedure expose m.
/*
$=/tstMbrList/
### start tst tstMbrList ##########################################
*** err: adrTso rc= 8 stmt=LISTDS 'A540769.TMP.TST.MBRLIST' MEMBERS+
. .
. e 1: A540769.TMP.TST.MBRLIST
. e 2: IKJ58503I DATA SET 'A540769.TMP.TST.MBRLIST' NOT IN CATAL+
OG
#noPds: 0 mbrs in A540769.TMP.TST.MBRLIST
#1: 1 mbrs in A540769.TMP.TST.MBRLIST
1 EINS
#0: 0 mbrs in A540769.TMP.TST.MBRLIST
#4: 4 mbrs in A540769.TMP.TST.MBRLIST
1 DREI
2 FUENF
3 VIER
4 ZWEI
#*IE*: 3 mbrs in A540769.TMP.TST.MBRLIST( *IE* )
1 IE
2 NNNIE
3 VIER
#*_IE*: 2 mbrs in A540769.TMP.TST.MBRLIST( *?IE* )
1 NNNIE
2 VIER
$/tstMbrList/
*/
call tst t, 'tstMbrList'
/* call tstMbrList1 "RZ2/A540769.WK.REXX(*DA?*)" */
pds = tstFileName('MbrList', 'r')
da.1 = '2ine eins'
call tstMbrList1 pds, '#noPds'
call writeDsn pds'(eins) ::f', da., 1
call tstMbrList1 pds, '#1'
call adrTso "delete '"pds"(eins)'"
call tstMbrList1 pds, '#0'
call writeDsn pds'(zwei) ::f', da., 1
call writeDsn pds'(drei) ::f', da., 1
call writeDsn pds'(vier) ::f', da., 1
call writeDsn pds'(fuenf) ::f', da., 1
call tstMbrList1 pds, '#4'
call writeDsn pds'(ie) ::f', da., 1
call writeDsn pds'(nnnie) ::f', da., 1
call tstMbrList1 pds"( *IE* )", '#*IE*'
call tstMbrList1 pds"( *?IE* )", '#*_IE*'
call adrTso "delete '"pds"'"
call tstEnd t
return
endProcedure tstMbrList
tstMbrList1: procedure expose m.
parse arg pds, txt
call tstOut t, txt':' mbrList(tstMbrList, pds) 'mbrs in' pds
do mx=1 to m.tstMbrList.0
call tstOut t, mx m.tstMbrList.mx
end
return
endProdecure tstMbrList1
/****** tstDiv ********************************************************/
tstDiv:
call tstSort
call tstMat
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSort: procedure expose m.
call tstSortComp
call tstSortComp '<<='
call tstSortComp 'm.aLe <<= m.aRi'
call tstSortComp 'if 1 then cmp = m.aLe <<= m.aRi; else call err sd'
return
endProcedure tstSort
tstSortComp: procedure expose m.
parse arg cmp
/*
$=/tstSort/
### start tst tstSort #############################################
sort 29 c ACHT DREI DREIZEHN EINS ELF FUENF M.I.25 M.I.26 M.I.27 M+
..I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI ZWOELF 0 1 1 1 2 2+
. 3 3 4 4
sort 22 c ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27 M.I.29 NEUN VIERZ+
EHN ZEHN ZWOELF 0 1 1 1 2 2 3 3 4 4
sort 15 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1 1 2 2 3 3 4 4
sort 8 c M.I.25 M.I.26 M.I.27 M.I.29 0 1 1
sort 1 M.I.29
sortWords(also als a 05 4 1e2, cmp) a als also 05 1e2 4
sortWords(also als a 05 4, cmp) a als also 05 4
sortWords(also als a 05, cmp) a als also 05
sortWords(also als a, cmp) a als also
sortWords(also als, cmp) als also
sortWords(also, cmp) also
sortWords(, cmp) .
sortWords(also als a 05 4 1e2, <) a als also 4 05 1e2
sortWords(also als a 05 4 1e2, >) 1e2 05 4 also als a
$/tstSort/ */
/*
$=/tstSortAscii/
### start tst tstSortAscii ########################################
sort 29 0 1 1 1 2 2 3 3 4 4 ACHT DREI DREIZEHN EINS ELF FUENF M.I.+
25 M.I.26 M.I.27 M.I.29 NEUN SECHS SIEBEN VIER VIERZEHN ZEHN ZWEI Z+
WOELF c
sort 22 0 1 1 1 2 2 3 3 4 4 ACHT DREIZEHN ELF M.I.25 M.I.26 M.I.27+
. M.I.29 NEUN VIERZEHN ZEHN ZWOELF c
sort 15 0 1 1 1 2 2 3 3 4 4 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 8 0 1 1 M.I.25 M.I.26 M.I.27 M.I.29 c
sort 1 M.I.29
$/tstSortAscii/ */
say '### start with comparator' cmp '###'
if m.err.os == 'LINUX' then
call tst t, "tstSortAscii"
else
call tst t, "tstSort"
call mAdd mCut(i, 0), eins, zwei, drei, vier, fuenf, sechs,
,sieben, acht, neun, zehn, elf, zwoelf, dreizehn, vierzehn
call mAdd i, 1, 2, 3, 4, 4, 3, 2, 1, 0, 1,
, 'M.I.25', 'M.I.26', 'M.I.27', 'c', 'M.I.29'
do yy = m.i.0 by -1 to 1
do x = 0 to yy
m.i.0 = x
call sort i, o, cmp
m = ''
la = ''
if x <> m.o.0 then
call err 'size mismatch' x '<>' m.o.0
do y=1 to m.o.0
m = m m.o.y
if \ (la << m.o.y) then
call err 'sort mismatch' yy x y '\' la '<<' m.o.y
end
end
if yy // 7 = 1 then
call tstOut t, 'sort' yy m
do x = 2 to yy
x1 = x-1
m.i.x1 = m.i.x
end
end
wi = 'also als a 05 4 1e2'
do l=words(wi) by -1 to 0
call tstOut t, 'sortWords('subWord(wi, 1, l)', cmp)' ,
sortWords(subWord(wi, 1, l), cmp)
end
call tstOut t, 'sortWords('wi', <)' sortWords(wi, '<')
call tstOut t, 'sortWords('wi', >)' sortWords(wi, '>')
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
/*
$=/tstMatch/
### start tst tstMatch ############################################
match(eins, e?n*) 1 1 2,i,s trans(E?N*) EiNs
match(eins, eins) 1 1 0 trans(EINS) EINS
match(e1nss, e?n*) 1 1 2,1,ss trans(?*) 1ss
match(eiinss, e?n*) 0 0 -9 trans(E?N*) .
match(einss, e?n *) 0 0 -9 trans(E?N *) .
match(ein s, e?n *) 1 1 2,i,s trans(E?N *) EiN s
match(ein abss , ?i*b*) 1 1 3,e,n a,ss trans(?I*B*) eIn aBss .
match(ein abss wie gehtsssxdirx und auch , ) 0 0 -9 trans() .
match(ies000, *000) 1 1 1,ies trans(*000) ies000
match(xx0x0000, *000) 1 1 1,xx0x0 trans(*000) xx0x0000
match(000x00000xx, 000*) 1 1 1,x00000xx trans(000*) 000x00000xx
match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef
match(abcdef, *abcdef*) 1 1 2,, trans(*ABCDEF*) ABCDEF
match(abcdef, **abcdef***) 1 1 5,,,,, trans(**ABCDEF***) ABCDEF
match(abcdef, *cd*) 1 1 2,ab,ef trans(*CD*) abCDef
match(abcdef, *abc*def*) 1 1 3,,, trans(*ABC*DEF*) ABCDEF
match(abcdef, *bc*e*) 1 1 3,a,d,f trans(*BC*E*) aBCdEf
match(abcdef, **bc**ef**) 1 1 6,a,,d,,, trans(**BC**EF**) aBCdEF
$/tstMatch/
*/
call tst t, "tstMatch"
call tstOut t, tstMatch1('eins', 'e?n*' )
call tstOut t, tstMatch1('eins', 'eins' )
call tstOut t, tstMatch1('e1nss', 'e?n*', '?*' )
call tstOut t, tstMatch1('eiinss', 'e?n*' )
call tstOut t, tstMatch1('einss', 'e?n *' )
call tstOut t, tstMatch1('ein s', 'e?n *' )
call tstOut t, tstMatch1('ein abss ', '?i*b*' )
call tstOut t, tstMatch1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, tstMatch1('ies000', '*000' )
call tstOut t, tstMatch1('xx0x0000', '*000' )
call tstOut t, tstMatch1('000x00000xx', '000*' )
call tstOut t, tstMatch1('000xx', '*0*', 'ab*cd*ef' )
call tstOut t, tstMatch1('abcdef', '*abcdef*' )
call tstOut t, tstMatch1('abcdef', '**abcdef***' )
call tstOut t, tstMatch1('abcdef', '*cd*' )
call tstOut t, tstMatch1('abcdef', '*abc*def*' )
call tstOut t, tstMatch1('abcdef', '*bc*e*' )
call tstOut t, tstMatch1('abcdef', '**bc**ef**' )
call tstEnd t
return
tstMatch1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) matchVars(w, m, vv) m.vv.0
do x=1 to m.vv.0
r = r','m.vv.x
end
if m2 = '' then
m2 = translate(m)
r = r 'trans('m2')' matchRep(w, m, m2)
return r
endProcedure tstMatch1
tstIntRdr: procedure expose m.
i.1 = "//A540769J JOB (CP00,KE50),'DB2 REO',"
i.2 = "// MSGCLASS=T,TIME=1440,"
i.3 = "// NOTIFY=&SYSUID,REGION=0M,SCHENV=DB2"
i.4 = "//*MAIN CLASS=LOG"
i.5 = "//S1 EXEC PGM=IEFBR14"
call writeDsn 'RR2/intRdr', i., 5, 1
return
endProcedure tstIntRdr
tstII: procedure expose m.
/*
$=/tstII/
### start tst tstII ###############################################
iiDs(org) ORG.U0009.B0106.KLEM43
iiDs(db2) DSN.DB2
iiRz2C(RZ2) 2
*** err: no key=R?Y in II_RZ2C
iiRz2C(R?Y) 0
iiRz2C(RZY) Y
iiDbSys2C(de0G) E
*** err: no key=D??? in II_DB2C
iiDbSys2C(d???) 0
iiDbSys2C(DBOF) F
iiSys2RZ(S27) RZ2
iiMbr2DbSys(DBP5) DVBP
ii_rz RZX RZY RZZ RQ2 RR2 RZ2 RZ4
ii_rz2db.rzx DE0G DEVG DX0G DPXG
rr2/dvbp RR2 R p=R d=RZ2, db DVBP P 1
iiixVPut 1: RZ2 2 p=B d=RZ2, db DBOF F 0
iiixVPut 1: RZ2 2 p=B d=RZ2, db DVBP P 1
iiixVPut 1: RZ2 2 p=B d=RZ2, db DP2G Q 0
*** err: no key=M6R in II_MBR2DB
errHan======= mbr2DbSys(m6r?) 0
errHandlerPush Mbr2DbSys(m7r?) ?no?dbSys?
*** err: no key=M8R in II_MBR2DB
errHandlerPop Mbr2DbSys(m8r?) 0
$/tstII/
*/
call tst t, 'tstII'
call tstOut t, 'iiDs(org) ' iiDs('oRg')
call tstOut t, 'iiDs(db2) ' iiDs(db2)
call tstOut t, 'iiRz2C(RZ2) ' iiRz2C(RZ2)
call tstOut t, 'iiRz2C(R?Y) ' iiRz2C(R?Y)
call tstOut t, 'iiRz2C(RZY) ' iiRz2C(RZY)
call tstOut t, 'iiDbSys2C(de0G) ' iiDbSys2C('de0G')
call tstOut t, 'iiDbSys2C(d???) ' iiDbSys2C('d???')
call tstOut t, 'iiDbSys2C(DBOF) ' iiDbSys2C('DBOF')
call tstOut t, 'iiSys2RZ(S27) ' iiSys2RZ(S27)
call tstOut t, 'iiMbr2DbSys(DBP5)' iiMbr2DbSys(DBP5)
call tstOut t, 'ii_rz ' m.ii_rz
call tstOut t, 'ii_rz2db.rzx ' m.ii_rz2db.rzx
call pipeIni
call iiVPut 'rr2/ DvBp '
call tstOut t, 'rr2/dvbp ' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
w1 = wordPos('RZ2/DBOF', m.ii_rzDb)
do wx=w1 to w1+2
call tstOut t, 'iiixVPut' iiIxVPut(wx)':' ,
vGet('rz') vget('rzC') 'p='vget('rzP') 'd='vget('rzD'),
|| ', db' vGet('dbSys') vGet('dbSysC') vGet('dbSysElar')
end
call tstOut t, "errHan======= mbr2DbSys(m6r?)" iiMbr2DbSys('m6r?')
call errHandlerPushRet "?no?dbSys?"
call tstOut t, "errHandlerPush Mbr2DbSys(m7r?)" iiMbr2DbSys('m7r?')
call errHandlerPop
call tstOut t, "errHandlerPop Mbr2DbSys(m8r?)" iiMbr2DbSys('m8r?')
call tstEnd t
return
endProcedure tstII
tstTime2tst: procedure expose m.
/*
$=/tstTime2tst/
### start tst tstTime2tst #########################################
2015-05-13-23.45.57.987654 ==> 735730.99025448673611 ==> 2015-05-13+
-23.45.57.987654 1
1956-04-01-23.59.59.999999 ==> 714139.99999999998843 ==> 1956-04-01+
-23.59.59.999999 1
2016-02-29-12.34.56.789087 ==> 736022.52426839221065 ==> 2016-02-29+
-12.34.56.789087 1
1567-08-23-19.59.59.999999 ==> 572203.83333333332176 ==> 1567-08-23+
-19.59.59.999999 1
$/tstTime2tst/
*/
call tst t, 'tstTime2tst'
l = '2015-05-13-23.45.57.987654 1956-04-01-23.59.59.999999' ,
'2016-02-29-12.34.56.789087 1567-08-23-19.59.59.999999'
do lx=1 to 4
v = word(l, lx)
w = timeDays2tst(timestamp2days(v))
call tstOut t, v '==>' timestamp2days(v) '==>' w (v = w)
end
call tstEnd t
return
endProcedure tstTime2tst
tstTime: procedure
/* Winterzeit dez 2011
$=/tstTime/
### start tst tstTime #############################################
05-28-00.00 2days 735745
05-28-04.00 2days 735745.16666666666667
05-28-21.00 2days 735745.9
05-29-00.00 2days 735746
16-05-28-00 2days 736111
16...12 - 15...06 366.25000000000000
2016-05-28-12.23.45 .
2016-05-28-12-23.45 bad timestamp 2016-05-28-12-23
2016.05-28-12.23.45 bad timestamp 2016.05-28-12.23
2016-05-28-12.23.45.987654 .
2016-0b-28-12.23.45 bad timestamp 2016-0b-28-12.23
2016-05-28-12.23.45.9876543 bad timestamp 2016-05-28-12.23
2016-05-28-12.23.45.98-654 bad timestamp 2016-05-28-12.23
2016-00-28-12.23.45 bad month in timestamp 2016-00
2016-05-28-13.23.45 .
2016-15-28-12.23.45 bad month in timestamp 2016-15
2016-05-31-12.23.45 .
2016-04-31-13.23.45 bad day in timestamp 2016-04-3
2015-04-30-12.23.45 .
2016-02-30-12.23.45 bad day in timestamp 2016-02-3
2016-02-29-13.23.45 .
2015-02-29-12.23.45 bad day in timestamp 2015-02-2
2016-07-30-25.00.00 bad hour in timestamp 2016-07-
2016-04-07-24.00.00.0 .
2015-02-19-24.00.01 bad hour in timestamp 2015-02-
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
Achtung: output haengt von Winter/SommerZ & LeapSecs ab
stckUnit = 0.000000000244140625
timeLeap = 00000018CBA80000 = 106496000000 = 26.000 secs
timeZone = 00000D693A400000 = 14745600000000 = 3600.000 secs
timeUQZero = 207090001374976
timeUQDigis = 35 digits ABCDEFGHIJKLMNOPQRSTUVWXYZ012345678
2jul(2011-03-31-14.35.01.234567) 11090
Lrsn2TAI10(00C5E963363741000000) 2010-05-01-10.35.20.789008
Lrsn2Lzt(00C5E963363741000000) 2010-05-01-11.34.54.789008
TAI102Lrsn(2011-03-31-14.35.01.234567) 00C78D87B86E38700000
lzt2Lrsn(2011-03-31-14.35.01.234567) 00C78D7A67FFA0700000
Lrsn2TAI10(TAI102Lrsn(2011-03-31-14.35.01.234567) +
2011-03-31-14.35.01.234567
TAI102Lrsn(Lrsn2TAI10(00C5E963363741000000) 00C5E963363741000000
Lrsn2LZt(LZt2Lrsn(2011-03-31-14.35.01.234567) 2011-03-31-14.35.01.2+
34567
LZt2Stc(Lrsn2LZt(00C5E963363741000000) 00C5E963363741000000
Lrsn2uniq(00C5E963363741000000) CTNR6S7T back 00C5E963363740000000
Lrsn2LZt(LZt2Lrsn(2051-10-31-14.35.01.234567) 2051-10-31-14.35.01+
..234567
Lrsn2TAI10(01010000000000000000) 2043-04-09-14.36.53.414912
$/tstTime/
*/
call jIni
call tst t, 'tstTime'
call out '05-28-00.00 2days ' timestamp2days('2015-05-28-00.00.00')
call out '05-28-04.00 2days ' timestamp2days('2015-05-28-04.00.00')
call out '05-28-21.00 2days ' timestamp2days('2015-05-28-21.36.00')
call out '05-29-00.00 2days ' timestamp2days('2015-05-29-00.00.00')
call out '16-05-28-00 2days ' timestamp2days('2016-05-28-00.00.00')
call out '16...12 - 15...06 ' timestampDiff( '2016-05-28-12.23.45',
, '2015-05-28-06.23.45')
l = '2016-05-28-12.23.45 2016-05-28-12-23.45 2016.05-28-12.23.45',
'2016-05-28-12.23.45.987654 2016-0b-28-12.23.45' ,
'2016-05-28-12.23.45.9876543 2016-05-28-12.23.45.98-654' ,
'2016-00-28-12.23.45 2016-05-28-13.23.45 2016-15-28-12.23.45',
'2016-05-31-12.23.45 2016-04-31-13.23.45 2015-04-30-12.23.45',
'2016-02-30-12.23.45 2016-02-29-13.23.45 2015-02-29-12.23.45',
'2016-07-30-25.00.00 2016-04-07-24.00.00.0 2015-02-19-24.00.01'
do lx=1 to words(l)
call out left(word(l, lx), 30),
strip(left(timestampCheck(word(l, lx)), 30), 't')
end
t1 = '2011-03-31-14.35.01.234567'
t2 = '2051-10-31-14.35.01.234567'
s1 = timeLrsnExp('C5E963363741')
s2 = timeLrsnExp('0101')
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'Achtung: output haengt von Winter/SommerZ & LeapSecs ab'
numeric digits 15
call out 'stckUnit =' m.time_StckUnit
call out 'timeLeap =' d2x(m.time_Leap,16) '=' m.time_Leap ,
'=' format(m.time_Leap * m.time_StckUnit,9,3) 'secs'
call out 'timeZone =' d2x(m.time_Zone,16) '=' m.time_Zone,
'=' format(m.time_Zone * m.time_StckUnit,6,3) 'secs'
/* call out "cvtext2_adr =" d2x(cvtExt2A, 8) */
call out 'timeUQZero =' m.time_UQZero
call out 'timeUQDigis =' ,
length(m.time_UQDigits) 'digits' m.time_UQDigits
call out '2jul('t1') ' time2jul(t1)
call out 'Lrsn2TAI10('s1')' timelrsn2TAI10(s1)
call out 'Lrsn2Lzt('s1')' timeLrsn2Lzt(s1)
call out 'TAI102Lrsn('t1')' timeTAI102Lrsn(t1)
call out 'lzt2Lrsn('t1')' timeLzt2Lrsn(t1)
call out 'Lrsn2TAI10(TAI102Lrsn('t1')' ,
timeLrsn2TAI10(timeTAI102Lrsn(t1))
call out 'TAI102Lrsn(Lrsn2TAI10('s1')' ,
timeTAI102Lrsn(timelrsn2TAI10(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t1')' timeLrsn2LZt(timeLZt2Lrsn(t1))
call out 'LZt2Stc(Lrsn2LZt('s1')' timeLZt2Lrsn(timeLrsn2LZt(s1))
call out 'Lrsn2uniq('s1')' timeLrsn2Uniq(s1) ,
'back' timeUniq2Lrsn(timeLrsn2Uniq(s1))
call out 'Lrsn2LZt(LZt2Lrsn('t2')' timeLrsn2LZt(timeLZt2Lrsn(t2))
call out 'Lrsn2TAI10('s2')' timelrsn2TAI10(s2)
call tstEnd t
return
endProcedure tstTime
tstMat: procedure expose m.
/*
$=/tstMat/
### start tst tstMat ##############################################
. 0 sqrt 0 isPrime 0 nxPrime 3 permut 1 > 1 2 3 4 5
. 1 sqrt 1 isPrime 0 nxPrime 3 permut 2 > 2 1 3 4 5
. 2 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 1 3 2 4 5
. 3 sqrt 1 isPrime 1 nxPrime 3 permut 3 > 2 3 1 4 5
. 4 sqrt 2 isPrime 0 nxPrime 5 permut 3 > 3 2 1 4 5
. 5 sqrt 2 isPrime 1 nxPrime 5 permut 3 > 3 1 2 4 5
. 6 sqrt 2 isPrime 0 nxPrime 7 permut 4 > 1 2 4 3 5
. 7 sqrt 2 isPrime 1 nxPrime 7 permut 4 > 2 1 4 3 5
. 8 sqrt 2 isPrime 0 nxPrime 11 permut 4 > 1 3 4 2 5
. 9 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 2 3 4 1 5
. 10 sqrt 3 isPrime 0 nxPrime 11 permut 4 > 3 2 4 1 5
. 11 sqrt 3 isPrime 1 nxPrime 11 permut 4 > 3 1 4 2 5
. 12 sqrt 3 isPrime 0 nxPrime 13 permut 4 > 1 4 3 2 5
. 13 sqrt 3 isPrime 1 nxPrime 13 permut 4 > 2 4 3 1 5
. 14 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 1 4 2 3 5
. 15 sqrt 3 isPrime 0 nxPrime 17 permut 4 > 2 4 1 3 5
. 16 sqrt 4 isPrime 0 nxPrime 17 permut 4 > 3 4 1 2 5
. 17 sqrt 4 isPrime 1 nxPrime 17 permut 4 > 3 4 2 1 5
. 18 sqrt 4 isPrime 0 nxPrime 19 permut 4 > 4 2 3 1 5
$/tstMat/
$/tstMat/
*/
call tst t, 'tstMat'
q = 'tst_Mat'
do qx=1 to 20
m.q.qx = qx
end
do i=0 to 18
call permut q, i
call tstOut t, right(i,4) 'sqrt' right(sqrt(i), 2) ,
'isPrime' isPrime(i) 'nxPrime' right(nxPrime(i), 4) ,
'permut' m.q.0 '>' m.q.1 m.q.2 m.q.3 m.q.4 m.q.5
end
call tstEnd t
return
endProcedure tstMat
/****** tstSql ********************************************************/
tstSqlUtils: procedure expose m.
call sqlConnect 'DBAF'
id = 'A540769.dsnUtils'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "TEMPLATE TCOPYD",
"DSN('&SSID..&JO..&US..P&PART(2)..D&DATE(3)..T&TIME.')",
"DATACLAS(NULL12) MGMTCLAS(COM#A011) STORCLAS(FAR$N)",
"SPACE (150,3750) TRK UNCNT 59;",
"listdef abc include tablespace DA540769.A002* partlevel;",
"listdef mf include tablespace MF01A1A.A110A partlevel;",
"copy list abc copyddn(tcopyd) shrlevel change;"
st = translate(st)
call sqlExec "call SYSPROC.DSNUTILS ( :id, :rst,",
":st,:retcode, :ANY" copies(',:e,:e,:z',12) ")"
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.DSNUTILS'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
exit
endProcedure tstSqlUtils
tstSqlStored: procedure expose m.
call sqlConnect 'DBAF'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "abc"
call sqlExec "call SYSPROC.COMMAND ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE SYSPROC.COMMAND'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStored
tstSqlStoredWK: procedure expose m.
call sqlConnect 'DBAF'
/* st = "direct wkUtiSub"
rst = 'NO'
say 'before call st='st 'rst='rst
call sqlExec "call A540769.WKUTILSUB ( :st, :rst)"
say 'after call st='st 'rst='rst
*/ rst = 'NO'
retcode = -9876
e = ''
z = 0
prc = 'DB2UTIL.DB2UTIL'
st = "DA540769.A2*" /* DA540769.A1*" */
say "call" prc "("st", ...)"
call sqlExec "call" prc "(:st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE' prc
/* say 'results' results */
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say ''
say '***** utility output'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say '***** end output'
call sqlDisconnect
return 0
endProcedure tstSqlStoredWK
tstSqlStoredSQL1: procedure expose m.
call sqlConnect 'DBIA'
rst = 'NO'
retcode = -9876
e = ''
z = 0
st = "DA540769.A2* DA540769.A1*"
call sqlExec "call A540769.WKSQL1 ( :st, :rst)"
say 'after call st='st 'rst='rst
call sqlExec ,
'ASSOCIATE LOCATOR (:RESULTS) WITH PROCEDURE A540769.WKUTIL'
say 'results' results
call sqlExec 'ALLOCATE C111 CURSOR FOR RESULT SET :RESULTS'
say 'allocated c111'
do while sqlExec('fetch c111 into :seq, :txt', 0 100) = 0
say 'sysPrint' seq strip(txt, 't')
end
call sqlExec 'close c111'
say 'closed'
call sqlDisconnect
return
endProcedure tstSqlStoredSQL1
tstSqlTriggerTiming:
parse upper arg tb ni
m.noInsert = ni == 0
cnt = 200000
if tb = '' then
TB = 'GDB9998.TWK511TRI'
call sqlConnect dbaf
say timing() 'noInsert' m.noInsert 'tb' tb
call sql2St 'select max(pri) MX from' tb, cc
if m.cc.1.mx == m.sqlNull then
m.cc.1.mx = 0
von = m.cc.1.mx + 1
bis = m.cc.1.mx + cnt
say m.cc.0 'max' m.cc.1.mx 'von' von 'bis' bis 'count' cnt tb
if right(tb, 2) = 'A1' then do
call sqlPrepare 3, 'insert into' tb '(pri, short, long, par)' ,
'values (?, ?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
else do
call sqlPrepare 3, 'insert into' tb '(pri, short, long)' ,
'values (?, ?, ?)'
do ax=von to bis
call sqlExecute 3, ax,
, ax 'wsh short', ax 'wsh long long long long long ',
, (ax-1) // 1000 + 1
end
end
/* call sqlLn 5,,, 'select * from' tb 'where pri >=' von */
call sqlCommit
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSqlRx: procedure expose m.
/*
$=/tstSqlRx/
### start tst tstSqlRx ############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSqlRx/ */
call jIni
call tst t, "tstSqlRx"
call sqlRxConnect
cx = 7
call sqlRxQuery cx, 'select * from sysdummy'
call sqlRxQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlRxFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlRxClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlRxQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlRxFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlRxClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlRxQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlRxFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlRxClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlRxFetch(cx) m.nm
call out 'fetchBT' sqlRxFetch(cx) m.nm
call sqlRxClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlRxFetch(cx) m.nm
call out 'fetchBi' sqlRxFetch(cx) m.nm
call tstEnd t
call sqlRxDisconnect
return
endProcedure tstSqlRx
tstSql: procedure expose m.
/*
$=/tstSql/
### start tst tstSql ##############################################
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s7 into :M.SQL.7.D from :src
. e 3: with into :M.SQL.7.D = M.SQL.7.D
fetchA 1 ab=m.abcdef.123.AB=abc ef=efg
fetchA 0 ab=m.abcdef.123.AB=abc ef=efg
fetchB 1 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchB 0 ab=a cd=2 ef=--- ind=-1 gh=d ind=0
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
sql2St 1 st.0=1
sql2St:1 a=a b=2 c=--- d=d
sql2One a
sql2One a=a b=2 c=--- d=d
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBi 1 SYSINDEXES
fetchBi 0 SYSINDEXES
$/tstSql/ */
call jIni
call tst t, "tstSql"
call sqlConnect
cx = 7
call sqlQuery cx, 'select * from sysdummy'
call sqlQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
call sqlClose cx
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
call sqlClose cx
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
call sqlClose cx
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call out 'sql2St' sql2St(sql, st) 'st.0='m.st.0
do i=1 to m.st.0
call out 'sql2St:'i ,
'a='m.st.i.a 'b='m.st.i.b 'c='m.st.i.c 'd='m.st.i.d
end
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call out 'sql2One' sql2One(sql, st)
call out 'sql2One' ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
drop m.st.a m.st.b m.st.c m.st.d m.st.0
call sqlQueryPrepare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?",':m.nm'
call sqlQueryExecute cx, 'SYSTABLES'
call out 'fetchBT' sqlFetch(cx) m.nm
call out 'fetchBT' sqlFetch(cx) m.nm
call sqlClose cx
call sqlQueryExecute cx, 'SYSINDEXES'
call out 'fetchBi' sqlFetch(cx) m.nm
call out 'fetchBi' sqlFetch(cx) m.nm
call tstEnd t
call sqlDisconnect
return
endProcedure tstSql
tstSqlCsm: procedure expose m.
/*
$=/tstSqlCsm/
### start tst tstSqlCsm ###########################################
*** err: SQLCODE = -204: S100447.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: subsys = DE0G, host = RZZ
*** err: implement sqlCmsQuery fetchVars ? or : :m.dst.ab, :m.dst.ef
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchA 0 ab=m.abcdef.123.AB=M.abcdef.123.AB ef=M.abcdef.123.EF
fetchB 1 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchB 0 ab=a cd=2 ef=--- ind=M.abc.Def.123.EF.SQLIND gh=d ind=M.ab+
c.Def.123.GH.SQLIND
fetchC 1 a=a b=2 c=--- d=d
fetchC 0 a=a b=2 c=--- d=d
$/tstSqlCsm/ */
call pipeIni
call tst t, "tstSqlCsm"
call sqlConnect 'RZZ/DE0G'
cx = 7
call sqlCsmQuery cx, 'select * from sysdummy'
call sqlCsmQuery cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1', ':m.dst.ab, :m.dst.ef'
a = 'abcdef'
b = 123
drop m.a.b.ab m.a.b.ef
do i=1 to 2
call out 'fetchA' sqlCsmFetch(cx, a || '.' || b) ,
'ab=m.'a'.'||b'.'ab'='m.a.b.ab 'ef='m.a.b.ef
end
drop m.a.b.ab m.a.ab.ef a b c
sql = "select 'a' a, 2 b, case when 1=0 then 1 else null end c",
", case when 1=1 then 'd' else null end d",
"from sysibm.sysDummy1"
call sqlCsmQuery cx, sql, 'AB CD EF GH'
st = 'abc.Def.123'
drop m.st.ab m.st.cd m.st.ef m.st.ef.sqlInd m.st.gh m.st.gh.sqlInd
do i=1 to 2
call out 'fetchB' sqlCsmFetch(cx, st) ,
'ab='m.st.ab 'cd='m.st.cd 'ef='m.st.ef 'ind='m.st.ef.sqlInd,
'gh='m.st.gh 'ind='m.st.gh.sqlInd
end
drop m.st.ab m.st.bc m.st.df m.st.df.sqlInd
call sqlCsmQuery cx, sql
st = 'abc.Def.123'
drop m.st.a m.st.b m.st.c m.st.d
do i=1 to 2
call out 'fetchC' sqlCsmFetch(cx, st) ,
'a='m.st.a 'b='m.st.b 'c='m.st.c 'd='m.st.d
end
drop m.st.a m.st.b m.st.c m.st.d
drop m.st.1.a m.st.1.b m.st.1.c m.st.1.d m.st.0
call tstEnd t
call sqlDisconnect
return
endProcedure tstsqlCsm
tstSqlCSV: procedure expose m.
/*
$=/tstSqlCSV/
### start tst tstSqlCSV ###########################################
NAME,CREATOR,MITCOM,MITQUO,MITNU,COL6
SYSTABLES,SYSIBM ,"a,b","a""b",1,8
SYSTABLESPACE,SYSIBM ,"a,b","a""b",---,8
SYSTABLESPACESTATS,SYSIBM,"a,b","a""b",---,6
$/tstSqlCSV/ */
call csvIni
call scanReadIni
call sqlConnect
call tst t, "tstSqlCSV"
r = csvWrt(sqlRdr("select name, creator, 'a,b' mitCom",
", 'a""b' mitQuo" ,
", case when name='SYSTABLES' then 1 else null end mitNu" ,
",length(creator)" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"))
call pipeWriteAll r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlCsv
tstSqlB: procedure expose m.
/*
$=/tstSqlB/
### start tst tstSqlB #############################################
#jIn 1# select strip(name) "tb", strip(creator) cr
#jIn 2# , case when name = 'SYSTABLES' then 1 else null end
#jIn 3# from sysibm.sysTables
#jIn 4# where creator = 'SYSIBM' and name like 'SYSTABLES%'
#jIn 5# .
#jIn 6# order by name
#jIn 7# fetch first 3 rows only
#jIn eof 8#
dest1.fet: SYSTABLES SYSIBM 1
dest2.fet: SYSTABLESPACE SYSIBM ---
dest3.fet: SYSTABLESPACESTATS SYSIBM ---
$/tstSqlB/ */
call pipeIni
call tst t, "tstSqlB"
cx = 9
call sqlConnect
call jIni
call mAdd mCut(t'.IN', 0),
, 'select strip(name) "tb", strip(creator) cr' ,
, ", case when name = 'SYSTABLES' then 1 else null end" ,
, "from sysibm.sysTables" ,
, "where creator = 'SYSIBM' and name like 'SYSTABLES%'", ,
, "order by name",
, "fetch first 3 rows only"
call sqlQuery cx, in2Str(,' ')
do qx=1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.tb m.dst.cr m.dst.col3
drop m.dst.tb m.dst.cr m.dst.col3
end
call sqlClose cx
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlB
tstSqlFTab: procedure expose m.
/*
$=/tstSqlFTab/
### start tst tstSqlFTab ##########################################
UPDATESTATSTIME----------------NACTIVE------NPAGES-EXTENT-LOADRLAST+
TIME--------------REORGLASTTIME--------------REORGINSERT-REORGDELET+
E-REORGUPDATE-REORGUNCLUS-REORGDISORG-REORGMASSDE-REORGNEARIN-REORG+
FARIND-STATSLASTTIME--------------STATSINSERT-STATSDELETE-STATSUPDA+
TE-STATSMASSDE-COPYLASTTIME---------------COPYUPDATED-COPYCHANGES-C+
OPYUPDATE-COPYUPDATETIME-------------I---DBID---PSID-PARTIT-INSTAN-+
--SPACE-TOTALRO-DATASIZ-UNCOMPR-DBNAME-------NAME---------REORGCL-R+
EORGSC-REORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-----+
----------
--- modified
allg vorher others vorher
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
db-------ts---------part---inst-UPDATESTATSTIME----------------NACT+
IVE------NPAGES-EXTENT-LOADRLASTTIME--------------REORGLASTTIME----+
----------REORGINSERT-REORGDELETE-REORGUPDATE-REORGUNCLUS-REORGDISO+
RG-REORGMASSDE-REORGNEARIN-REORGFARIND-STATSLASTTIME--------------S+
TATSINSERT-STATSDELETE-STATSUPDATE-STATSMASSDE-COPYLASTTIME--------+
-------COPYUPDATED-COPYCHANGES-COPYUPDATE-COPYUPDATETIME-----------+
--I---DBID---PSID---SPACE-TOTALRO-DATASIZ-UNCOMPR-REORGCL-REORGSC-R+
EORGHA-HASHLASTUS-DRI-L-STATS01-UPDATES-LASTDATACHANGE-------------+
--
allg nachher others nachher
DBNAME INSTANCE +
. NPAGES REORGLASTTIME +
. REORGUPDATES +
. REORGMASSDELETE STATSLASTTIME +
. STATSUPDATES +
. COPYUPDATEDPAGES COPYUPDATETIME +
. PSID DATASIZE REO+
RGSCANACCESS DRIVETYPE UPDATESIZE
. NAME UPDATESTATSTIME +
. EXTENTS +
. REORGINSERTS REORGUNCLUSTINS +
. REORGNEARINDREF +
. STATSINSERTS STATSMASSDELETE +
. COPYCHANGES +
. IBMREQD SPACE UNCOMPRESSEDDATASI+
ZE REORGHASHACCESS LPFACILITY LASTDATACHANGE
. PARTITION NACTIVE+
. LOADRLASTTIME +
. REORGDELETES REORGD+
ISORGLOB REORGFARINDREF +
. STATSDELETES COPYLASTTIME +
. COPYUPDATELRSN +
. DBID TOTALROWS REORGCLUSTE+
RSENS HASHLASTUSED STATS01
$/tstSqlFTab/
*/
call pipeIni
call tst t, 'tstSqlFTab'
call sqlConnect
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 1, ,'-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabOthers abc
call sqlfTab abc
call sqlClose 17
call out '--- modified'
call sqlQuery 17, 'select * from sysibm.sysTablespaceStats' ,
"where dbName = 'xxxDB06' and name = 'SYSTSTAB'"
call sqlFTabOpts fTabReset(abc, 2 1, 1 3 'c', '-'), 17, 12
call sqlFTabDef abc, 492, '%7e'
call sqlFTabAdd abc, DBNAME, '%-8C', 'db', 'allg vorher' ,
, 'allg nachher'
call sqlFTabAdd abc, NAME , '%-8C', 'ts'
call sqlFTabAdd abc, PARTITION , , 'part'
call sqlFTabAdd abc, INSTANCE , , 'inst'
ox = m.abc.0 + 1
call sqlFTabOthers abc
call fTabAddTit abc, ox, 2, 'others vorher'
call fTabAddTit abc, ox, 3, 'others nachher'
call sqlFTab abc
call sqlClose 17
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab
tstSqlFTab2: procedure expose m.
/*
$=/tstSqlFTab2/
### start tst tstSqlFTab2 #########################################
Und Eins Oder
. zw aber
Und Eins---------------zw aber---
. und eins 22223
. und eins 22224
Und Eins---------------zw aber---
Und Eins Oder
. zw aber
a-------------b---
aaa 222
a-------------b---
--- row 1 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2223000e04 22223
--- row 2 ---------------------------------------------------------+
-------------
. Und Eins Oder und eins
. zw aber 2.2224000e04 22224
--- end of 2 rows -------------------------------------------------+
-------------
$/tstSqlFTab2/
*/
call pipeIni
call tst t, 'tstSqlFTab2'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', 22222 + row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
call sqlQuery 17, sq1
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
call sqlFTab sqlFTabOthers(sqlfTabReset(tstSqlFtab2, 17))
call sqlClose 17
call sqlQuery 15, sq1
call sqlFTabCol sqlFTabOthers(sqlfTabReset(tstSqlFtab5, 15))
call sqlClose 15
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab2
tstSqlFTab3: procedure expose m.
/*
$=/tstSqlFTab3/
### start tst tstSqlFTab3 #########################################
Und Eins Oder
. zw aber
Und Eins--z---
. und eins 1
. und eins 2
Und Eins--z---
Und Eins Oder
. zw aber
a-----b---
aaa 222
a-----b---
$/tstSqlFTab3/
*/
call pipeIni
call tst t, 'tstSqlFTab3'
call sqlConnect
sq1 = 'select '' und eins'' "Und Eins Oder"',
', row_number() over() "zw aber" ',
'from sysibm.sysTables fetch first 2 rows only'
r = jOpen(sqlRdr(sq1), '<')
f = sqlRdrfTabReset(r, 'tstSqFTab3')
b = in2Buf(r)
call sqlFTabDetect f, b'.BUF'
call fTab f, b
call jClose r
sq2 = 'select ''aaa'' "a", 222 "b"' ,
'from sysibm.sysTables fetch first 1 rows only'
call sqlQuery 17, sq2
f = sqlfTabReset('tstSqFTab3t', 17)
st = 'tstSqFTab3st'
call sqlFetch2St 17, st
s2 = 'tstSqFTab3s2'
do sx=1 to m.st.0
m.s2.sx = st'.'sx
end
m.s2.0 = m.st.0
call sqlFTabDetect f, s2
call fTabBegin f
do sx=1 to m.st.0
call out f(m.f.fmt, st'.'sx)
end
call fTabEnd f
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab3
tstSqlFTab4: procedure expose m.
/*
$=/tstSqlFTab4/
### start tst tstSqlFTab4 #########################################
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
*** err: SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: , FROM INTO
. e 2: src select x frm y
. e 3: > <<<pos 14 of 14<<<
. e 4: sql = select x frm y
. e 5: stmt = prepare s10 into :M.SQL.10.D from :src
. e 6: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -104: select x frm y
a
3
1 rows fetched: select 3 "a" from sysibm.sysDummy1
dy => 1
a
1
1 rows fetched: select 1 "a" from sysibm.sysDummy1
sqlCode -204: drop table gibt.EsNicht
a
2
1 rows fetched: select 2 "a" from sysibm.sysDummy1
SQLCODE = -104: ILLEGAL SYMBOL "Y". SOME SYMBOLS THAT MIGHT
. BE LEGAL ARE: , FROM INTO
src select x frm y
. > <<<pos 14 of 14<<<
sql = select x frm y
stmt = prepare s10 into :M.SQL.10.D from :src
with into :M.SQL.10.D = M.SQL.10.D
sqlCode 0: rollback
ret => 0
$/tstSqlFTab4/
*/
call pipeIni
call tst t, 'tstSqlFTab4'
call sqlConnect
b = jBuf('select 1 "a" from sysibm.sysDummy1;' ,
, 'drop table gibt.EsNicht;' ,
, 'select 2 "a" from sysibm.sysDummy1;',
, ' select x frm y;',
, 'select 3 "a" from sysibm.sysDummy1;')
call tstout t, 'dy =>' sqlsOut(scanSqlStmtRdr(b, 0))
call tstout t, 'ret =>' sqlsOut(scanSqlStmtRdr(b, 0), 'rb ret')
call tstEnd t
call sqlDisConnect
return
endProcedure tstSqlFTab4
tstSql4Obj: procedure expose m.
/*
$=/tstSql4Obj/
### start tst tstSql4Obj ##########################################
tstR: @tstWriteoV2 isA :tstClass-1 = -11
tstR: .a2i = -11
tstR: .b3b = b3
tstR: .D4 = D4-11+D4++++.
tstR: .fl5 = -111.1
tstR: .ex6 = -.111e-11
insert into cr.insTb -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', 'D4-11+D4++++', -111.1, -.111e-11
. ) ; .
insert into cr.insTbHex -- tstClass-1
. ( , a2i, b3b, D4, fl5, ex6
. ) values .
. ( -11, -11, 'b3', x'C40760F1F14EC4F44E4E4E4E', -111.1, -.111e-1+
1
. ) ; .
tstR: @tstWriteoV4 isA :tstClass-2
tstR: .c = c83
tstR: .a2i = 83
tstR: .b3b = b3b8
tstR: .D4 = D483+D4++++++++++++++++++++++++++++++++++++++++++++++++
.++++++++++++++++++++++++++++++.
tstR: .fl5 = .183
tstR: .ex6 = .11183e-8
insert into cr.insTb -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , 'D483+D4++++++++++++++++++++++++++++++++++++++++++++++++++++++
'
. || '++++++++++++++++++++++++'
. , .183, .11183e-8
. ) ; .
insert into cr.insTbHex -- tstClass-2
. ( c, a2i, b3b, D4, fl5, ex6
. ) values .
. ( 'c83', 83, 'b3b8'
. , x'C407F8F34EC4F44E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. || '++++++++++++++++++++++++++++++++'
. || x'314E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E4E'
. , .183, .11183e-8
. ) ; .
$/tstSql4Obj/
*/
call pipeIni
call tst t, 'tstSql4Obj'
call pipe '+N'
call tstDataClassOut '. c3 a2i i b3b c5 D4 c23 fl5 f8n2 ex6 e9n3',
, -11, -11
call tstDataClassOut 'c c3 a2i i b3b c5 D4 c93 fl5 f8n2 ex6 e9n3',
, 83, 83
call pipe 'P|'
do cx=1 while in()
i = m.in
call mAdd t'.'trans, className(objClass(i)) 'tstClass-'cx
call out i
call sql4Obj i, 'cr.insTb'
m.i.d4 = overlay('07'x, m.i.d4, 2)
if length(m.i.d4) >= 62 then
m.i.d4 = overlay('31'x, m.i.d4, 62)
call sql4Obj i, 'cr.insTbHex'
end
call pipe '-'
call tstEnd t
return
endProcedure tstSql4Obj
tstSqlC: procedure expose m.
call sqlIni
/*
$=/tstSqlCRx/
### start tst tstSqlCRx ###########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: stmt = prepare s9 into :M.SQL.9.D from :src
. e 7: with into :M.SQL.9.D = M.SQL.9.D
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: stmt = prepare s9 into :M.SQL.9.D from :src
. e 3: with into :M.SQL.9.D = M.SQL.9.D
sys ==> server CHSKA000DP4G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCRx/
$=/tstSqlCCsm/
### start tst tstSqlCCsm ##########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "?". SOME SYMBOLS THAT MIGH+
T
. e 1: BE LEGAL ARE: . <IDENTIFIER> JOIN INNER LEFT RIGHT FU+
LL CROSS ,
. e 2: HAVING GROUP
. e 3: src select * from sysibm?sysDummy1
. e 4: > >>>pos 21 of 30>>>
. e 5: sql = select * from sysibm?sysDummy1
. e 6: subsys = DE0G, host = RZZ
*** err: SQLCODE = -204: NONONO.SYSDUMMY1 IS AN UNDEFINED NAME
. e 1: sql = select * from nonono.sysDummy1
. e 2: subsys = DE0G, host = RZZ
sys RZZ/DE0G ==> server CHROI00ZDE0G .
fetched a1=abc, i2=12, c3=---
. I1 C2
. 1 eins
2222 zwei
$/tstSqlCCsm/ */
sql1 = "select 1 i1, 'eins' c2 from sysibm.sysDummy1" ,
"union all select 2222 i1, 'zwei' c2 from sysibm.sysDummy1"
do tx=1 to 1 + (m.tst_Csm \== 0)
if tx = 1 then do
call tst t, "tstSqlCRx"
sys = ''
end
else do
call tst t, "tstSqlCCsm"
sys = 'RZZ/DE0G'
end
call sqlConnect sys
cx = 9
call sqlQuery cx, 'select * from sysibm?sysDummy1'
call sqlQuery cx, 'select * from nonono.sysDummy1'
call sqlQuery cx, "select 'abc' a1, 12 i2, current server srv",
", case when 1=0 then 1 else null end c3",
"from sysibm.sysDummy1"
do while sqlFetch(cx, dst)
call out 'sys' sys '==> server' m.dst.srv
call out 'fetched a1='m.dst.a1', i2='m.dst.i2', c3='m.dst.c3
end
call fTabAuto , sqlRdr(sql1)
call sqlDisconnect
call tstEnd t
end
return
endProcedure tstSqlC
tstSqlUpd: procedure expose m.
/*
$=/tstSqlUpd/
### start tst tstSqlUpd ###########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpd/ */
call tst t, "tstSqlUpd"
cx = 9
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQuery cx, "select * from final table (update session.dgtt",
" set c2 = 'u' || c2)"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpd
tstSqlUpdPre: procedure expose m.
/*
$=/tstSqlUpdPre/
### start tst tstSqlUpdPre ########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table ( update session.dgtt set c2 = ? ||+
. c2)
stmt = prepare s5 into :M.SQL.5.D from :src
with into :M.SQL.5.D = M.SQL.5.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstSqlUpdPre/ */
call tst t, "tstSqlUpdPre"
cx = 5
qx = 3
call sqlConnect
call sqlUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlUpdatePrepare 5, "insert into session.dgtt" ,
"values (?, ?, ?)"
call sqlUpdateExecute 5, 1, 'eins', '2012-04-01 06.07.08'
call sqlUpdateExecute 5, 2, 'zwei', '2012-02-29 15:44:33.22'
call out 'insert updC' m.sql.5.updateCount
call sqlUpdatePrepare 5,"insert into session.dgtt" ,
"select i1+?, 'zehn+'||strip(c2), t3+? days",
"from session.dgtt"
call sqlUpdateExecute 5, 10, 10
call out 'insert select updC' m.sql.5.updateCount
call sqlQueryPrepare cx, 'select d.*' ,
', case when mod(i1,2) = ? then 0+? else null end grad' ,
'from session.dgtt d'
call sqlQueryExecute cx, 1, 1
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlClose cx
call sqlQueryPrepare cx, "select * from final table (" ,
"update session.dgtt set c2 = ? || c2)"
call sqlQueryExecute cx, "u"
do qx=qx+1 while sqlFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlUpdPre
tstsqlRxUpd: procedure expose m.
/*
$=/tstsqlRxUpd/
### start tst tstsqlRxUpd #########################################
insert updC 1
insert select updC 2
dest4.fet: 1 eins 2012-04-01-06.07.08.000000 1 updC 0
dest5.fet: 2 zwei 2012-02-29-15.44.33.220000 --- updC 0
dest6.fet: 11 zehn+eins 2012-04-11-06.07.08.000000 1 updC 0
dest7.fet: 12 zehn+zwei 2012-03-10-15.44.33.220000 --- updC 0
SQLCODE = 000, SUCCESSFUL EXECUTION
warnings 4=W no where
sql = select * from final table (update session.dgtt set c2 = 'u' +
|| c2)
stmt = prepare s9 into :M.SQL.9.D from :src
with into :M.SQL.9.D = M.SQL.9.D
dest9.fet: 1 ueins 2012-04-01-06.07.08.000000 updC 4
dest10.fet: 2 uzwei 2012-02-29-15.44.33.220000 updC 4
dest11.fet: 11 uzehn+eins 2012-04-11-06.07.08.000000 updC 4
dest12.fet: 12 uzehn+zwei 2012-03-10-15.44.33.220000 updC 4
$/tstsqlRxUpd/ */
call pipeIni
call tst t, "tstsqlRxUpd"
cx = 9
qx = 3
call sqlRxConnect
call sqlRxUpdate,"declare global temporary table session.dgtt",
"(i1 int, c2 varchar(20), t3 timestamp)"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(1, 'eins', '2012-04-01 06.07.08')"
call sqlRxUpdate,"insert into session.dgtt" ,
"values(2, 'zwei', '2012-02-29 15:44:33.22')"
call out 'insert updC' m.sql..updateCount
call sqlRxUpdate,"insert into session.dgtt" ,
"select i1+10, 'zehn+'||strip(c2), t3+10 days",
"from session.dgtt"
call out 'insert select updC' m.sql..updateCount
call sqlRxQuery cx, 'select d.*' ,
', case when mod(i1,2) = 1 then 1 else null end grad' ,
'from session.dgtt d'
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxQuery cx, "select * from final table",
"(update session.dgtt set c2 = 'u' || c2)"
do qx=qx+1 while sqlRxFetch(cx, 'dest'qx'.fet')
dst = 'dest'qx'.fet'
call out dst':' m.dst.i1 m.dst.c2 m.dst.t3 ,
'updC' m.sql.cx.updateCount
drop m.dst.i1 m.dst.c2 m.dst.t3 m.dst.grad
end
call sqlRxClose cx
call sqlRxDisconnect
call tstEnd t
return
endProcedure tstsqlRxUpd
tstSqlE: procedure expose m.
/*
$=/tstSqlE/
### start tst tstSqlE #############################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
-713 set schema ''
0 set schema
0 select
fetch=1 SYSIBM
$/tstSqlE/
*/
call sqlConnect
call tst t, "tstSqlE"
call tstOut t, sqlExecute(3, "set current schema = 'sysibm'") ,
"set schema ''"
call tstOut t, sqlExecute(3, " set current schema = sysibm ") ,
"set schema"
call tstOut t, sqlExecute(3, " select current schema c" ,
"from sysibm.sysDummy1") 'select'
call tstOut t, 'fetch='sqlFetch(3, aa) m.aa.c
call sqlClose 3
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlE
tstSqlO: procedure expose m.
/*
$=/tstSqlO/
### start tst tstSqlO #############################################
sqlCode 0: set current schema = A540769
*** err: SQLCODE = -204: A540769.SYSDUMMY IS AN UNDEFINED NAME
. e 1: sql = select * from sysdummy
. e 2: stmt = prepare s10 into :M.SQL.10.D from :src
. e 3: with into :M.SQL.10.D = M.SQL.10.D
sqlCode -204: select * from sysdummy
REQD=Y col=123 case=--- .sqlInd:-1 col5=anonym geburri=1956-04-01+
-06.00.00.000000
$/tstSqlO/
*/
call sqlConnect
call scanWinIni
call tst t, "tstSqlO"
call sqlStmts 'set current schema = A540769';
call sqlStmts 'select * from sysdummy';
r = sqlRdr( ,
"select d.*, 123, timestamp('01.04.1956','06:00:00')" ,
'"geburri walter",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d')
call jOpen r, '<'
do while jRead(r)
o = m.r
call out 'REQD='m.o.IBMREQD 'col='m.o.col2,
'case='m.o.CASENULL '.sqlInd:'m.o.caseNull.sqlInd,
'col5='m.o.col5,
'geburri='m.o.GEBURRI
end
call jClose r
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlUpdComLoop: procedure expose m.
/*
$=/tstSqlUpdComLoop/
### start tst tstSqlUpdComLoop ####################################
sqlCode 0: declare global temporary table session.dgtt (i1 int) on +
commit ....
sqlCode 0, 123 rows inserted: insert into session.dgtt select row_n+
umber()....
CNT
123
1 rows fetched: select count(*) cnt from session.dgtt
123 rows deleted, 10 commits: delete from session.dgtt d where i1 i+
n (sele....
C
0
1 rows fetched: select count(*) cnt from session.dgtt
$/tstSqlUpdComLoop/ */
call pipeIni
call tst t, "tstSqlUpdComLoop"
call sqlConnect
call sqlsOut "declare global temporary table session.dgtt",
"(i1 int) on commit preserve rows"
call sqlsOut "insert into session.dgtt",
"select row_number() over() from sysibm.sysTables",
"fetch first 123 rows only"
call sqlsOut "select count(*) cnt from session.dgtt"
call out sqlUpdComLoop("delete from session.dgtt d where i1 in",
"(select i1 from session.dgtt fetch first 13 rows only)")
call sqlsOut "select count(*) cnt from session.dgtt"
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlUpdComLoop
tstSqlO1: procedure expose m.
/*
$=/tstSqlO1/
### start tst tstSqlO1 ############################################
tstR: @tstWriteoV2 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV3 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV4 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV5 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
--- writeAll
tstR: @tstWriteoV6 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART
tstR: @tstWriteoV7 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLEPART_HIST
tstR: @tstWriteoV8 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLES
tstR: @tstWriteoV9 isA :<tstSqlO1Type>
tstR: .CR = SYSIBM
tstR: .TB = SYSTABLESPACE
$/tstSqlO1/
*/
call tst t, "tstSqlO1"
call sqlConnect
qr = sqlRdr("select strip(creator) cr, strip(name) tb",
"from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 2 fetch first 4 rows only")
call jOpen qr, m.j.cRead
call mAdd t.trans, className(m.qr.type) '<tstSqlO1Type>'
do while jRead(qr)
abc = m.qr
if m.qr.rowCount = 1 then do
cx = m.qr.cursor
end
call out abc
end
call jClose qr
call out '--- writeAll'
call pipeWriteAll qr
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO1
tstSqlO2: procedure expose m.
/*
$=/tstSqlO2/
### start tst tstSqlO2 ############################################
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstSqlO2/
*/
call pipeIni
call tst t, "tstSqlO2"
call sqlConnect
call pipe '+N'
call out "select strip(creator) cr, strip(name) tb,"
call out "(row_number()over())*(row_number()over()) rr"
call out "from sysibm.sysTables"
call out "where creator='SYSIBM' and name like 'SYSTABL%'"
call out "order by 2 fetch first 4 rows only"
call pipe 'N|'
call sqlSel
call pipe 'P|'
call fTabAuto fTabReset(abc, 1)
call pipe '-'
call sqlDisConnect
call tstEnd t
return 0
endProcedure tstSqlO2
tstSqlS1: procedure expose m.
/*
$=/tstSqlS1/
### start tst tstSqlS1 ############################################
select c, a from sysibm.sysDummy1
tstR: @tstWriteoV2 isA :<cla sql c a>
tstR: .C = 1
tstR: .A = a
select ... where 1=0
tstR: @ obj null
$/tstSqlS1/
*/
call sqlIni
call tst t, "tstSqlS1"
call sqlConnect
s1 = jSingle( ,
sqlRdr("select count(*) c, 'a' a from sysibm.sysdummy1"))
call mAdd t.trans, className(objClass(s1)) '<cla sql c a>'
call out 'select c, a from sysibm.sysDummy1'
call tstWrite t, s1
call out 'select ... where 1=0'
call tstWrite t, jSingle( ,
sqlRdr("select*from sysibm.sysdummy1 where 1=0"), '')
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlS1
tstSqlStmt: procedure expose m.
/*
$=/tstSqlStmt/
### start tst tstSqlStmt ##########################################
*** err: SQLCODE = -713: THE REPLACEMENT VALUE FOR CURRENT SCHEMA I+
S
. e 1: INVALID
. e 2: sql = set current schema = 'sysibm'
. e 3: stmt = execute immediate :src
sqlCode -713: set current schema = 'sysibm'
sqlCode 0: set current schema = sysibm
tstR: @tstWriteoV2 isA :<sql?sc>
tstR: .C = SYSIBM
tstR: @tstWriteoV3 isA :<sql?sc>
tstR: .C = SYSIBM
$/tstSqlStmt/
*/
call sqlConnect
call tst t, "tstSqlStmt"
cn = className(classNew('n* Sql u f%v C'))
call mAdd t.trans, cn '<sql?sc>'
call sqlStmts "set current schema = 'sysibm'"
call sqlsOut " set current schema = sysibm "
call sqlsOut " select current schema c from sysDummy1", , 'o'
call sqlsOut " (select current schema c from sysDummy1)", , 'o'
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmt
tstSqlStmts: procedure expose m.
/*
$=/tstSqlStmts/
### start tst tstSqlStmts #########################################
*** err: SQLCODE = -104: ILLEGAL SYMBOL "BLABLA". SOME SYMBOLS THAT
. e 1: MIGHT BE LEGAL ARE: <ERR_STMT> <WNG_STMT> GET SQL SAV+
EPOINT HOLD
. e 2: FREE ASSOCIATE
. e 3: src blabla
. e 4: > <<<pos 1 of 6<<<
. e 5: sql = blabla
sqlCode -104: blabla
sqlCode 0: set current schema= sysIbm
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
c
1
1 rows fetched: select count(*) "c" from sysDummy1 with ur
#jIn 1# set current -- sdf
#jIn 2# schema = s100447;
#jIn eof 3#
sqlCode 0: set current schema = s100447
$/tstSqlStmts/ */
call jIni
call sqlConnect
call scanReadIni
call scanWinIni
call tst t, "tstSqlStmts"
call sqlStmts "blabla ;;set current schema= sysIbm "
b = jBuf('select count(*) "c" from sysDummy1 --com' ,
,'with /* comm */ ur;')
call sqlStmts b
call sqlStmts b
call mAdd mCut(t'.IN', 0), 'set current -- sdf', 'schema = s100447;'
call sqlStmts
call sqlDisConnect
call tstEnd t
return
endProcedure tstSqlStmts
tstCatTb: /* ???????????????????? tkr kopieren und testen */
/*
$=/tstCatTb/
### start tst tstCatTb ############################################
..
select * from sysibm.SYSDUMMY1 .
IBMREQD
I .
Y .
I .
IBMREQD
$/tstCatTb/
*/
call sqlConnect
call tst t, 'tstCatTb'
call sqlCatTb 'sysDummy1'
call sqlCatTb 'SYSTableSpaceStats',
, "name = 'A403A1' and dbName = 'DA540769'"
call sqlDisConnect
call tstEnd t
return
endProcedure tstCatTb
tstSqlDisDb: procedure expose m.
call sqlDsn di, 'DP4G', '-dis db(*) sp(*)' ,
'restrict advisory limit(*)', 12
m.oo.0 = 0
call sqlDisDb oo, di
say 'di.0' m.di.0 '==> oo.0' m.oo.0
trace ?r
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE)
say 'DB2PDB6.RR2HHAGE ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE, 3)
say 'DB2PDB6.RR2HHAGE.3 ==>' ix m.oo.ix.sta
ix = sqlDisDbIndex(oo, DB2PDB6,RR2HHAGE,22)
say 'DB2PDB6.RR2HHAGE.22 ==>' ix m.oo.ix.sta
return
endProcedure tstSqlDisDb
/****** tstComp ********************************************************
test the wsh compiler
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompExpr
call tstCompFile
call tstCompStmt
call tstCompDir
call tstCompObj
call tstCompORun
call tstCompORu2
call tstCompORuRe
call tstCompDataIO
call tstCompPipe
call tstCompPip2
call tstCompRedir
call tstCompComp
call tstCompColon
call tstCompTable
call tstCompSyntax
if m.err.os == 'TSO' then
call tstCompSql
call tstTotal
return
endProcedure tstComp
tstComp1: procedure expose m.
parse arg ty nm cnt
c1 = 0
if cnt = 0 | cnt = '+' then do
c1 = cnt
cnt = ''
end
call jIni
src = jBuf()
call jOpen src, m.j.cWri
do sx=2 to arg()
call jWrite src, arg(sx)
end
call tstComp2 nm, ty, jClose(src), , c1, cnt
return
endProcedure tstComp1
tstComp2: procedure expose m.
parse arg nm, spec, src, compSt
call compIni
call tst t, nm, compSt
if src == '' then do
src = jBuf()
call tst4dp src'.BUF', mapInline(nm'Src')
end
m.t.moreOutOk = abbrev(strip(arg(5)), '+')
oldErr = m.err.count
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.err.count = oldErr
coErr = m.t.err
say if( noSyn, "compiled", "*** syntaxed") r ":" objMet(r, 'oRun')
cnt = 0
do ax = 5 to max(arg(), 5) while m.t.err = coErr & noSyn
a1 = strip(arg(ax))
if a1 == '' & arg() >= 5 then
iterate
if abbrev(a1, '+') then do
m.t.moreOutOk = 1
a1 = strip(substr(a1, 2))
end
if datatype(a1, 'n') then
cnt = a1
else if a1 \== '' then
call err 'tstComp2 bad arg('ax')' arg(ax)
if cnt = 0 then do
call mCut 'T.IN', 0
call out "run without input"
end
else do
call mAdd mCut('T.IN', 0),
,"eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
do lx=4 to cnt
call mAdd 'T.IN', left(lx "line" lx, lx+9, '-')';'
end
call out "run with" cnt "inputs"
end
m.t.inIx = 0
call oRun r
end
call tstEnd t
return
endProcedure tstComp2
tstCompDataConst: procedure expose m.
/*
$=/tstCompDataConst/
### start tst tstCompDataConst ####################################
compile =, 8 lines: Lline one, $** asdf
run without input
. Lline one, .
line two..
line threecontinued on 4
line five fortsetzung
line six fortsetzung
$/tstCompDataConst/ */
call tstComp1 '= tstCompDataConst',
, ' Lline one, $** asdf',
, 'line two.',
, 'line three$*+ bla bla' ,
, 'continued on 4',
, 'line five $*( und so',
, 'weiter $abc $? $''$*)'' $"$*)" und weiter $*) fortsetzung',
, 'line six $*( und $*( $** $*( so',
, 'weiter $abc $? $*)'' $"$*)" und weiter $*) fortsetzung'
/*
$=/tstCompDataConstBefAftComm1/
### start tst tstCompDataConstBefAftComm1 #########################
compile =, 3 lines: $*(anfangs com.$*) $*(plus$*) $** x
run without input
the only line;
$/tstCompDataConstBefAftComm1/ */
call tstComp1 '= tstCompDataConstBefAftComm1',
, ' $*(anfangs com.$*) $*(plus$*) $** x',
, 'the only line;',
, ' $*(end kommentar$*) '
/*
$=/tstCompDataConstBefAftComm2/
### start tst tstCompDataConstBefAftComm2 #########################
compile =, 11 lines: $*(anfangs com.$*) $*(plus$*) $*+ x
run without input
the first non empty line;
. .
befor an empty line with comments;
$/tstCompDataConstBefAftComm2/ */
call tstComp1 '= tstCompDataConstBefAftComm2',
, ' $*(anfangs com.$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, ' $*(comment 2. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts Zeile com.$*) $*(plus$*) $** x',
, 'the first non empty line;',
, ' ',
, 'befor an empty line with comments;',
, ' $*(comment 4. Zeile$*) $*(plus$*) $*+ x',
, ' $*(forts 4.Zeile com.$*) $*(plus$*) $** x',
, ' $*(end kommentar$*) $*+',
, ' $*(forts end com.$*) $*(plus$*) $** x'
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
/*
$=/tstCompDataVars/
### start tst tstCompDataVars #####################################
compile =, 5 lines: Lline one, $** asdf
run without input
. Lline one, .
lline zwei output
lline 3 .
variable v1 = valueV1 ${v1}= valueV1; .
. $-{""$v1} = valueV1; .
$/tstCompDataVars/ */
call tstComp1 '= tstCompDataVars',
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }; ',
, ' $"$-{""""$v1} =" $-{$""$"v1"}; '
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
/*
$=/tstCompShell3/
### start tst tstCompShell3 #######################################
compile @, 8 lines: call tstOut "T", "abc" $-[2*3$] "efg"$-[2*3$]"+
hij"
run without input
abc 6 efg6hij
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s
insert into A540769x.tqt002 with n(n) as ( select 4 from sysibm.s +
. union all .
abc 6 efg6hij
$/tstCompShell3/ */
call tstComp1 '@ tstCompShell3',
, 'call tstOut "T", "abc" $-[2*3$] "efg"$-[2*3$]"hij"',
, 'ix=3' ,
, 'call tstOut "T","insert into A540769x.tqt002" ,',
, '"with n(n) as ( select" $-[ix+1$] "from sysibm.s"',
, 'call tstOut "T","insert into A540769x.tqt002" , ',
, '"with n(n) as ( select" $-[ix+1$] "from sysibm.s" , ' ,
, '" union all "' ,
, '$$ abc $-[2*3$] efg$-[2*3$]hij',
/*
$=/tstCompShell/
### start tst tstCompShell ########################################
compile @, 12 lines: $$ Lline one, $** asdf
run without input
Lline one,
lline zwei output
v1 = valueV1 ${v1}= valueV1|
REXX OUT L5 CONTINUED L6 CONTINUED L7
L8 ONE
L9 TWO
valueV1
valueV1 valueV2
out valueV1 valueV2
SCHLUSS
$/tstCompShell/ */
call tstComp1 '@ tstCompShell',
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call out rexx out l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call out l8 one ' ,
, 'call out l9 two$=v2=valueV2 ',
, '$$- $v1 $$- $v1 $v2 ',
, 'call out "out " $v1 $v2 ',
, '$$- schluss '
/*
$=/tstCompShell2/
### start tst tstCompShell2 #######################################
compile @, 13 lines: $@do j=0 to 1 $@[ $$ do j=$j
run without input
do j=0
after if 0 $@[ $]
after if 0 $=@[ $]
do j=1
if 1 then $@[ a
a2
if 1 then $@=[ b
b2
after if 1 $@[ $]
after if 1 $=@[ $]
end
$/tstCompShell2/ */
call tstComp1 '@ tstCompShell2',
, '$@do j=0 to 1 $@[ $$ do j=$j' ,
, 'if $j then $@[ ',
, '$$ if $j then $"$@[" a $$a2' ,
, '$]',
, 'if $j then $@=[ ',
, '$$ if $j then $"$@=[" b $$b2' ,
, '$]',
, 'if $j then $@[ $]' ,
, '$$ after if $j $"$@[ $]"' ,
, 'if $j then $@=[ $]' ,
, '$$ after if $j $"$=@[ $]"' ,
, '$]',
, '$$ end'
return
endProcedure tstCompShell
tstCompPrimary: procedure expose m.
call compIni
/*
$=/tstCompPrimary/
### start tst tstCompPrimary ######################################
compile =, 16 lines: Strings $"$""$""""$""" $'$''$''''$'''
run without input
Strings $"$""$" $'$''$'
rexx $-[ 3 * 5 $] = 15
rexx $-[ 5 * 7 $] = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn eof 1#
var read >1 0 rr undefined
#jIn eof 2#
var read >2 0 rr undefined
no call abc$-[4*5$] $-[efg$-[6*7$] abc20 EFG42
brackets $-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$] 1000
run with 3 inputs
Strings $"$""$" $'$''$'
rexx $-[ 3 * 5 $] = 15
rexx $-[ 5 * 7 $] = 35
rexx $-// 7 * 11 $// = 77
rexx $-/abcEf/ 11 * 13 $/abcEf/ = 143
data line three line four bis hier
shell line five line six bis hier
var get v1 value Eins, v1 value Eins .
var isDef v1 1, v2 0 .
#jIn 1# eins zwei drei
var read >1 1 rr eins zwei drei
#jIn 2# zehn elf zwoelf?
var read >2 1 rr zehn elf zwoelf?
no call abc$-[4*5$] $-[efg$-[6*7$] abc20 EFG42
brackets $-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$] 1000
$/tstCompPrimary/ */
call vRemove 'v2'
call tstComp1 '= tstCompPrimary 3',
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx $"$-[ 3 * 5 $] =" $-[ 3 * 5 $]' ,
, 'rexx $"$-[ 5 * 7 $] =" $-[ 5 * 7 $]' ,
, 'rexx $"$-// 7 * 11 $// =" $-// 7 * 11 $//' ,
, 'rexx $"$-/abcEf/ 11 * 13 $/abcEf/ ="',
'$-/abcEf/ 11 * 13 $/abcEf/' ,
, 'data $-=[ line three',
, 'line four $] bis hier' ,
, 'shell $-@[ $$ line five',
, '$$ line six $] bis hier' ,
, '$= v1 = value Eins $=rr=undefined $= eins = 1 ',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v${ eins } }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr',
, 'no call $"abc$-[4*5$] $-[efg$-[6*7$]"',
'abc$-[4*5$] $-[efg$-[6*7$]$]',
, 'brackets $"$-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$]"',
'$-[$-[1+9$]*$-[7+3$]*$-/b/5+5$/b/$]'
return
endProcedure tstCompPrimary
tstCompExpr: procedure expose m.
call compIni
/*
$=/tstCompExprStr/
### start tst tstCompExprStr ######################################
compile -, 3 lines: $=vv=vvStr
run without input
vv=vvStr
o2String($.-vv)=vvStr
$/tstCompExprStr/ */
call tstComp1 '- tstCompExprStr',
, '$=vv=vvStr' ,
, '"vv="$vv' ,
, '$"o2String($.-vv)="o2String($.-vv)'
/*
$=/tstCompExprObj/
### start tst tstCompExprObj ######################################
compile ., 5 lines: $=vv=vvStr
run without input
vv=
vvStr
s2o($.vv)=
vvStr
$/tstCompExprObj/ */
call tstComp1 '. tstCompExprObj',
, '$=vv=vvStr' ,
, '"]vv="', '$.-vv',
, '$."s2o($.vv)="', 's2o($-vv)'
/*
$=/tstCompExprDat/
### start tst tstCompExprDat ######################################
compile =, 4 lines: $=vv=vvDat
run without input
vv=vvDat
$.-vv= ]vvDat
$.-["abc"$]=]abc
$/tstCompExprDat/ */
call tstComp1 '= tstCompExprDat',
, '$=vv=vvDat' ,
, 'vv=$vv',
, '$"$.-vv=" $.-vv',
, '$"$.-[""abc""$]="$.-["abc"$]'
/*
$=/tstCompExprRun/
### start tst tstCompExprRun ######################################
compile @, 3 lines: $=vv=vvRun
run without input
vv=vvRun
o2string($.-vv)=vvRun
$/tstCompExprRun/ */
call tstComp1 '@ tstCompExprRun',
, '$=vv=vvRun' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.-vv)="o2string($.-vv)'
/*
$=/tstCompExprCon/
### start tst tstCompExprCon ######################################
compile #, 2 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
$/tstCompExprCon/
$=/tstCompExprCo2/
### start tst tstCompExprCo2 ######################################
compile #, 3 lines: $$ in # drinnen
run without input
$$ in # drinnen
call out "vv="$vv
nacgh $#@
$/tstCompExprCo2/
*/
call tstComp1 '# tstCompExprCon',
, '$$ in # drinnen' ,
, 'call out "vv="$vv'
call tstComp1 '# tstCompExprCo2',
, '$$ in # drinnen' ,
, 'call out "vv="$vv',
, '$#@ $$ nacgh $"$#@"'
return
endProcedure tstCompExpr
tstCompStmt: procedure expose m.
/*
$=/tstCompStmt1/
### start tst tstCompStmt1 ########################################
compile @, 8 lines: $= v1 = value eins $= v2 =- 3*5*7 .
run without input
data v1 value eins v2 105
eins
zwei
drei
vier
fuenf
elf
. zwoelf dreiZ .
. vierZ .
fuenfZ
lang v1 value eins v2 945
oRun ouput 1
$/tstCompStmt1/ */
call pipeIni
call compIni
call vPut 'oRun', oRunner('call out "oRun ouput" (1*1)')
call vRemove 'v2'
call tstComp1 '@ tstCompStmt1',
, '$= v1 = value eins $= v2 =- 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@[$$ zwei $$ drei ',
, ' $@[ $] $@// $// $@/q r s / $/q r s /',
' $@/eins/ $@[ $$vier $] $/eins/ $] $$fuenf',
, '$$elf $@=[$@=[ zwoelf dreiZ $] ',
, ' $@=[ $] $@=[ $@=[ vierZ $] $] $] $$fuenfZ',
, '$$- "lang v1" $v1 "v2" ${v2}*9',
, '$@oRun'
/*
$=/tstCompStmt2/
### start tst tstCompStmt2 ########################################
compile @, 1 lines: $@for qq $$ loop qq $qq
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
loop qq eins zwei drei
#jIn 2# zehn elf zwoelf?
loop qq zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
loop qq zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
$/tstCompStmt2/ */
call tstComp1 '@ tstCompStmt2 3',
, '$@for qq $$ loop qq $qq'
/*
$=/tstCompStmt3/
### start tst tstCompStmt3 ########################################
compile @, 9 lines: $$ 1 begin run 1
2 ct zwei
ct 4 mit assign .
run without input
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
run with 3 inputs
1 begin run 1
3 run 3 ctV = ct 4 assign ctV|
run 5 procCall $@prCa
out in proc at 8
run 6 vor call $@prCa
out in proc at 8
9 run end
$/tstCompStmt3/ */
call tstComp1 '@ tstCompStmt3 3',
, '$$ 1 begin run 1',
, '$@ct $$ 2 ct zwei',
, '$$ 3 run 3 ctV = $ctV|',
, '$@ct $@=[ct 4 mit assign $=ctV = ct 4 assign ctV $]',
, '$$ run 5 procCall $"$@prCa" $@prCa',
, '$$ run 6 vor call $"$@prCa"',
, '$@prCa',
, '$@proc prCa $$out in proc at 8',
, '$$ 9 run end'
/*
$=/tstCompStmt4/
### start tst tstCompStmt4 ########################################
compile @, 4 lines: $=eins=vorher
run without input
eins vorher
eins aus named block eins .
$/tstCompStmt4/ */
call tstComp1 '@ tstCompStmt4 0',
, '$=eins=vorher' ,
, '$$ eins $eins' ,
, '$=/eins/aus named block eins $/eins/' ,
, '$$ eins $eins'
/*
$=/tstCompStmtDo/
### start tst tstCompStmtDo #######################################
compile @, 2 lines: ti=0$@do y=3 to 4 $@do 2 $@[
run without input
y=3 ti1 z=7
y=3 ti1 z=8
y=3 ti2 z=7
y=3 ti2 z=8
y=4 ti3 z=7
y=4 ti3 z=8
y=4 ti4 z=7
y=4 ti4 z=8
$/tstCompStmtDo/ */
call tstComp1 '@ tstCompStmtDo', 'ti=0$@do y=3 to 4 $@do 2 $@[',
, 'ti = ti + 1',
'$@do $*(sdf$*) z $*(sdf$*) =7 to 8 $$ y=$y ti$-[ti$] z=$z $]'
/*
$=/tstCompStmtDo2/
### start tst tstCompStmtDo2 ######################################
compile @, 7 lines: $$ $-=/sqlSel/
run without input
select 1 abc select 2 abc after table .
$/tstCompStmtDo2/ */
call tstComp1 '@ tstCompStmtDo2',
, '$$ $-=/sqlSel/',
, '$=ty = abc ',
, '$@do tx=1 to 2 $@=/table/',
, 'select $tx $ty',
, '$/table/',
, '$=ty = abc',
, 'after table',
'$/sqlSel/'
/*
$=/tstCompStmtWith/
### start tst tstCompStmtWith #####################################
compile @, 3 lines: $@with $.vA $$ fEins=$FEINS fZwei=$FZWEI va&fEi+
ns=${vA&FEINS}
run without input
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
fEins=2Eins fZwei=2Zwei va&fEins=1Eins
fEins=1Eins fZwei=1Zwei va&fEins=1Eins
$/tstCompStmtWith/
*/
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
v1 = onew(cl)
m.v1.feins = '1Eins'
m.v1.fzwei = '1Zwei'
v2 = oNew(cl)
m.v2.feins ='2Eins'
m.v2.fzwei ='2Zwei'
call vPut 'vA', v1
call vPut 'vB', v2
stmt = '$$ fEins=$FEINS fZwei=$FZWEI va&fEins=${vA&FEINS}'
call tstComp1 '@ tstCompStmtWith',
, '$@with $.vA' stmt ,
, '$@with $vA $@[' stmt ,
, '$@with $vB ' stmt stmt '$]'
/*
$=/tstCompStmtArg/
### start tst tstCompStmtArg ######################################
compile :, 11 lines: v2 = var2
run without input
a1=eins a2=zwei, a3=elf b1= b2=
after op= v2=var2 var2=zwei,
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=- v2=var2 var2=ZWEI
a1=EINS a2=ZWEI a3= b1=ELF b2=
after op=. v2=var2 var2=ZWEI
$/tstCompStmtArg/
*/
call tstComp1 ': tstCompStmtArg',
, 'v2 = var2',
, '@% outArg eins zwei, elf',
, '$$ after op= v2=$v2 var2=$var2',
, '@% outArg - eins zwei, elf',
, '$$ after op=- v2=$v2 var2=$var2',
, '@% outArg . eins zwei, elf',
, '$$ after op=. v2=$v2 var2=$var2',
, 'proc $@:/outArg/' ,
, 'arg a1 {$v2} a3, b1 b2',
, '$$ a1=$a1 a2=${$v2} a3=$a3 b1=$b1 b2=$b2' ,
, '$/outArg/'
cl = classNew('n? tstStmtWith u f FEINS v, f FZWEI v')
return
endProcedure tstCompStmt
tstCompSyntax: procedure expose m.
call tstCompSynPrimary
call tstCompSynAss
call tstCompSynRun
return
endProcedure tstCompSyntax
tstCompSynPrimary: procedure expose m.
/*
$=/tstCompSynPri1/
### start tst tstCompSynPri1 ######################################
compile @, 1 lines: a $ =
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
*** err: no method oRun in class String
$/tstCompSynPri1/ */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*
$=/tstCompSynPri2/
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition . {
. e 2: pos 4 in line 1: a $. {
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $. {
. e 2: pos 3 in line 1: a $. {
*** err: no method oRun in class String
$/tstCompSynPri2/ */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*
$=/tstCompSynPri3/
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- [ .
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - [
. e 2: pos 4 in line 1: b $- [
*** err: scanErr primary block or expression expected expected
. e 1: last token scanPosition - [
. e 2: pos 4 in line 1: b $- [
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $- [
. e 2: pos 3 in line 1: b $- [
*** err: no method oRun in class String
$/tstCompSynPri3/ */
call tstComp1 '@ tstCompSynPri3 +', 'b $- [ '
/*
$=/tstCompSynPri4/
### start tst tstCompSynPri4 ######################################
compile @, 1 lines: a ${ $*( sdf$*) } =
*** err: scanErr var name expected
. e 1: last token scanPosition } =
. e 2: pos 17 in line 1: a ${ $*( sdf$*) } =
$/tstCompSynPri4/ */
call tstComp1 '@ tstCompSynPri4 +', 'a ${ $*( sdf$*) } ='
/*
$=/tstCompSynFile/
### start tst tstCompSynFile ######################################
compile @, 1 lines: $@.<$*( co1 $*) $$abc
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .<$*( co1 $*) $$abc
. e 2: pos 3 in line 1: $@.<$*( co1 $*) $$abc
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@.<$*( co1 $*) $$abc
. e 2: pos 1 in line 1: $@.<$*( co1 $*) $$abc
*** err: no method oRun in class String
$/tstCompSynFile/ */
call tstComp1 '@ tstCompSynFile +', '$@.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*
$=/tstCompSynAss1/
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $=
$/tstCompSynAss1/ */
call tstComp1 '@ tstCompSynAss1 +', '$='
/*
$=/tstCompSynAss2/
### start tst tstCompSynAss2 ######################################
compile @, 2 lines: $= .
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $=
$/tstCompSynAss2/ */
call tstComp1 '@ tstCompSynAss2 +', '$= ', 'eins'
/*
$=/tstCompSynAss3/
### start tst tstCompSynAss3 ######################################
compile @, 2 lines: $= $$
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
$/tstCompSynAss3/ */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*
$=/tstCompSynAss4old/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
$/tstCompSynAss4old/
$=/tstCompSynAss4/
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $= eins
. e 2: pos 1 in line 1: $= eins
*** err: no method oRun in class String
$/tstCompSynAss4/ */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*
$=/tstCompSynAss5/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $= abc eins $$ = x
. e 2: pos 1 in line 1: $= abc eins $$ = x
*** err: no method oRun in class String
$/tstCompSynAss5/
$=/tstCompSynAss5old/
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected in assignment after $= var
. e 1: last token scanPosition eins $$ = x
. e 2: pos 9 in line 1: $= abc eins $$ = x
$/tstCompSynAss5old/ */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*
$=/tstCompSynAss6/
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= abc =
$/tstCompSynAss6/ */
call tstComp1 '@ tstCompSynAss6 +', '$= abc ='
/*
$=/tstCompSynAss7/
### start tst tstCompSynAss7 ######################################
compile @, 1 lines: $= abc =..
*** err: scanErr block or expression in assignment after $= expecte+
d
. e 1: last token scanPosition .
. e 2: pos 11 in line 1: $= abc =..
$/tstCompSynAss7/ */
call tstComp1 '@ tstCompSynAss7 +', '$= abc =.'
return
endProcedure tstCompSynAss
tstCompSynRun: procedure expose m.
/*
$=/tstCompSynRun1/
### start tst tstCompSynRun1 ######################################
compile @, 1 lines: $@
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@
. e 2: pos 1 in line 1: $@
*** err: no method oRun in class String
$/tstCompSynRun1/ */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*
$=/tstCompSynRun2/
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@=
. e 2: pos 1 in line 1: $@=
$/tstCompSynRun2/ */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*
$=/tstCompSynRun3/
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@: und
*** err: scanErr bad kind : in compExpr
. e 1: last token scanPosition und
. e 2: pos 5 in line 1: $@: und
*** err: no method oRun in class Null
$/tstCompSynRun3/ */
call tstComp1 '@ tstCompSynRun3 +', '$@: und'
/*
$=/tstCompSynFor4/
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor4/ */
call tstComp1 '@ tstCompSynFor4 +', '$@for'
/*
$=/tstCompSynFor5/
### start tst tstCompSynFor5 ######################################
compile @, 2 lines: $@for
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 6 in line 1: $@for
$/tstCompSynFor5/ */
call tstComp1 '@ tstCompSynFor5 +', '$@for', a
/*
$=/tstCompSynFor6/
### start tst tstCompSynFor6 ######################################
compile @, 2 lines: a
*** err: scanErr variable or named block after for
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@for $$q
$/tstCompSynFor6/
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
*/
/*
$=/tstCompSynFor7/
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr var? statement after for expected
. e 1: last token scanPosition .
. e 2: pos 11 in line 2: b $@for a
$/tstCompSynFor7/ */
call tstComp1 '@ tstCompSynFor7 +', 'a', ' b $@for a', ' $$q'
/*
$=/tstCompSynCt8/
### start tst tstCompSynCt8 #######################################
compile @, 3 lines: a
*** err: scanErr ct statement expected
. e 1: last token scanPosition .
. e 2: pos 8 in line 2: b $@ct
$/tstCompSynCt8/ */
call tstComp1 '@ tstCompSynCt8 +', 'a', ' b $@ct', ' $$q'
/*
$=/tstCompSynProc9/
### start tst tstCompSynProc9 #####################################
compile @, 2 lines: a
*** err: scanErr var or namedBlock expected after proc
. e 1: last token scanPosition .
. e 2: pos 15 in line 2: b $@proc $$q
$/tstCompSynProc9/ */
call tstComp1 '@ tstCompSynProc9 +', 'a', ' b $@proc $$q'
/*
$=/tstCompSynProcA/
### start tst tstCompSynProcA #####################################
compile @, 2 lines: $@proc p1
*** err: scanErr proc statement expected
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $@proc p1
$/tstCompSynProcA/ */
call tstComp1 '@ tstCompSynProcA +', '$@proc p1', ' $$q'
/*
$=/tstCompSynCallB/
### start tst tstCompSynCallB #####################################
compile @, 1 lines: $@% [roc p1$]
*** err: scanErr primary, block or expression expected
. e 1: last token scanPosition % [roc p1$]
. e 2: pos 3 in line 1: $@% [roc p1$]
*** err: scanErr rexxShell expected: compile @ stopped before end o+
f input
. e 1: last token scanPosition $@% [roc p1$]
. e 2: pos 1 in line 1: $@% [roc p1$]
*** err: no method oRun in class String
$/tstCompSynCallB/ */
call tstComp1 '@ tstCompSynCallB +', '$@% [roc p1$]'
/*
$=/tstCompSynCallC/
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@%[call roc p1 ]
*** err: scanErr ending $] expected after [
. e 1: last token scanPosition .
. e 2: atEnd after line 1: $@%[call roc p1 ]
$/tstCompSynCallC/ */
call tstComp1 '@ tstCompSynCallC +', '$@%[call roc p1 ]'
/*
$=/tstCompSynCallD/
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@^[call( $** roc
*** err: scanErr ending $] expected after [
. e 1: last token scanPosition )
. e 2: pos 13 in line 2: $*( p1 $*) )
$/tstCompSynCallD/ */
call tstComp1 '@ tstCompSynCallD +',
,'$@^[call( $** roc' , ' $*( p1 $*) )'
return
endProcedure tstCompSynRun
tstCompObj: procedure expose m.
call tstReset t
call oIni
cl = classNew('n? tstCompCla u v, f FEINS v, f FZWEI v')
do rx=1 to 10
o = oNew(cl)
m.tstComp.rx = o
m.o = 'o'rx
if rx // 2 = 0 then do
m.o.fEins = 'o'rx'.1'
m.o.fZwei = 'o'rx'.fZwei'rx
end
else do
m.o.fEins = 'o'rx'.fEins'
m.o.fZwei = 'o'rx'.2'
end
call mAdd 'T.TRANS', m.tstComp.rx '<o'rx'>'
end
/*
$=/tstCompObjRef/
### start tst tstCompObjRef #######################################
compile @, 13 lines: o1=m.tstComp.1
run without input
out .$"string" o1
string
out . o1
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .[ o3 $]
tstR: @<o3> isA :tstCompCla = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .[ o4 $]
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
$/tstCompObjRef/ */
m.ttt=1
call tstComp1 '@ tstCompObjRef' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out $".$""string""" o1 $$."string"',
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.[ o2 $]',
, '$$ out .[ o3 $"$]" $$.[ ', ' m.tstComp.3 ', ' $]',
, '$$ out .[ o4 $"$]" $$.[ ', ' m.tstComp.4 ', ' $]',
, '$$ out ./-/ o5 $"$/-/" $$./-/ m.tstComp.5 ', ' $/-/'
/*
$=/tstCompObjRefPri/
### start tst tstCompObjRefPri ####################################
compile @, 9 lines: $$ out .$"$.{o1}" $$.[ m.tstComp.1 $]
run without input
out .$.{o1}
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .$.-{o2}
<o2>
out .$.={o3}
. m.tstComp.3 .
out .$.@{out o4}
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf ORun oRun end >>>
out .$.@[$$abc $$efg$]
tstWriteO kindOf ORun oRun begin <<<
abc
efg
tstWriteO kindOf ORun oRun end >>>
out .$.@[o5$]
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o5> isA :tstCompCla = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
abc
tstWriteO kindOf ORun oRun end >>>
$/tstCompObjRefPri/ */
call tstComp1 '@ tstCompObjRefPri' ,
, '$$ out .$"$.{o1}" $$.[ m.tstComp.1 $]',
, '$$ out .$"$.-{o2}" $$.-[ m.tstComp.2 $]',
, '$$ out .$"$.={o3}" $$.=[ m.tstComp.3 $]',
, '$$ out .$"$.@{out o4}" $$.@@[ call out m.tstComp.4 $]',
, '$$ out .$"$.@[$$abc $$efg$]" $$. $.@@[ $$abc ', ' ', ' $$efg $]',
, '$$ out .$"$.@[o5$]" $$. $.@@[ $$. m.tstComp.5', '$$abc $]'
/*
$=/tstCompObjRefFile/
### start tst tstCompObjRefFile ###################################
compile @, 7 lines: $$ out .$".<.[o1]" $$.<.[ m.tstComp.1 $]
run without input
out ..<.[o1]
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o2> isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<{o3}
tstWriteO kindOf JRW jWriteNow begin <<<
. m.tstComp.3 .
tstWriteO kindOf JRW jWriteNow end >>>
out .$.<@{out o4}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @<o4> isA :tstCompCla = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
tstWriteO kindOf JRW jWriteNow end >>>
out .$<@[$$abc $$efg$]
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRefFile/ */
call tstComp1 '@ tstCompObjRefFile' ,
, '$$ out .$".<.[o1]" $$.<.[ m.tstComp.1 $]',
, '$$ out .$"<$.-{o2}" $$<.[ m.tstComp.2 $]',
, '$$ out .$"$.<{o3}" $$<=[ m.tstComp.3 $]',
, '$$ out .$"$.<@{out o4}" $$<@[ call out m.tstComp.4 $]',
, '$$ out .$"$<@[$$abc $$efg$]" $$<@[ $$abc ', ' ', ' $$efg $]'
/*
$=/tstCompObjFor/
### start tst tstCompObjFor #######################################
compile @, 2 lines: $@do rx=1 to 3 $$. m.tstComp.rx
run without input
FEINS=o1.fEins FZWEI=o1.2
FEINS=o2.1 FZWEI=o2.fZwei2
FEINS=o3.fEins FZWEI=o3.2
$/tstCompObjFor/
*/
call tstComp1 '@ tstCompObjFor' ,
, '$@do rx=1 to 3 $$. m.tstComp.rx' ,
, '$| $@forWith witx $$ FEINS=$FEINS FZWEI=$FZWEI'
/*
$=/tstCompObjRun/
### start tst tstCompObjRun #######################################
compile @, 4 lines: $$ out .$"$@[o1]" $$@[ $$. m.tstComp.1 $]
run without input
out .$@[o1]
tstWriteO kindOf ORun oRun begin <<<
tstR: @<o1> isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf ORun oRun end >>>
out .$<@[$$abc $$efg$]
tstWriteO kindOf JRW jWriteNow begin <<<
abc
efg
tstWriteO kindOf JRW jWriteNow end >>>
$/tstCompObjRun/ */
call tstComp1 '@ tstCompObjRun' ,
, '$$ out .$"$@[o1]" $$@[ $$. m.tstComp.1 $]',
, '$$ out .$"$<@[$$abc $$efg$]" $$<@[ $$abc ', ' ', ' $$efg $]'
m.t.trans.0 = 0
/*
$=/tstCompObj/
### start tst tstCompObj ##########################################
compile @, 6 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .[ o1, o2]
tstR: @tstWriteoV1 isA :tstCompCla = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @tstWriteoV2 isA :tstCompCla = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
$/tstCompObj/ */
call tstComp1 '@ tstCompObj' ,
, 'o1=m.tstComp.1',
, 'o2 = m.tstComp.2' ,
, '$$ out . o1 $$. o1',
, '$$ out .{ o2 } $$.[ o2 $]',
, '$$ out .[ o1, o2]$; $@.[ m.tstComp.1 ', ' m.tstComp.2 $]'
return
m.t.trans.0 = 0
endProcedure tstCompObj
tstCompORun: procedure expose m.
/*
$=/tstCompORun/
### start tst tstCompORun #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=-{1 arg only} oder?, v3=, v4=
oRun arg=2, v2=].{1 obj only} oder?, v3=, v4=
oRun arg=3, v2={2 args}, v3=und zwei?, v4=
oRun arg=4, v2={3 args}, v3=zwei, v4=und drei?
$/tstCompORun/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORun',
, '$@oRun', '$@%[oRun$]' ,
, ' $@%[oRun $"-{1 arg only}" oder?$]' ,
, ' $@%[oRun - $.".{1 obj only}" ''oder?''$] $=v2=zwei' ,
, ' $@%[oRun - $"{2 args}", "und" $v2"?"$]' ,
, ' $@%[oRun - $"{3 args}", $v2, "und drei?"$]'
return
endProcedure tstCompORun
tstCompORu2: procedure expose m.
/*
$=/tstCompORu2/
### start tst tstCompORu2 #########################################
compile @, 6 lines: $@oRun
run without input
oRun arg=1, v2=, v3=, v4=
oRun arg=1, v2=, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=2, v2=eins, zwei, drei, v3=, v4=
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
oRun arg=4, v2=-eins, v3=zwei, v4=DREI
$/tstCompORu2/ */
call compIni
call vPut 'oRun', oRunner('parse arg , v2, v3, v4;',
'call tstOut t, "oRun arg="arg()", v2="v2", v3="v3", v4="v4' )
call tstComp1 '@ tstCompORu2',
, '$@oRun', '$@%oRun',
, '$@% oRun eins, zwei, drei' ,
, '$@%[ oRun eins, zwei, drei $]',
, '$@% oRun - "-eins", "zwei", drei' ,
, '$@%[ oRun - "-eins", "zwei", drei $]'
return
endProcedure tstCompORu2
tstCompORuRe: procedure expose m.
/*
$=/tstCompORuRe/
### start tst tstCompORuRe ########################################
compile @, 9 lines: $$ primary $-^oRuRe eins, zwei
run without input
primary oRuRe(arg=1, v2=, v3=) eins, zwei
oRuRe(arg=2, v2=expr, zwei, v3=)
oRuRe(arg=3, v2=-expr, v3=zwei)
oRuRe(arg=2, v2=block, zwei, v3=)
oRuRe(arg=3, v2=-block, v3=zwei)
$/tstCompORuRe/ */
call compIni
call vPut 'oRuRe', oRunner('parse arg , v2, v3;',
'return "oRuRe(arg="arg()", v2="v2", v3="v3")"' )
call tstComp1 '@ tstCompORuRe',
, '$$ primary $-^oRuRe eins, zwei' ,
, '$$-^ oRuRe expr, zwei',
, '$$-^ oRuRe - "-expr", "zwei"',
, '$$-^[oRuRe block, zwei$]' ,
, '$$-^[',, 'oRuRe - "-block", "zwei"' , , '$]'
return
endProcedure tstCompORuRe
tstCompDataIO: procedure expose m.
/*
$=/tstCompDataHereData/
### start tst tstCompDataHereData #################################
compile =, 13 lines: herdata $@#/stop/ .
run without input
. herdata .
heredata 1 $x
heredata 2 $y
nach heredata
. herdata [ .
heredata 1 xValue
heredata 2 yValueY
nach heredata [
. herdata { .
HEREDATA 1 xValue
heredata 2 yValueY
nach heredata {
$/tstCompDataHereData/ */
call tstComp1 '= tstCompDataHereData',
, ' herdata $@#/stop/ ',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata',
, ' herdata [ $@=/stop/ ',
, '$=x=xValue$=y=yValueY',
, 'heredata 1 $x',
, 'heredata 2 $y',
, '$/stop/ $$ nach heredata [',
, ' herdata { $@/st/',
, '; call out heredata 1 $x',
, '$$heredata 2 $y',
, '$/st/ $$ nach heredata {'
/*
$=/tstCompDataIO/
### start tst tstCompDataIO #######################################
compile =, 5 lines: input 1 $@.<-=[$dsn $*+.
run without input
. input 1 .
readInp line 1 .
readInp line 2 .
. nach dsn input und nochmals mit & .
readInp line 1 .
readInp line 2 .
. und schluiss..
$/tstCompDataIO/ */
dsn = word(tstPdsMbr(tstFilename('lib37', 'r'), 'readInp'), 1)
dsnFB = strip(dsn tstFB('::F37', 0))
b = jBuf(tstFB('readInp line 1', 37),
,tstFB('readInp line 2', 37))
extFd = tstFB('&dsn('dsn') dd(xyz)', 0)
extFd = tstFB(dsn 'dd(xyz) ::f', 0)
if extFd = '' then
extFd = dsn
call jCat file(dsnFB), b
call vPut 'dsn', dsn
say 'dsn' dsn 'extFD' extFD'?'
call tstComp1 '= tstCompDataIO',
, ' input 1 $@.<-=[$dsn $*+',
, tstFB('::f', 0) '$]',
, ' nach dsn input und nochmals mit & ' ,
, ' $@.<'extFD,
, ' und schluiss.'
return
endProcedure tstCompDataIO
tstObjVF: procedure expose m.
parse arg v, f
obj = oNew(classNew('n? TstClassVF u v, f FLD1 v'))
m.obj = if(f=='','val='v, v)
m.obj.fld1 = if(f=='','FLD1='v, f)
return obj
endProcedure tstObjVF
tstCompFile: procedure expose m.
/*
$=/tstCompFileBloSrc/
$=vv=value-of-vv
###file from empty # block
$@<#[
$]
###file from 1 line # block
$@<#[
the only $ix+1/0 line $vv
$]
###file from 2 line # block
$@<#[
first line /0 $*+ no comment
second and last line $$ $wie
$]
===file from empty = block
$@<=[ $*+ comment
$]
===file from 1 line = block
$@<=[ the only line $]
===file from 2 line = block
$@<=[ first line$** comment
second and last line $]
---file from empty - block
$@<-/s/
$/s/
---file from 1 line - block
$@<-/s/ the only "line" (1*1) $/s/
---file from 2 line = block
$@<-// first "line" (1+0)
second and "last line" (1+1) $//
...file from empty . block
$@<.[
$]
...file from 1 line . block
$@<.[ tstObjVF('v-Eins', '1-Eins') $]
...file from 2 line . block
$@<.[ tstObjVF('v-Elf', '1-Elf')
tstObjVF('zwoelf') $]
...file from 3 line . block
$@<.[ tstObjVF('einUndDreissig')
s2o('zweiUndDreissig' o2String($.-vv))
tstObjVF('dreiUndDreissig') $]
@@@file from empty @ block
$@<@[
$]
$=noOutput=before
@@@file from nooutput @ block
$@<@[ nop
$=noOutput = run in block $]
@@@nach noOutput=$noOutput
@@@file from 1 line @ block
$@<@[ $$. tstObjVF('w-Eins', 'w1-Eins') $]
@@@file from 2 line @ block
$@<@[ $$. tstObjVF('w-Elf', 'w1-Elf')
y='zwoelf' $$- y $]
@@@file from 3 line @ block
$@<@[ $$. tstObjVF('w einUndDreissig') $$ +
zweiUndDreissig $$ 33 $vv$]
{{{ empty [ block
$@<[ $]
{{{ empty [ block with comment
$@<[ $*+ abc
$]
{{{ one line [ block
$@<[ the only $"[...$]" line $*+.
$vv $]
{{{ one line -[ block
$@<-[ the only $"-[...$]" "line" $vv $]
{{{ empty #[ block
$@<#[
$]
{{{ one line #[ block
$@<#[ the only $"-[...$]" "line" $vv $[vv${x}$]
$]
$/tstCompFileBloSrc/ */
/*
$=/tstCompFileBlo/
### start tst tstCompFileBlo ######################################
compile =, 72 lines: $=vv=value-of-vv
run without input
###file from empty # block
###file from 1 line # block
the only $ix+1/0 line $vv
###file from 2 line # block
first line /0 $*+ no comment
second and last line $$ $wie
===file from empty = block
===file from 1 line = block
. the only line .
===file from 2 line = block
. first line
second and last line .
---file from empty - block
---file from 1 line - block
THE ONLY line 1
---file from 2 line = block
FIRST line 1
SECOND AND last line 2
...file from empty . block
...file from 1 line . block
tstR: @tstWriteoV1 isA :TstClassVF = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @tstWriteoV2 isA :TstClassVF = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @tstWriteoV3 isA :TstClassVF = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @tstWriteoV4 isA :TstClassVF = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @tstWriteoV5 isA :TstClassVF = val=dreiUndDreissig
tstR: .FLD1 = FLD1=dreiUndDreissig
@@@file from empty @ block
@@@file from nooutput @ block
@@@nach noOutput=run in block
@@@file from 1 line @ block
tstR: @tstWriteoV6 isA :TstClassVF = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @tstWriteoV7 isA :TstClassVF = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @tstWriteoV8 isA :TstClassVF = val=w einUndDreissig
tstR: .FLD1 = FLD1=w einUndDreissig
zweiUndDreissig
33 value-of-vv
{{{ empty [ block
{{{ empty [ block with comment
{{{ one line [ block
. the only [...$] line value-of-vv .
{{{ one line -[ block
THE ONLY -[...$] line value-of-vv
{{{ empty #[ block
{{{ one line #[ block
. the only $"-[...$]" "line" $vv $[vv${x}$]
$/tstCompFileBlo/ */
call tstComp2 'tstCompFileBlo', '='
m.t.trans.0 = 0
/*
$=/tstCompFileObjSrc/
$=vv=value-vv-1
$=fE=<[ $]
$=f2=. $.<.[s2o("f2 line 1" o2String($.-vv))
tstObjVF("f2 line2") $]
---empty file $"$@<$fE"
$@fE
---file with 2 lines $"$@<$f2"
$@.<.f2
$=vv=value-vv-2
---file with 2 lines $"$@<$f2"
$@.<.f2
$= dsn =- word(tstPdsMbr(tstFilename('libvb', 'r'), 'fileObj'),1) +
tstFB('::V', 0)
$@[
fi=jOpen(file($dsn),'>')
call jWrite fi, 'line one on' $"$dsn"
call jWrite fi, 'line two on' $"$dsn"
call jClose fi
$]
---file on disk out
$@<-dsn
$/tstCompFileObjSrc/ */
/*
$=/tstCompFileObj/
### start tst tstCompFileObj ######################################
compile =, 20 lines: $=vv=value-vv-1
run without input
---empty file $@<$fE
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-1
tstR: @tstWriteoV1 isA :TstClassVF = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file on disk out
line one on $dsn
line two on $dsn
$/tstCompFileObj/ */
call tstComp2 'tstCompFileObj', '='
return
endProcedure tstCompFile
tstCompPipe: procedure expose m.
/*
$=/tstCompPipe1/
### start tst tstCompPipe1 ########################################
compile @, 1 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
(1 eins zwei drei 1)
#jIn 2# zehn elf zwoelf?
(1 zehn elf zwoelf? 1)
#jIn 3# zwanzig 21 22 23 24 ... 29|
(1 zwanzig 21 22 23 24 ... 29| 1)
#jIn eof 4#
$/tstCompPipe1/ */
call tstComp1 '@ tstCompPipe1 3',
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPipe2/
### start tst tstCompPipe2 ########################################
compile @, 2 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
[2 (1 eins zwei drei 1) 2]
[2 (1 zehn elf zwoelf? 1) 2]
[2 (1 zwanzig 21 22 23 24 ... 29| 1) 2]
$/tstCompPipe2/ */
call tstComp1 '@ tstCompPipe2 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "[2 ", " 2]"'
/*
$=/tstCompPipe3/
### start tst tstCompPipe3 ########################################
compile @, 3 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 [2 (1 eins zwei drei 1) 2] 3>
<3 [2 (1 zehn elf zwoelf? 1) 2] 3>
<3 [2 (1 zwanzig 21 22 23 24 ... 29| 1) 2] 3>
$/tstCompPipe3/ */
call tstComp1 '@ tstCompPipe3 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| call pipePreSuf "[2 ", " 2]"',
, ' $| call pipePreSuf "<3 ", " 3>"'
/*
$=/tstCompPipe4/
### start tst tstCompPipe4 ########################################
compile @, 7 lines: call pipePreSuf "(1 ", " 1)"
run without input
#jIn eof 1#
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<3 [222 [221 [21 [20 (1 eins zwei drei 1) 20] 21] 221] 222] 3>
<3 [222 [221 [21 [20 (1 zehn elf zwoelf? 1) 20] 21] 221] 222] 3>
<3 [222 [221 [21 [20 (1 zwanzig 21 22 23 24 ... 29| 1) 20] 21] 221]+
. 222] 3>
$/tstCompPipe4/ */
call tstComp1 '@ tstCompPipe4 3',
, ' call pipePreSuf "(1 ", " 1)"' ,
, ' $| $@[ call pipePreSuf "[20 ", " 20]"',
, ' $| call pipePreSuf "[21 ", " 21]"',
, ' $| $@[ call pipePreSuf "[221 ", " 221]"',
, ' $| call pipePreSuf "[222 ", " 222]"',
, '$] $] ',
, ' $| call pipePreSuf "<3 ", " 3>"'
return
endProcedure tstCompPipe
tstCompPip2: procedure expose m.
/*
$=/tstCompPip21/
### start tst tstCompPip21 ########################################
compile @, 3 lines: $<[ zeile eins .
run without input
(1 zeile eins 1)
(1 zeile zwei 1)
run with 3 inputs
(1 zeile eins 1)
(1 zeile zwei 1)
$/tstCompPip21/ */
call tstComp1 '@ tstCompPip21 3',
, ' $<[ zeile eins ' ,
, ' zeile zwei $]' ,
, ' call pipePreSuf "(1 ", " 1)"'
/*
$=/tstCompPip22/
### start tst tstCompPip22 ########################################
compile @, 3 lines: if ${>i1} then $@[
run without input
#jIn eof 1#
nachher
run with 3 inputs
#jIn 1# eins zwei drei
<zeile 1: eins zwei drei>
<zwei>
nachher
$/tstCompPip22/ */
call tstComp1 '@ tstCompPip22 3',
, 'if ${>i1} then $@[' ,
, ' $$ zeile 1: $i1 $$ zwei $| call pipePreSuf "<",">" $]',
, ' $$ nachher '
return
endProcedure tstCompPip2
tstCompRedir: procedure expose m.
/*
$=/tstCompRedir/
### start tst tstCompRedir ########################################
compile @, 6 lines: $=eins=<@[ $@for vv $$ <$vv> $] .
run without input
#jIn eof 1#
output eins .
output piped zwei .
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
output eins <eins zwei drei> <zehn elf zwoelf?> +
<zwanzig 21 22 23 24 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz a+
b<zwanzig 21 22 23 24 ... 29|>yz
$/tstCompRedir/ */
call pipeIni
call vRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call vPut 'dsn', dsn
say 'dsn' $dsn
call tstComp1 '@ tstCompRedir 3' ,
, ' $=eins=<@[ $@for vv $$ <$vv> $] ',
, ' $$ output eins $-=[$@.eins$] $; ',
, ' $@for ww $$b${ww}y ' ,
, ' $>-= $-[ $dsn $] 'tstFB('::v', 0),
, '$| call pipePreSuf "a", "z" $<.eins' ,
, ' $; $$ output piped zwei $-=[$@<$-dsn$]'
/*
$=/tstCompRedi2/
### start tst tstCompRedi2 ########################################
compile @, 12 lines: call mAdd t.trans, $var "dsnTestRedi"
run without input
>1<dsnTestRedi currTimeRedi
>2<$"dsnTestRedi" currTimeRedi
>3<$"dsnTestRedi" ::v currTimeRedi
>4<$-var" currTimeRedi
>5<$dsnTestRedi" currTimeRedi
$/tstCompRedi2/
*/
call vPut 'var', tstFileName('compRedi', 'r')
call vPut 'tst', translate(date()'+'time()'+testRedi2', '_', ' ')
call tstComp1 '@ tstCompRedi2 ' ,
, 'call mAdd t.trans, $var "dsnTestRedi"',
, 'call mAdd t.trans, $tst "currTimeRedi"',
, '$<> $>'vGet('var') '::v $$ $">1<'vGet('var')'" $tst',
, '$<> $<'vGet('var') ' $@ call pipeWriteAll' ,
, '$<> $>$"'vGet('var')' ::v" $$ $">2<$""'vGet('var')'""" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>$"'vGet('var')'" ::v $$ $">3<$""'vGet('var')'"" ::v" $tst',
, '$<> $<$"'vGet('var') '" $@ call pipeWriteAll',
, '$<> $>-var $$ $">4<$"-var" $tst',
, '$<> $<-var $@ call pipeWriteAll',
, '$<> $>$var ::v $$ $">5<$"$var" $tst',
, '$<> $<$var $@ call pipeWriteAll'
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
/*
$=/tstCompCompShell/
### start tst tstCompCompShell ####################################
compile @, 5 lines: $$compiling shell $; $= rrr =. $.^compile $<@#/+
aaa/
run without input
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn eof 1#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 2#
run with 3 inputs
compiling shell
running einmal
RUN 1 COMPILED einmal
#jIn 1# eins zwei drei
compRun eins zwei dreieinmal
#jIn 2# zehn elf zwoelf?
compRun zehn elf zwoelf?einmal
#jIn 3# zwanzig 21 22 23 24 ... 29|
compRun zwanzig 21 22 23 24 ... 29|einmal
#jIn eof 4#
running zweimal
RUN 1 COMPILED zweimal
#jIn eof 5#
$/tstCompCompShell/ */
call tstComp1 '@ tstCompCompShell 3',
, "$$compiling shell $; $= rrr =. $.^compile $<@#/aaa/",
, "call out run 1*1*1 compiled $cc;" ,
"$@for v $$ compRun $v$cc" ,
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
/*
$=/tstCompCompData/
### start tst tstCompCompData #####################################
compile @, 5 lines: $$compiling data $; $= rrr =. $.^[compile = +
=$] $<@#/aaa/
run without input
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
run with 3 inputs
compiling data
running einmal
call out run 1*1*1 compiled einmal
running zweimal
call out run 1*1*1 compiled zweimal
$/tstCompCompData/ */
call tstComp1 '@ tstCompCompData 3',
, "$$compiling data $; $= rrr =. $.^[compile = =$] $<@#/aaa/",
, "call out run 1*1*1 compiled $cc",
, "$/aaa/ $;",
, "$=cc=einmal $$ running $cc $@rrr",
, "$=cc=zweimal $$ running $cc $@rrr"
return
endProcedure tstCompComp
tstCompDir: procedure expose m.
/*
$=/tstCompDirSrc/
'in src v1='$v1
$#@ call out 'src @ out v1='$v1
$#. $*(komm$*) s2o('src . v1=')
$.-v1
$#-
'src - v1='$v1
$#=
src = v1=$v1
$/tstCompDirSrc/
$=/tstCompDir/
### start tst tstCompDir ##########################################
compile @call out 'before v1='$v1 $=v1=eins $#. s2o('. v1='$-v1) $#+
@ call out '@ v1='$v1 $#= = v1=$v1 $#- '- v1='$v1 $#-, 8 lines: 'in+
. src v1='$v1
run without input
before v1=v1Before
.. v1=eins
@ v1=eins
= v1=eins .
- v1=eins
in src v1=eins
src @ out v1=eins
src . v1=
eins
src - v1=eins
src = v1=eins
$/tstCompDir/ */
call compIni
call vPut 'v1', 'v1Before'
call tstComp2 'tstCompDir', "@call out 'before v1='$v1 $=v1=eins" ,
"$#. s2o('. v1='$-v1) $#@ call out '@ v1='$v1" ,
"$#= = v1=$v1 $#- '- v1='$v1 $#-"
/*
$=/tstCompDirPiSrc/
zeile 1 v1=$v1
zweite Zeile vor $"$@$#-"
$#@ $@proc pi2 $@-[
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile $]
$/tstCompDirPiSrc/ */
/*
$=/tstCompDirPi/
### start tst tstCompDirPi ########################################
compile @call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#=, 5 lines: ze+
ile 1 v1=$v1
run without input
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
zeile 1 v1=eiPi
zweite Zeile vor $@$#-
$/tstCompDirPi/ */
call tstComp2 'tstCompDirPi',
, "@call pipePreSuf '<','>' $=v1=eiPi $<.pi2 $#="
return
endProcedure tstCompDir
tstCompColon: procedure expose m.
/*
$=/tstCompColon1/
### start tst tstCompColon1 #######################################
compile :, 12 lines: vA = valueVonA
run without input
vA = valueVonA
vA=valueVonA vB=valueVonB vC=valueVonC
vC=valueVonC vD=valueVonD vE=valueVonvE
vF=6
$/tstCompColon1/ */
call tstComp1 ': tstCompColon1',
, 'vA = valueVonA' ,
, ' $$ vA = $vA' ,
, ' * kommentar ' ,
, '=vB=- "valueVonB"' ,
, '=/vC/valueVonC$/vC/' ,
, ' $$ vA=$vA vB=$vB vC=$vC' ,
, '$=/vD/valueVonD' ,
, '$/vD/ vE=valueVonvE' ,
, ' * kommentar ' ,
, ' $$ vC=$vC vD=$vD vE=$vE',
, 'vF=- 2*3 $=vG=@@[ $$ vF=$vF$]' ,
, '@vG'
/*
$=/tstCompColon2/
### start tst tstCompColon2 #######################################
compile :, 7 lines: ix=0
run without input
#jIn eof 1#
proc p1 arg(2) total 0 im argumentchen
run with 3 inputs
#jIn 1# eins zwei drei
#jIn 2# zehn elf zwoelf?
#jIn 3# zwanzig 21 22 23 24 ... 29|
#jIn eof 4#
<<for 1 -> eins zwei drei>>
<<for 2 -> zehn elf zwoelf?>>
<<for 3 -> zwanzig 21 22 23 24 ... 29|>>
proc p1 arg(2) total 3 im argumentchen
$/tstCompColon2/
*/
call tstComp1 ': tstCompColon2 3',
, 'ix=0' ,
, 'for v @:[ix=- $ix+1',
, ' $$ for $ix -> $v' ,
, '] | @[call pipePreSuf "<<",">>"',
, '$] @%[p1 total $ix im argumentchen$]',
, 'proc @:/p1/$$- "proc p1 arg(2)" arg(2)' ,
, '/p1/'
/*
$=/tstCompColon3/
### start tst tstCompColon3 #######################################
compile :, 11 lines: tc3Eins=freeVar1
run without input
tc3Eins=freeVar1 o2&tc3Eins= o2&tc3Zwei=
tc3Eins=freeVar1 o2&tc3Eins=with3Eins o2&tc3Zwei=with3Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
o3&tc3Eins=ass4Eins o3&tc3Zwei=with5 o3 Zwei
tc3Eins=freeVar1 o2&tc3Eins=ass4Eins o2&tc3Zwei=with5Zwei
$/tstCompColon3/
*/
call classNew 'n? TstCompColon3 u f tc3Eins v, f tc3Zwei v'
showO2 = 'tc3Eins=$tc3Eins' ,
'o2&tc3Eins=${o2&tc3Eins} o2&tc3Zwei=${o2&tc3Zwei}'
showO3 = 'o3&tc3Eins=${o3&tc3Eins} o3&tc3Zwei=${o3&tc3Zwei}'
call tstComp1 ': tstCompColon3',
, 'tc3Eins=freeVar1' ,
, 'o2 =. oNew("TstCompColon3")' ,
, '$$' showO2 ,
, 'with $o2 $@:[tc3Eins = with3Eins',
, 'tc3Zwei = with3Zwei',
, '] $$' showO2 ,
, '{o2&tc3Eins} = ass4Eins',
, 'with $o2 $=tc3Zwei = with5Zwei',
, '$$' showO2 ,
, 'with o3 =. oCopy($o2) $=tc3Zwei = with5 o3 Zwei',
, '$$' showO3 '$$' showO2
return
endProcedure tstCompColon
tstCompTable: procedure expose m.
/*
$=/tstCompTable1/
### start tst tstCompTable1 #######################################
compile :, 6 lines: table $*( sdf $*) .
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = v1
tstR: .fZwei = valueZwei undD
tstR: .fDrei = rei
zweite
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = w1 wZwe
tstR: .fZwei = i
tstR: .fDrei = wwwDrei
$/tstCompTable1/
*/
call wshIni
cl = classNew('n* CompTable u f fEins v, f fZwei v, f fDrei v')
c2 = classNew('n* CompTable u f fEins v, f fDrei v')
call tstComp1 ': tstCompTable1',
, 'table $*( sdf $*) ' ,
, 'fEins fZwei $*(....$*) fDrei ' ,
, '$@[call mAdd t.trans, className("'cl'") "<TstCT1Class>"$]',
, ' v1 valueZwei undDrei ' ,
, '$$ zweite',
, ' w1 wZwei wwwDrei '
/*
$=/tstCompWithNew/
### start tst tstCompWithNew ######################################
compile :, 12 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
tstR: @tstWriteoV3 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEinsB
tstR: .fZwei = withNewValue fZweiB
tstR: .fDrei = withNewValue fDreiB
tstR: @tstWriteoV5 isA :<TstCT2Class>
tstR: .fEins = withValue fEinsC
tstR: .fDrei = withValue fDreiC
$/tstCompWithNew/
*/
call tstComp1 ': tstCompWithNew',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, 'fZwei = withNewValue fZwei' ,
, '$@[call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:[ fDrei = withNewValuel drei $] $] ' ,
, 'withNew ' ,
, 'fEins = withNewValue fEinsB' ,
, 'fZwei = withNewValue fZweiB',
, 'fDrei = withNewValue fDreiB',
, 'withNew fEins = withValue fEinsC' ,
, '$@[call mAdd t.trans, className("'c2'") "<TstCT2Class>"',
, '$@[$=fDrei = withValue fDreiC$] $] '
/*
$=/tstCompWithNeRe/
### start tst tstCompWithNeRe #####################################
compile :, 11 lines: withNew
run without input
tstR: @tstWriteoV2 isA :<TstClassR2>
tstR: .rA = value rA
tstR: .rB refTo @]value rB isA :w
tstR: @tstWriteoV4 isA :<TstClassR2>
tstR: .rA = val33 rA
tstR: .rB refTo @]VAL33 RB isA :w
tstR: @tstWriteoV5 isA :<TstClassR2>
tstR: .rA = val22 rA
tstR: .rB refTo @]VAL22 RB isA :w
tstR: @tstWriteoV6 isA :<TstCT1Class>
tstR: .fEins = withNewValue fEins
tstR: .fZwei = withNewValue fZwei
tstR: .fDrei = withNewValuel drei
vOth=value vOth fZwei=fZwei Wert vorher ?fDrei=0
$/tstCompWithNeRe/
*/
cR = classNew("n* CompTable u f rA v, f rB r")
call vRemove 'fDrei'
call vPut 'fZwei', 'fZwei Wert vorher'
call tstComp1 ': tstCompWithNeRe',
, 'withNew' ,
, 'fEins = withNewValue fEins' ,
, '@:[withNew rA =value rA $=rB=. "]value rB" ' ,
, '$@ call mAdd t.trans, className("'cR'") "<TstClassR2>"$]',
, 'fZwei = withNewValue fZwei' ,
, '$@[call mAdd t.trans, className("'cl'") "<TstCT1Class>"',
, '$@:[withNew rA =val22 rA $=rB=. ]val22 rB ' ,
, '{vOth} = value vOth',
, '$@:[withNew rA =val33 rA $=rB=. ]val33 rB $] $]' ,
, '$@:[ fDrei = withNewValuel drei $] $] ',
, '$<> $$ vOth=$vOth fZwei=$fZwei ?fDrei=${?fDrei}'
return
endProcedure tstCompTable
tstCompSql: procedure expose m.
/*
$=/tstCompSqlSrc/
$@=[
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
where creator='SYSIBM' and name like 'SYSTABL%'
order by 2 fetch first 4 rows only
$]
$| call sqlSel
$| call fTabAuto
$/tstCompSqlSrc/
$=/tstCompSql/
### start tst tstCompSql ##########################################
compile @, 9 lines: $@=[
run without input
CR TB RR
SYSIBM SYSTABLEPART 1
SYSIBM SYSTABLEPART_HIST 4
SYSIBM SYSTABLES 9
SYSIBM SYSTABLESPACE 16
$/tstCompSql/
$=/tstCompSqlFTabSrc/
$$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh from sysibm.sysDummy1
$| $@. vPut('lc', sqlRdr(scanSqlIn2Stmt()))
$| call fTab sqlFTabOthers(sqlRdrFTabReset($.lc, tstCompSql1))
$<>
$$ select 'aOh' ahaOhne, 'buuVar' buhVar from sysibm.sysDummy1
$| call sqlSel
$| t2 = fTabReset(sqlRdrFTabReset( , tstCompS2), '2 1', '2 c', '-')
ox = m.t2.0 + 1
call sqlFTabOthers t2
call fTab fTabAddTit(t2, ox, 2, '-----')
$<>
$$ select 'aOh' aDrei, 'buuDre' buhDrei from sysibm.sysDummy1
$| call sql2Tab
$/tstCompSqlFTabSrc/
$=/tstCompSqlFTab/
### start tst tstCompSqlFTab ######################################
compile @, 13 lines: $$ select 'ahaaaax' ahaCol, 'buuuuh' buhhhh fr+
om sysibm.sysDummy1
run without input
AHACOL--BUHHHH---
ahaaaax buuuuh
AHACOL--BUHHHH---
-----
AHA-BUHVAR---
aOh buuVar
-----
AHAOHNE
. BUHVAR
ADREI
. BUHDREI
ADR-BUHDRE---
aOh buuDre
ADR-BUHDRE---
ADREI
. BUHDREI
$/tstCompSqlFTab/
### start tst tstCompSql ##########################################
*/
call sqlConnect
call tstComp2 'tstCompSql', '@'
call tstComp2 'tstCompSqlFTab', '@'
call sqlDisConnect
return
endProcedure tstCompSql
tstTut0: procedure expose m.
/*
$=/tstTut01Src/
$#=
$*+>.fSub() Kommentar
$*+>~tmp.jcl(t) Kommentar
$*+@=[ Kommentar
$=subsys=DP4G
$=db=DA540769
$=ts=A977A
$*+@<~wk.jcl(jc) Kommentar
??* ?-[sysvar(sysnode) date() time()?]ts=$ts 10*len=$-[length($ts)*10$]
//P02 EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
$@[if right($ts, 2) == '7A' then $@=[
FULL YES
$] else
$$ $'' FULL NO
$]
SHRLEVEL CHANGE
$*+] Kommentar
$#out original/src
$/tstTut01Src/
$=/tstTut01/
### start tst tstTut01 ############################################
compile , 28 lines: $#=
run without input
??* ?-[sysvar(sysnode) date() time()?]ts=A977A 10*len=50
//P02 EXEC PGM=DSNUTILB,
// PARM='DP4G,A540769C.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977A* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
FULL YES
SHRLEVEL CHANGE
$/tstTut01/
$=/tstTut02Src/
$#@
$**>.fSub()
$**@[
$=subsys=DP4G
$=db=DA540769
$=jx=0
$@do tx = 976 to 977 $@=[
$=ts=A$tx
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$**]
$#out original/src
$/tstTut02Src/
$=/tstTut02/
### start tst tstTut02 ############################################
compile , 28 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut02/
$=/tstTut03Src/
$#@
$=subsys=DP4G
$@:[table
db ts
DGDB9998 A976
DA540769 A977
$]
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=[
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$#out original/src
$/tstTut03Src/
$=/tstTut03/
### start tst tstTut03 ############################################
compile , 31 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut03/
$=/tstTut04Src/
$#@
$=subsys=DP4G
$=db=DA540769
call sqlConnect $subsys
$@=[ select dbName db , tsName ts
from sysibm.sysTables
where creator = 'SYSIBM' and name like 'SYSINDEXPAR%'
order by name desc
$]
$| call sqlSel
$** $| call fTabAuto
$** $#end
$|
$=jx=0
$@forWith o $@=[
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$TS EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $DB.$TS* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
call sqlDisConnect
$#out original/src
$/tstTut04Src/
$=/tstTut04/
### start tst tstTut04 ############################################
compile , 35 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSHIST EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSHIST * PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CSYSTSIPT EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DSNDB06 .SYSTSIPT* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut04/
$=/tstTut05Src/
$#:
subsys = DP4G
lst =<:[withNew out :[
db = DGDB9998
ts =<:[table
ts
A976
A977
$]
db = DA540769
<|/ts/
ts
A976
A975
/ts/
]
$** $$. $lst
$** $@ct $@[$=tool =. $.compile@ $<~.wk.rexx(wshtut06)$]
$** $@$tool
$@do sx=1 to ${lst.0} $@[
$=db = ${lst.$sx.db}
$** $$. ${lst.$sx}
$@do tx=1 to ${lst.$sx.ts.0} $@=[
$*+ $$. ${lst.$sx.ts.$tx}
$=ts= ${lst.$sx.ts.$tx.ts}
$@[ say $-=[subsys $subsys db $db ts $ts $] $]
$@copy()
$]
$]
$@ct $@[
cl = classNew('n? DbTsList u s' ,
classNew('n? DbTs u f db v, f ts s' ,
classNew('n? Ts u f ts v')))
$=lst=. oNew(cl)
$]
$@proc copy $@=[
$@ct $=jx=0
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//C$ts EXEC PGM=DSNUTILB,
// PARM='$subsys,A540769$jx.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=$subsys.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE $db.$ts* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$]
$#out original/src
$/tstTut05Src/
$=/tstTut05/
### start tst tstTut05 ############################################
compile , 56 lines: $#@
run without input
//A5407691 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407691.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407692 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA977 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407692.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DGDB9998.A977* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407693 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA976 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407693.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A976* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
//A5407694 JOB (CP00,KE50),'DB2 REO',
// MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//CA975 EXEC PGM=DSNUTILB,
// PARM='DP4G,A5407694.FULCOPL'
//SYSPRINT DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//SYSTEMPL DD DSN=DP4G.DBAA.LISTDEF(TEMPL),DISP=SHR
//SYSIN DD *
LISTDEF C#LIST
INCLUDE TABLESPACE DA540769.A975* PARTLEVEL
OPTIONS EVENT(ITEMERROR, SKIP)
COPY LIST C#LIST COPYDDN(TCOPYD)
PARALLEL
SHRLEVEL CHANGE
$/tstTut05/
tstTut06 ==> platz für copy aus tut05
$=/tstTut07Src/
$**$>.fEdit()
call sqlConnect dp4g
$@:[table
ts
VTCASHFLOW
VTCASHFLOWAMOUNT
VTINSTRFLATDATA
$]
$| $@=[
select name, statstime, strip(dbName) || '.' || strip(tsName) dbts
from sysibm.sysTables
where creator = 'VDPS2' and name in
$=co=(
$@forWith t $@=[
$co '$ts'
$=co=,
$]
)
$]
$| call sqlSel
$** $| call fTabAuto
$|
$=jx=0
$@forWith t $@=[
$=jx=- $jx+1
//A540769$jx JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP$jx EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A540769$jx.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE $DBTS
OPTIONS EVENT (ITEMERROR, SKIP)
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$]
call sqlDisconnect
$#out original/src
$/tstTut07Src/
$=/tstTut07/
$=/tstTut07/
### start tst tstTut07 ############################################
compile , 47 lines: $**$>.fEdit()
run without input
//A5407691 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP1 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407691.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV27A1T.VDPS329
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407692 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP2 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407692.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV28A1T.VDPS390
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
//A5407693 JOB (CP00,KE50),
// 'CATALOG',MSGCLASS=T,TIME=1440,
// NOTIFY=&SYSUID,REGION=0M
//STEP3 EXEC PGM=DSNUTILB,TIME=1440,
// PARM=(DP4G,'A5407693.RUNSTA'),
// REGION=0M
//SYSPRINT DD SYSOUT=*
//SYSUDUMP DD SYSOUT=*
//UTPRINT DD SYSOUT=*
//SYSOUT DD SYSOUT=*
//RNPRIN01 DD SYSOUT=*
//SYSIN DD *
LISTDEF LST#STA INCLUDE TABLESPACE VV21A1T.VDPS004
OPTIONS EVENT (ITEMERROR, SKIP)
..
RUNSTATS TABLESPACE LIST LST#STA
SHRLEVEL CHANGE
INDEX(ALL KEYCARD)
REPORT YES UPDATE ALL
$/tstTut07/
$=/tstTut08Src/
$/tstTut08Src/
$=/tstTut08/
$/tstTut08/
*/
call sqlIni
call sqlDisconnect '*'
call tstComp2 'tstTut01'
call tstComp2 'tstTut02'
call tstComp2 'tstTut03'
if m.err.os == 'TSO' then do
call tstComp2 'tstTut04'
/* call tstComp2 'tstTut05' */
/* call tstComp2 'tstTut07' ???? anderes Beispiel ???? */
end
call tstTotal
return
endProcedure tstTut0
/****** tstBase ********************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call tstM
call tstUtc2d
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstClass3
call tstClass4
call tstO
call oIni
call tstF
call tstFWords
call tstFtst
call tstFCat
call tstOEins
call tstO2Text
call jIni
call tstJSay
call tstJ
call tstJ2
call tstScanSqlStmt
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstPipeS
call tstEnvVars
call tstvWith
call tstTotal
call tstPipeLazy
call tstEnvClass
if m.tst_csm then
call tstDsnEx
call tstFile
call tstFileList
call tstMbrList
call tstFE
call tstFTab
call tstFmt
call tstfUnits
call tstCsv
call tstTotal
call tstSb
call tstSb2
call tstScan
call ScanReadIni
call tstScanRead
call tstScanUtilInto
call tstScanWin
call tstScanSQL
call tstTotal
return
endProcedure tstBase
/*--- test the tst Module, check the output visually ----------------*/
tstTstSay: procedure expose m.
call tstIni
oldErr = m.tst.err
oldNames = m.tst.errNames
say '+++ tstTstSay start with' oldErr 'totErrs and',
m.tst.tests 'tests'
/*
$=/tstTstSayEins/
### start tst tstTstSayEins #######################################
test eins einzige testZeile
$/tstTstSayEins/
$=/tstTstSayZwei/
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
$/tstTstSayZwei/
$=/tstTstSayDrei/
### start tst tstTstSayDrei #######################################
drei 1. testZeile vor empty Zeile
..
drei 3. testZeile vor 10 space
. .
drei 5. testZeile ziemlich lang 66 +
. 77 5 10 15++++++++++++++++++++
.+++++++++++++++++++++++++++++++++++++++++++.
$/tstTstSayDrei/
*/
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x, 'err 0'
call tst x, 'tstTstSayZwei'
call tstOut x, "zwei 1. testZeile " /* ein space zuviel */
call tstOut x, "zwei 2. und letzte testZeile"
call tstOut x, "zwei 3. zuviel"
call tstEnd x, 'err 3'
call tst y, 'tstTstSayDrei'
call tstOut y, 'drei 1. testZeile vor empty Zeile'
call tstOut y, ''
call tstOut y, 'drei 3. testZeile vor 10 space'
call tstOut y, left('', 10)
call tstOut y, 'drei 5. testZeile ziemlich lang',
left(66, 66) left('77 5 10 15', 77, '+')
call tstEnd y, 'err 0'
if m.y.err <> 0 then
call err '+++ tstTstSay errs' m.x.err 'expected' 0
if m.tst.err <> oldErr + 3 then
call err '+++ tstTstSay totErrs' m.tst.err 'expected' 3
say '+++ tstTstSay end Ok with' m.tst.err 'totErrs and' ,
m.tst.tests 'tests'
m.tst.err = oldErr
m.tst.errNames = oldNames
return
endProcedure tstTstSay
tstMark: procedure expose m.
parse arg m, msg
if symbol('m.m') == 'VAR' then
m.m = msg';' m.m
else
m.m = msg 'new'
return m
endProcedure tstMark
tstM: procedure expose m.
/*
$=/tstMa/
### start tst tstMa ###############################################
mNew() 1=newM1 2=newM2
mNew(tst...) 2=2 new 3=4; 3; 1 new 4=5 new
iter 4; 3; 1 new
iter 2 new
iter 5 new
$/tstMa/
*/
call tst t, 'tstMa'
m1 = mNew()
m2 = mNew()
m.m1 = 'newM1'
m.m2 = 'newM2'
call tstOut t, 'mNew() 1='m.m1 '2='m.m2
call mNewArea 'tst'm1
t1 = tstMark(mNew('tst'm1), '1')
t2 = tstMark(mNew('tst'm1), '2')
call mFree tstMark(t1, '3')
t3 = tstMark(mNew('tst'm1), '4')
t4 = tstMark(mNew('tst'm1), '5')
call tstOut t, 'mNew(tst...) 2='m.t2 '3='m.t3 '4='m.t4
i = mIterBegin('tst'm1)
do while assNN('i', mIter(i))
call tstOut t, 'iter' m.i
end
call tstEnd t
/*
$=/tstM/
### start tst tstM ################################################
symbol m.b LIT
symbol m.a LIT
mAdd a A.2
mAdd a A.3
m.a: 3: 1=eins 2=zwei 3=drei 4=M.A.4
m.c: 5: 1=c vorAddSt a 2=eins 3=zwei 4=drei 5=c nacAddSt a 6=M.C.6
$/tstM/ */
drop m.b m.a m.a.0 m.a.1 m.a.2
call tst t, 'tstM'
call tstOut t, 'symbol m.b' symbol('m.b')
m.b = 1
call tstOut t, 'symbol m.a' symbol('m.a')
call tstOut t, 'mAdd a' mAdd(mCut(a, 0), 'eins', 'zwei')
call tstOut t, 'mAdd a' mAdd(a, 'drei')
call tstOut t, 'm.a:' m.a.0': 1='m.a.1 '2='m.a.2 '3='m.a.3 '4='m.a.4
call mAdd mCut(c, 0), 'c vorAddSt a'
call mAddSt c, a
call mAdd c, 'c nacAddSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3,
'4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstFCat: procedure expose m.
/*
$=/tstFCat/
### start tst tstFCat #############################################
fCat( ,0) =;
fCat(1 ,0) =;
fCat(112222 ,0) =;
fCat(3%#a1%c2 ,0) =;
fCat(4%#a1%c2@%c333 ,0) =;
fCat(5%#a1%c2@%c3@%c4 ,0) =;
fCat( ,1) =eins;
fCat(1 ,1) =eins;
fCat(112222 ,1) =eins;
fCat(3%#a1%c2 ,1) =1eins2;
fCat(4%#a1%c2@%c333 ,1) =1eins2eins333;
fCat(5%#a1%c2@%c3@%c4 ,1) =1eins2eins3eins4;
fCat( ,2) =einszwei;
fCat(1 ,2) =eins1zwei;
fCat(112222 ,2) =eins112222zwei;
fCat(3%#a1%c2 ,2) =1eins231zwei2;
fCat(4%#a1%c2@%c333 ,2) =1eins2eins33341zwei2zwei333;
fCat(5%#a1%c2@%c3@%c4 ,2) =1eins2eins3eins451zwei2zwei3zwei4;
fCat( ,3) =einszweidrei;
fCat(1 ,3) =eins1zwei1drei;
fCat(112222 ,3) =eins112222zwei112222drei;
fCat(3%#a1%c2 ,3) =1eins231zwei231drei2;
fCat(4%#a1%c2@%c333 ,3) =1eins2eins33341zwei2zwei33341drei2dr+
ei333;
fCat(5%#a1%c2@%c3@%c4 ,3) =1eins2eins3eins451zwei2zwei3zwei451d+
rei2drei3drei4;
$/tstFCat/ */
call pipeIni
call tst t, "tstFCat"
m.qq.1 = "eins"
m.qq.2 = "zwei"
m.qq.3 = "drei"
do qx = 0 to 3
m.qq.0 = qx
call tstFCat1 qx
call tstFCat1 qx, '1'
call tstFCat1 qx, '112222'
call tstFCat1 qx, '3%#a1%c2'
call tstFCat1 qx, '4%#a1%c2@%c333'
call tstFCat1 qx, '5%#a1%c2@%c3@%c4'
end
call tstEnd t
return
endProcedure tstFCat
tstFCat1: procedure expose m.
parse arg m.qq.0, fmt
call out left("fCat("fmt, 26)","m.qq.0") ="fCat(fmt, qq)";"
return
endProcedure tstFCat1
tstMap: procedure expose m.
/*
$=/tstMap/
### start tst tstMap ##############################################
mapNew m keys m-keys 0
map m zwei --> 2
map m Zwei is not defined
map stem m-keys 4
map m eins --> 1
map m zwei --> 2
map m drei --> 3
map m vier --> 4
*** err: duplicate in mapAdd(m, eins, 1)
map m zwei is not defined
q 2 zw dr
map stem Q 2
map Q zw --> 2Q
map Q dr --> 3Q
map stem m 3
map m eins --> 1
map m zwei --> 2PUT
map m vier --> 4PUT
*** err: duplicate in mapAdd(m, zwei, 2ADDDUP)
tstMapLong eins keys 3
tstMapLong zweiMal keys 48
tstMapLong dreiMal keys 93
tstMapLong vier keys 138
tstMapLong <fuenf> keys 188
tstMap clear keys 0
inline1 3
inline1 1 == inline1 eins==
inline1 2 ====
inline1 3 == inline1 drei==
inline2 1 1 == inline2 eins==
inline3 ?
$/tstMap/ */
/*
$=/tstMapInline1/
inline1 eins
inline1 drei
$/tstMapInline1/ */
/*
$=/tstMapInline2/
inline2 eins
$/tstMapInline2/ */
call tst t, 'tstMap'
m = mapNew('K')
ky = mapKeys(m)
call mAdd t'.TRANS', m 'm', ky 'm-keys'
call tstOut t, 'mapNew' m 'keys' ky m.ky.0
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapAdd m, 'drei', 3
call mapAdd m, 'vier', 4
call tstMapShow m, 'zwei'
call tstMapShow m, 'Zwei'
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'eins', 1
call mapReset m, '='
call tstMapShow m, 'zwei'
call mapAdd m, 'eins', 1
call mapAdd m, 'zwei', 2
call mapPut m, 'zwei', 2Put
call mapPut m, 'vier', 4Put
call mapReset q, '='
call mapAdd q, 'zw', 2q
call mapAdd q, 'dr', 3q
call tstOut t, 'q' m.q.0 m.q.1 m.q.2
call tstMapShowSt q, mapKeys(q)
call tstMapShowSt m, mapKeys(m)
call mapAdd m, 'zwei', 2addDup
call tstMapLong m, 'eins' ,201, 2000, -2, 2
call tstMapLong m, 'zweiMal' ,201, 2000, -2, 2
call tstMapLong m, 'dreiMal' ,201, 2000, 2,-2
call tstMapLong m, 'vier ' ,2010, 201, -2, 2
call tstMapLong m, '<fuenf>' ,2010, 201, 2,-2
call mapClear m
keys = mapKeys(m)
call tstOut t, 'tstMap clear keys' m.keys.0
i = mapInline('tstMapInline1')
call tstOut t, 'inline1' m.i.0
do x=1 to m.i.0
call tstOut t, 'inline1' x '=='m.i.x'=='
end
i = mapInline('tstMapInline2')
call tstOut t, 'inline2' m.i.0 '1 =='m.i.1'=='
call tstOut t, 'inline3' mapInline('tstMapInline3', 'r')'?'
call tstEnd t
return
endProcedure tstMap
tstMapLong: procedure expose m.
parse arg m, w, f1, t1, f2, t2
if f1 < t1 then
b1 = 201
else
b1 = -201
if f2 < t2 then
b2 = 1
else
b2 = -1
lo = copies(w, 2100 % length(w))
keys = mapKeys(m)
keyCn = m.keys.0
call tstOut t, 'tstMapLong' w 'keys' keyCn
do x = f1 by b1 to t1
do y = x+f2 by b2 to x+t2
k = left(lo, y)
if mapHasKey(m, k) then
call err 'mapLong hasKey before' w y
call mapAdd m, k, w y
if \ mapHasKey(m, k) then
call err 'mapLong \ hasKey after' w y
if mapGet(m, k) \== w y then
call err 'mapLong \ get <> ' w y
keys = mapKeys(m)
if keyCn + 1 \= m.keys.0 then
call err 'mapLong keys .0 <> ' w y
keyCn = m.keys.0
if k \== m.keys.keyCn then
call err 'mapLong keys . ' keyCn '<>' w y
end
end
return
endProcedure tstMapLong
tstMapVia: procedure expose m.
/*
$=/tstMapVia/
### start tst tstMapVia ###########################################
map M K --> A
mapVia(m, K) A
*** err: missing m.A at 3 in mapVia(M, K|)
mapVia(m, K|) M.A
mapVia(m, K|) valAt m.a
mapVia(m, K|) valAt m.a
*** err: missing m.A.aB at 5 in mapVia(M, K|aB)
mapVia(m, K|aB) M.A.aB
mapVia(m, K|aB) valAt m.A.aB
*** err: missing m.valAt m.a at 4 in mapVia(M, K||)
mapVia(m, K||) M.valAt m.a
mapVia(m, K||) valAt m.valAt m.a
mapVia(m, K||F) valAt m.valAt m.a.F
$/tstMapVia/ */
call tst t, 'tstMapVia'
u = 'A.aB'
v = 'valAt m.a'
drop m.a m.u m.v m.v.f
call mapReset m, 'K'
call mapAdd m, k, a
call tstMapShow m, k
call tstOut t, 'mapVia(m, K) ' mapVia(m, 'K')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
m.a = v
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|) ' mapVia(m, 'K|')
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
m.u = 'valAt m.'u
call tstOut t, 'mapVia(m, K|aB) ' mapVia(m, 'K|aB')
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
v = m.a
m.v = 'valAt m.'v
m.v.f = 'valAt m.'v'.F'
call tstOut t, 'mapVia(m, K||) ' mapVia(m, 'K||')
call tstOut t, 'mapVia(m, K||F) ' mapVia(m, 'K||F')
call tstEnd t
return
endProcedure tstMapVia
tstMapShow: procedure expose m.
parse arg a, key
if mapHasKey(a, key) then
call tstOut t, 'map' a key '-->' mapGet(a, key)
else
call tstOut t, 'map' a key 'is not defined'
return
endProcedure tstMapShow
tstMapShowSt: procedure expose m.
parse arg a, st
call tstOut t, 'map stem' st m.st.0
do wx=1 to m.st.0
call tstMapShow a, m.st.wx
end
return
endProcedure tstMapShow
tstClass2: procedure expose m.
/*
$=/tstClass2/
### start tst tstClass2 ###########################################
@CLASS.9 :class = u
. choice u union
. .NAME = class
. stem 8
. .1 refTo @CLASS.3 :class = u
. choice u union
. .NAME = v
. stem 2
. .1 refTo @CLASS.1 :class = m
. choice m union
. .NAME = o2String
. .MET = return m.m
. stem 0
. .2 refTo @CLASS.2 :class = m
. choice m union
. .NAME = o2File
. .MET = return file(m.m)
. stem 0
. .2 refTo @CLASS.12 :class = c
. choice c union
. .NAME = u
. stem 1
. .1 refTo @CLASS.11 :class = u
. choice u union
. .NAME = .
. stem 1
. .1 refTo @CLASS.10 :class = f
. choice f union
. .NAME = NAME
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .3 refTo @CLASS.13 :class = c
. choice c union
. .NAME = f
. stem 1
. .1 refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.15 :class = c
. choice c union
. .NAME = s
. stem 1
. .1 refTo @CLASS.14 :class = u
. choice u union
. .NAME = .
. stem 0
. .5 refTo @CLASS.16 :class = c
. choice c union
. .NAME = c
. stem 1
. .1 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.17 :class = c
. choice c union
. .NAME = r
. stem 1
. .1 refTo @CLASS.14 done :class @CLASS.14
. .7 refTo @CLASS.20 :class = c
. choice c union
. .NAME = m
. stem 1
. .1 refTo @CLASS.19 :class = u
. choice u union
. .NAME = .
. stem 2
. .1 refTo @CLASS.10 done :class @CLASS.10
. .2 refTo @CLASS.18 :class = f
. choice f union
. .NAME = MET
. stem 1
. .1 refTo @CLASS.3 done :class @CLASS.3
. .8 refTo @CLASS.22 :class = s
. choice s union
. stem 1
. .1 refTo @CLASS.21 :class = r
. choice r union
. stem 1
. .1 refTo @CLASS.9 done :class @CLASS.9
$/tstClass2/
*/
call classIni
call tst t, 'tstClass2'
call classOut m.class_C, m.class_C
call tstEnd t
return
endProcedure tstClass2
tstClass3: procedure expose m.
/*
$=/tstClass3/
### start tst tstClass3 ###########################################
met v#o2String return m.m
met w#o2String return substr(m, 2)
met w#o2String return substr(m, 2)
*** err: no method nonono in class w
met w#nonono 0
t1 4 flds FV, FR
clear q1 FV= FR= FW=] FO=
orig R1 FV=valFV FR=refFR FW=]valFW FO=obj.FO
copy <s1> FV=valFV FR=refFR FW=]valFW FO=obj.FO
t2 2 flds , EINS.ZWEI
clear q2 EINS.ZWEI= val=
orig R2 EINS.ZWEI=valR2.eins.zwei val=valR2Self
copy <s2> EINS.ZWEI=valR2.eins.zwei val=valR2Self
t3 0 flds M.<class tst...Tf33>.FLDS.1, M.<class tst...Tf33>.FLDS.2
clear q3 s1.0=0
orig R3 s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1.1+
..s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
copy <s3> s1.0=1 s1.1=M.R3.S1.1 s1.1.f1=M.R3.S1.1.F1 s1.1.s2.0=2 s1+
..1.s2.1.f2=M.R3.S1.1.S2.1.F2 s1.1.s2.2.f2=M.R3.S1.1.S2.2.F2
$/tstClass3/ */
call oIni
call tst t, 'tstClass3'
call mAdd t.trans, m.class_C '<class class>'
call tstOut t, 'met v#o2String' classMet(m.class_V, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#o2String' classMet(m.class_W, 'o2String')
call tstOut t, 'met w#nonono' classMet(m.class_W, 'nonono')
all = classNew('n? tstClassTf31 u f FV v, f FR r, f FW w, f FO o'),
classNew('n? tstClassTf32 u f EINS f ZWEI v, v') ,
classNew('n? tstClassTf33 u f S1' classNew('s u v, f F1 v,',
'f S2 s f F2 v'))
call mAdd t.trans, word(all, 3) '<class tst...Tf33>'
m.r1.fv = 'valFV'
m.r1.fr = 'refFR'
m.r1.fw = ']valFW'
m.r1.fo = 'obj.FO'
m.r2 = 'valR2Self'
m.r2.eins.zwei = 'valR2.eins.zwei'
m.r3.s1.0 = 1
m.r3.s1.1.s2.0 = 2
o.1 = "q 'FV='m.q.FV 'FR='m.q.fr 'FW='m.q.fw 'FO='m.q.fo"
o.2 = "q 'EINS.ZWEI='m.q.EINS.zwei 'val='m.q"
o.3 = "q 's1.0='m.q.s1.0"
p.1 = o.1
p.2 = o.2
p.3 = "q 's1.0='m.q.s1.0 's1.1='m.q.s1.1 's1.1.f1='m.q.s1.1.f1" ,
"'s1.1.s2.0='m.q.s1.1.s2.0 's1.1.s2.1.f2='m.q.s1.1.s2.1.f2",
"'s1.1.s2.2.f2='m.q.s1.1.s2.2.f2"
do tx=1 to words(all)
t1 = word(all, tx)
u1 = classFlds(t1)
q = 'q'tx
call tstOut t, 't'tx m.u1.0 'flds' m.u1.1',' m.u1.2
call utInter("m='"q"';" classMet(t1, 'oClear'))
interpret "call tstOut t, 'clear'" o.tx
q = 'R'tx
interpret "call tstOut t, 'orig'" p.tx
q = utInter("m='"q"';t='';" classMet(t1, 'oCopy'))
call mAdd t.trans, q '<s'tx'>'
interpret "call tstOut t, 'copy'" p.tx
end
call tstEnd t
return
endProcedure tstClass3
tstClass: procedure expose m.
/*
$=/tstClass/
### start tst tstClass ############################################
Q u =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: bad type v: classNew(v tstClassTf12)
*** err: missing key in mapGet(CLASS_N2C, 0)
R u =className= uststClassTf12
R u =className= uststClassTf12in
R u =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1 :CLASS.7
R.1 u =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2 :CLASS.7
R.2 u =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S u =className= TstClass7
S s =stem.0= 2
S.1 u =className= TstClass7s
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
S.2 u =className= TstClass7s
S.2.zwei v ==> M.S.2.zwei
S.2 m =met-metA--> say "metA"
S.2 m =met-metB--> say "metB"
class of mutate qq tstClassTf12
$/tstClass/ */
f = 'eins.zwei'
e = 'eins'
z = 'zwei'
drop m.q.f m.r.f m.r.0 m.r.1 m.r.1.f m.r.2 m.r.2.f
drop m.s.0 m.s.1 m.s.1.e m.s.2 m.s.2.z
call classIni
call tst t, 'tstClass'
t1 = classNew('n? tstClassTf12 u f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
if class4name('tstClassB', '') == '' then do
t2 = classNew('n tstClassB u n tstClassC u tstClassTf12,',
's u v tstClassTf12')
end
else do /* the second time we would get a duplicate error */
call tstOut t, '*** err: bad type v: classNew(v tstClassTf12)'
call tstOut t, '*** err: missing key in mapGet(CLASS_N2C, 0)'
end
t2 = classNew('n? uststClassTf12 u' ,
'n? uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('n? TstClass7 u s',
classNew('n? TstClass7s u c 1 f eins v, c 2 f zwei v',
,'m', 'metA say "metA"', 'metB say "metB"'))
m.s.0 = 2
m.s.1 = 1
m.s.2 = 2
call tstClassOut t, t3, s
call oMutatName qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' className(tt)
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if wordPos(t, m.class_V m.class_W m.class_O) > 0 then
return tstOut(o, a m.t.name '==>' m.a)
if m.t == 'r' then
return tstOut(o, a m.t '==>' m.a ':'if(m.t.0==0,'',m.t.1))
if m.t == 'u' & m.t.name \== '' then
call tstOut o, a m.t '=className=' m.t.name
if m.t == 'f' then
return tstClassOut(o, m.t.1, a'.'m.t.name)
if m.t = 'u' then do
do ux=1 to m.t.0
call tstClassOut o, m.t.ux, a
end
return 0
end
if m.t = 's' then do
call tstOut o, a m.t '=stem.0=' m.a.0
do ux=1 to m.a.0
call tstClassOut o, m.t.1, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.1, a
return 0
end
if m.t = 'm' then
return tstOut(o, a m.t '=met-'m.t.name'-->' m.t.met)
call err 'bad class type' m.t
endProcedure tstClassOut
tstClass4: procedure expose m.
parse arg
/*
$=/tstClass4/
### start tst tstClass4 ###########################################
f 1 eins
f 2 zwei
f 3 drei
f 4 vier
f 5 acht
s 1 fuenf
s 2 sechs
s 3 sie
$/tstClass4/
*/
call classIni
call tst t, 'tstClass4'
x = classNew('n* TstClass4a u f eins v, f%v zwei drei, f vier v',
', f%s-v fuenf sechs sie, f acht v')
ff = classFlds(x)
do fx=1 to m.ff.0
call tstOut t, 'f' fx m.ff.fx
end
st = classMet(x, 'stms')
do sx=1 to m.st.0
call tstOut t, 's' sx m.st.sx
end
call tstEnd t
return
endProcedure tstClass4
tstO: procedure expose m.
/*
$=/tstO/
### start tst tstO ################################################
o1.class <class_S>
o1.class <class T..1>
o1#met1 metEins
o1#met2 metZwei
o1#new return classClear('<class T..1>', oMutate(mNew('<class T..1>+
'), '<class T..1>'))
$/tstO/
*/
call mIni
call tst t, 'tstO'
call oIni
say m.class_s
call mAdd t.trans, m.class_s '<class_S>'
c1 = classNew('n? TstOCla1 u', 'm', 'met1 metEins', 'met2 metZwei')
call mAdd t.trans, c1 '<class T..1>'
o1 = 'tst_o1'
call tstOut t, 'o1.class' objClass(o1)
o1 = oMutate('o1', c1)
call tstOut t, 'o1.class' objClass(o1)
call tstOut t, 'o1#met1' objMet(o1, 'met1')
call tstOut t, 'o1#met2' objMet(o1, 'met2')
call tstOut t, 'o1#new' objMet(o1, 'new')
call tstEnd t
return
endProcedure tstO
tstOEins: procedure expose m.
/*
$=/tstOEins/
### start tst tstOEins ############################################
class method calls of TstOEins
. met Eins.eins M
flds of <obj e of TstOEins> FEINS, FZWEI
methodcalls of object e of TstOEins
. met Eins.eins <obj e of TstOEins>
. met Eins.zwei <obj e2 of TstOEins>
*** err: no method nein in class TstOEins
*** err: no method nein in class String
class method calls of TstOEins
. met Elf.zwei M
flds of <obj f of TstOElf> FEINS, FZWEI, FELF
methodcalls of object f of TstOElf
. met Eins.eins <obj f of TstOElf>
. met Elf.zwei <obj f of TstOElf>
. met Elf.drei <obj f of TstOElf>
oCopy c1 of class TstOEins, c2
C1 u =className= TstOEins
C1.FEINS v ==> M.C1.FEINS
C1.FZWEI v ==> M.C1.FZWEI
C1 m =met-eins--> call tstOut t, " met Eins.eins" m
C1 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C2 u =className= TstOEins
C2.FEINS v ==> M.C1.FEINS
C2.FZWEI v ==> M.C1.FZWEI
C2 m =met-eins--> call tstOut t, " met Eins.eins" m
C2 m =met-zwei--> call tstOut t, " met Eins.zwei" m
oCopy c3 of class TstOElf, c4
C4 u =className= TstOElf
C4 u =className= TstOEins
C4.FEINS v ==> M.C3.FEINS
C4.FZWEI v ==> M.C3.FZWEI
C4 m =met-eins--> call tstOut t, " met Eins.eins" m
C4 m =met-zwei--> call tstOut t, " met Eins.zwei" m
C4.FELF r ==> M.C3.FELF :<class O>
C4 m =met-zwei--> call tstOut t, " met Elf.zwei" m
C4 m =met-drei--> call tstOut t, " met Elf.drei" m
tEinsDop <class TstOEins>
oRun 7*3 21
oRun 12*12 144
$/tstOEins/ */
call oIni
call tst t, 'tstOEins'
tEins = classNew('n? TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
call mAdd t.trans, tEins '<class TstOEins>' ,
, m.class_o '<class O>'
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOEins', 'eins')
e = oNew('TstOEins')
e2 = oNew('TstOEins')
call mAdd t.trans, e '<obj e of TstOEins>'
call mAdd t.trans, e2 '<obj e2 of TstOEins>'
call tstOut t, 'flds of' e mCat(oFlds(e), ', ')
call tstOut t, 'methodcalls of object e of TstOEins'
call tstOmet e, 'eins'
call tstOmet e2, 'zwei'
call tstOmet e, 'nein'
call tstOmet 'noObj', 'nein'
tElf = classNew('n? TstOElf u TstOEins, f FELF r', 'm',
, 'zwei call tstOut t, " met Elf.zwei" m',
, 'drei call tstOut t, " met Elf.drei" m')
call tstOut t, 'class method calls of TstOEins'
interpret classMet('TstOElf', 'zwei')
f = oNew('TstOElf')
call mAdd t.trans, f '<obj f of TstOElf>'
call tstOut t, 'flds of' f mCat(oFlds(f), ', ')
call tstOut t, 'methodcalls of object f of TstOElf'
call tstOmet f, 'eins'
call tstOmet f, 'zwei'
call tstOmet f, 'drei'
call oMutatName c1, 'TstOEins'
call tstOut t, 'oCopy c1 of class TstOEins, c2'
call tstClassOut t, tEins, c1
call oCopy c1, c2
call tstClassOut t, tEins, c2
call tstOut t, 'oCopy c3 of class TstOElf, c4'
call oMutatName c3, 'TstOElf'
call oCopy c3, c4
call tstClassOut t, tElf, c4
/* tEinsDop = classNew('n TstOEins u f FEINS v,f FZWEI v', 'm',
, 'eins call tstOut t, " met Eins.eins" m',
, 'zwei call tstOut t, " met Eins.zwei" m')
*/ tEinsDop = tEins
call tstOut t, 'tEinsDop' tEinsDop
e3 = oNew('TstOEins')
if e3 <<= e | e3 <<= e2 then
call err 'doppelt reinitialised objects'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
r12 = oRunner('return 12 * 12')
call tstOut t, 'oRun 12*12' oRun(r12)
call tstEnd t
return
endProcedure tstOEins
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstO2Text: procedure expose m.
/*
$=/o2Text/
### start tst o2Text ##############################################
. > .
und _s abc > und so
und _s lang > und so und so und so und so und so und so und so und+
. so und so ....
]und _w abc > und so
o1 > tstO2T1=[fEins=v_o1_fEins fZwei=v_o1_fZwei fDrei=v_o+
1_fDrei]
o1 lang > tstO2T1=[fEins=v_o1_fEins fZwei=v_o1_fZweiv_o1_fZwei+
v_o1_fZweiv....
runner > <tstRunObj>=[<tstRunCla>]
file > <tstFileObj>=[File]
$/o2Text/
*/
call catIni
cl = classNew('n* TstO2Text1 u f fEins v, f fZwei v, f fDrei v')
o1 = 'tstO2T1'
call oMutate o1, cl
call mPut o1'.fEins', 'v_o1_fEins'
call mPut o1'.fZwei', 'v_o1_fZwei'
call mPut o1'.fDrei', 'v_o1_fDrei'
call tst t, 'o2Text'
maxL = 66
call tstOut t, ' >' o2Text(' ', maxL)
call tstOut t, 'und _s abc >' o2Text('und so ', maxL)
call tstOut t, 'und _s lang >' o2Text(copies('und so ',33), maxL)
call tstOut t, ']und _w abc >' o2Text('und so ', maxL)
call tstOut t, 'o1 >' o2Text(o1 , maxL)
call mPut o1'.fZwei', copies('v_o1_fZwei',33)
call tstOut t, 'o1 lang >' o2Text(o1 , maxL)
f = file('abc.efg')
r = oRunner('say o2Text test')
call mAdd t.trans, r '<tstRunObj>',
, className(objClass(r)) '<tstRunCla>' ,
, f '<tstFileObj>'
call tstOut t, 'runner >' o2Text(r , maxL)
call tstOut t, 'file >' o2Text(f , maxL)
call mAdd t.trans, r '<tstRunnerObj>',
, className(objClass(r)) '<tstRunnerCla>'
call tstEnd t
return
endProcedure tstO2Text
tstJSay: procedure expose m.
/*
$=/tstJSay/
### start tst tstJSay #############################################
*** err: bad option openArg in jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JSay#jOpen(<obj s of JSay>, <)
*** err: jWrite(<obj s of JSay>, write s vor open) but not opened+
. w
*** err: JRWEof#open(<obj e of JRWEof>, >)
*** err: jRead(<obj e of JRWEof>) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx valueBefore
out eins
#jIn 1# tst in line 1 eins ,
out zwei in 1 vv=readAdrVV
#jIn 2# tst in line 2 zwei ; .
out drei in 1 vv=readAdrVV Schluss
$/tstJSay/ */
call jIni
call tst t, 'tstJSay'
jrw = oNew('JRW')
call mAdd t'.TRANS', jrw '<obj j of JRW>'
call jOpen jrw, 'openArg'
call jWrite jrw, 'writeArg'
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jOpen s, m.j.cRead
s = oNew('JSay')
call mAdd t'.TRANS', s '<obj s of JSay>'
call jWrite s, 'write s vor open'
call jOpen s, '>'
call jWrite s, 'write s nach open'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
call jOpen e, '>'
e = oNew('JRWEof')
call mAdd t'.TRANS', e '<obj e of JRWEof>'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jReadVar(e, xx) 'm.xx' m.xx
call jOpen e, m.j.cRead
call tstOut t, 'read e nach open' jReadVar(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in() 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' inVar(vv) 'vv='vv 'Schluss'
call tstEnd t
return
endProcedure tstJSay
tstJ: procedure expose m.
/*
$=/tstJ/
### start tst tstJ ################################################
out eins
#jIn 1# tst in line 1 eins ,
1 in() tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
2 in() tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
3 in() tst in line 3 drei .schluss..
#jIn eof 4#
in() 3 reads vv VV
line buf line one
line buf line two
line buf line three
line buf line four
*** err: jWrite(<buf b>, buf line five while reading) but not opene+
d w
$/tstJ/ */
call jIni
call tst t, "tstJ"
b = jOpen(jBuf(), '>')
call mAdd t'.TRANS', b '<buf b>'
call out 'out eins'
do lx=1 by 1 while in()
call out lx 'in()' m.in
end
call out 'in()' (lx-1) 'reads vv' vv
call jOpen b, '>'
call jWrite b, 'buf line one'
call jClose b
call mAdd b'.BUF', 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jClose b
call jOpen b, m.j.cRead
do while jRead(b)
call out 'line' m.b
end
call jWrite b, 'buf line five while reading'
call jClose b
call tstEnd t
return
endProcedure tstJ
tstJ2: procedure expose m.
/*
$=/tstJ2/
### start tst tstJ2 ###############################################
class1 <Tst?1 class> <Tst?1 name>
class2 <Tst?1 class> <Tst?1 name>
class3 <Tst?1 class> <Tst?1 name>
b read EINS feld eins, ZWEI feld zwei, DREI feld drei
b read EINS feld eins, ZWEI feld zwei 2, DREI feld drei
c read EINS feld eins, ZWEI feld zwei, DREI drei cat 1
tstR: @tstWriteoV3 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei
tstR: .DREI = drei cat 1
c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2
tstR: @tstWriteoV4 isA :<Tst?1 name>
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
$/tstJ2/ */
call jIni
call tst t, "tstJ2"
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call mAdd t'.TRANS', ty '<Tst?1 class>'
call mAdd t'.TRANS', m.ty.name '<Tst?1 name>'
call tstOut t, 'class1' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class2' ty m.ty.name
ty = classNew('n* Tst u f EINS v, f ZWEI v, f DREI v')
call tstOut t, 'class3' ty m.ty.name
call oMutate qq, ty
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWrite b, oCopy(qq)
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen jClose(b), m.j.cRead
c = jOpen(jBuf(), '>')
do xx=1 while jRead(b)
res = m.b
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen jClose(c), m.j.cRead
do while jRead(c)
ccc = m.c
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call out ccc
end
call tstEnd t
return
endProcedure tstJ2
tstCat: procedure expose m.
/*
$=/tstCat/
### start tst tstCat ##############################################
catRead 1 line 1
catRead 2 line 2
catRead 3 line 3
appRead 1 line 1
appRead 2 line 2
appRead 3 line 3
appRead 4 append 4
appRead 5 append 5
$/tstCat/ */
call catIni
call tst t, "tstCat"
i = cat(jBuf('line 1', 'line 2'), jBuf('line 3'))
call jOpen i, m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'catRead' lx m.i
end
call jOpen jClose(i), m.j.cApp
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen jClose(i), m.j.cRead
do lx=1 by 1 while jRead(i)
call tstOut t, 'appRead' lx m.i
end
call tstEnd t
return
endProcedure tstCat
tstEnv: procedure expose m.
call pipeIni
/*
$=/tstEnv/
### start tst tstEnv ##############################################
before pipeBeLa
after pipeEnd
*** err: jWrite(<jBuf c>, write nach pop) but not opened w
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
before writeNow 2 c --> std
before writeNow 1 b --> c
b line eins
b zwei |
nach writeNow 1 b --> c
add nach pop
after push c only
tst in line 1 eins ,
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
nach writeNow 2 c --> std
*** err: jWrite(<jBuf c>, ) but not opened w
$/tstEnv/ */
call tst t, "tstEnv"
c = jBuf()
call mAdd t'.TRANS', c '<jBuf c>'
call out 'before pipeBeLa'
b = jBuf("b line eins", "b zwei |")
call pipe '+Ff', c, b
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipe '-'
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipe '+A', c
call out 'after push c only'
call pipeWriteNow
call pipe '-'
call pipe '+f', , c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipe '-'
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call pipeIni
/*
$=/tstEnvCat/
### start tst tstEnvCat ###########################################
c1 contents
c1 line eins |
before writeNow 1 b* --> c*
b1 line eins|
b2 line eins
b2 zwei |
c2 line eins |
after writeNow 1 b* --> c*
c2 contents
c2 line eins |
$/tstEnvCat/ */
call tst t, "tstEnvCat"
b0= jBuf()
b0= jBuf()
b1= jBuf("b1 line eins|")
b2 = jBuf("b2 line eins", "b2 zwei |")
c1 = jBuf("c1 line eins |")
c2 = jBuf("c2 line eins |")
call pipe '+Affff', c1, b0, b1, b2, c2
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipe '-'
call out 'c1 contents'
call pipe '+f' , , c1
call pipeWriteNow
call pipe '-'
call pipe '+f' , , c2
call out 'c2 contents'
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstEnvCat
tstPipe: procedure expose m.
call pipeIni
/*
$=/tstPipe/
### start tst tstPipe #############################################
.+0 vor pipeBegin
#jIn 1# tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
.+7 nach pipeLast
[7 +6 nach pipe 7]
[7 +2 nach pipe 7]
[7 +4 nach nested pipeLast 7]
[7 (4 +3 nach nested pipeBegin 4) 7]
[7 (4 (3 +1 nach pipeBegin 3) 4) 7]
[7 (4 (3 tst in line 1 eins , 3) 4) 7]
[7 (4 (3 tst in line 2 zwei ; 3) 4) 7]
[7 (4 (3 tst in line 3 drei .schluss. 3) 4) 7]
[7 (4 (3 +1 nach writeNow vor pipe 3) 4) 7]
[7 (4 +3 nach preSuf vor nested pipeLast 4) 7]
[7 +4 nach preSuf vor nested pipeEnd 7]
[7 +5 nach nested pipeEnd vor pipe 7]
[7 +6 nach writeNow vor pipeLast 7]
.+7 nach writeNow vor pipeEnd
.+8 nach pipeEnd
$/tstPipe/ */
say 'x0' m.pipe.0
call tst t, 'tstPipe'
call out '+0 vor pipeBegin'
say 'x1' m.pipe.0
call pipe '+N'
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe 'N|'
call out '+2 nach pipe'
call pipe '+N'
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipe 'P|'
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipe '-'
call out '+5 nach nested pipeEnd vor pipe'
call pipe 'N|'
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipe 'P|'
call out '+7 nach pipeLast'
call pipePreSuf '[7 ', ' 7]'
call out '+7 nach writeNow vor pipeEnd'
call pipe '-'
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstPipeS: procedure expose m.
/*
$=/tstPipeS/
### start tst tstPipeS ############################################
eine einzige zeile
nach all einzige Zeile
select strip(creator) cr, strip(name) tb,
(row_number()over())*(row_number()over()) rr
from sysibm.sysTables
$/tstPipeS/
*/
call pipeIni
call tst t, "tstPipeS"
call pipe '+s',, 'eine einzige zeile'
call pipeWriteAll
call out 'nach all einzige Zeile'
call pipe 'sss',,
, "select strip(creator) cr, strip(name) tb," ,
, "(row_number()over())*(row_number()over()) rr" ,
, "from sysibm.sysTables"
call pipeWriteAll
call pipe '-'
call tstEnd t
return
endProcedure tstPipeS
tstEnvVars: procedure expose m.
call pipeIni
/*
$=/tstEnvVars/
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get TST.ADR1
v2 hasKey 0
one to theBur
two to theBuf
v1=TST.ADR1 o=TST.ADR1
v3=v3WieGehts? o=v3WieGehts?
v4=]v4WieGehts? o=]v4WieGehts?
o o0=<o0>
s o0=<o0>
o o0=<o0>
s o0=<o0>
o0&fSt0=rexx o0.fSt0 o=rexx o0.fSt0
o0&fRe0=]rexx o0.fRe0 o=]rexx o0.fRe0
o0&=rexx o0-value o=rexx o0-value
o o0=<o0>
s o0=<o0>
o0&fSt0=put o0.fSt0 o=put o0.fSt0
o0&fRe0=]putO o0.fRe0 o=]putO o0.fRe0
o0&=put o0-value o=put o0-value
$/tstEnvVars/
$=/tstEnvVars1/
### start tst tstEnvVars1 #########################################
m.o1=put-o1-value m.o1.fStr=put-o1.fStr m.o1.fRef=<o0>
o o1=<o1> s o1=<o1>
o1&fStr=put-o1.fStr o=put-o1.fStr
o1&=put-o1-value o=put-o1-value
o1&fRef=<o0> o=<o0>
o1&fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o1&fRef>fRe0=]putO o0.fRe0 o=]putO o0.fRe0
m.o1&fNest.fSt0= put-o1.fNest.fSt0 m.o1&fNest.fRe0= ]put-o1&fNest.f+
Re0
o1&fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o1&fNest&fRe0=]put-o1&fNest.fRe0 o=]put-o1&fNest.fRe0
$/tstEnvVars1/
$=/tstEnvVars2/
### start tst tstEnvVars2 #########################################
o2=<o2> getO(o2)=<o2> getO(o2&fRef)=<o1>
o2&fRef>fStr=put-o1.fStr o=put-o1.fStr
o2&fRef>=put-o1-value o=put-o1-value
o2&fRef>fRef=<o0> o=<o0>
o2&fRef>fRef>fSt0=put o0.fSt0 o=put o0.fSt0
o2&fRef>fRef>fRe0=]putO o0.fRe0 o=]putO o0.fRe0
o2&fRef>fNest.fSt0=put-o1.fNest.fSt0 o=put-o1.fNest.fSt0
o2&fRef>fNest&fRe0=]put-o1&fNest.fRe0 o=]put-o1&fNest.fRe0
$/tstEnvVars2/
$=/tstEnvVarsS/
### start tst tstEnvVarsS #########################################
oS=<oS> oS&fStS=<put oS.fStS>
oS&fStV.0=1 oS&fStV.1=<put oS.fStV.1>
m.oS.fStR.0=2 .2=]<put oS.fStR.2>
oS&fStR.0=2 .1=]<put oS.fStR.1> .2=]<put oS.fStR.2>
m.oS.0=9876 .1234=<put oS.1234>
*** err: undefined var oS&12
oS&0=9876 .12=M. .1234=<put oS.1234>
$/tstEnvVarsS/
$=/tstEnvVars3/
### start tst tstEnvVars3 #########################################
m.<o0>=*o0*val vGet(<o0>>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(<o0>>fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(<o0>>fRe0)=<o1>
m.<o1>=*o1*val vGet(<o0>>fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(<o0>>fRe0>fStr)=*o1.fStr*val
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0)=<o0>
m.V.tstEnvVar0=<o0> vGet(tstEnvVar0&)=<o0>
m.<o0>=*o0*val vGet(tstEnvVar0&>)=*o0*val
m.<o0>.fSt0=*o0.fSt0*val vGet(tstEnvVar0&fSt0)=*o0.fSt0*val
m.<o0>.fRe0=<o1> vGet(tstEnvVar0&fRe0)=<o1>
m.<o1>=*o1*val vGet(tstEnvVar0&fRe0>)=*o1*val
m.<o1>.fStr=*o1.fStr*val vGet(tstEnvVar0&fRe0>fStr)=*o1.fStr*val
m.<o1>.fVar=tstEnvVar2 vGet(tstEnvVar0&fRe0>fVar)=tstEnvVar2
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&)=<o2>
m.<o2>=*o2*val vGet(tstEnvVar0&fRe0>fVar&>)=*o2*val
m.<o2>.fStr=*o2.fStr*val vGet(tstEnvVar0&fRe0>fVar&fStr)=*o2.fStr*v+
al
m.<o0>=*o0*put2 vGet(<o0>>)=*o0*put2
m.<o0>.fSt0=*o0.fSt0*put2 vGet(<o0>>fSt0)=*o0.fSt0*put2
m.<o1>=*o0>fRe0>put2 vGet(<o0>>fRe0>)=*o0>fRe0>put2
m.<o1>.fStr=*o0>fRe0>fStr*put2 vGet(<o0>>fRe0>fStr)=*o0>fRe0>fStr*p+
ut2
m.<o0>=*v0&>*put3 vGet(tstEnvVar0&>)=*v0&>*put3
m.<o0>.fSt0=*v0&fSt0*put3 vGet(tstEnvVar0&fSt0)=*v0&fSt0*put3
m.<o1>=*v0&fRe0>*put3 vGet(tstEnvVar0&fRe0>)=*v0&fRe0>*put3
m.<o1>.fStr=*v0&fRe0>fStr*put3 vGet(tstEnvVar0&fRe0>fStr)=*v0&fRe0>+
fStr*put3
m.<o2>=*v0&fRe0>fVar&>*put3 vGet(tstEnvVar0&fRe0>fVar&>)=*v0&fRe0>f+
Var&>*put3
m.<o2>.fStr=*v0&fRe0>fVar&fStr*put3 vGet(tstEnvVar0&fRe0>fVar&fStr)+
=*v0&fRe0>fVar&fStr*put3
$/tstEnvVars3/
*/
c0 = classNew('n? TstEnvVars0 u f fSt0 v, f = v, f fRe0 r')
c1 = classNew('n? TstEnvVars1 u f fStr v,f fRef r' ,
', f fNest TstEnvVars0, f = v, f fVar v')
o0 = oNew(c0)
o1 = oNew(c1)
o2 = oNew(c1)
call tst t, "tstEnvVars3"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
fSt0 = 'fSt0'
fRe0 = 'fRe0'
fStr = 'fStr'
fRef = 'fRef'
fVar = 'fVar'
v0 = 'tstEnvVar0'
v2 = 'tstEnvVar2'
m.o0 = '*o0*val'
m.o0.fSt0 = '*o0.fSt0*val'
m.o0.fRe0 = o1
m.o1 = '*o1*val'
m.o1.fStr = '*o1.fStr*val'
m.o1.fRef = o2
m.o1.fVar = v2
m.o2 = '*o2*val'
m.o2.fStr = '*o2.fStr*val'
m.v.v0 = o0
m.v.v2 = o2
call tstEnvVarsMG o0, o0'>'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call tstEnvVarsMG o0'.'fRe0, o0'>'fRe0
call tstEnvVarsMG o1, o0'>'fRe0'>'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call tstEnvVarsMG v'.'v0, v0
call tstEnvVarsMG v'.'v0, v0'&'
call tstEnvVarsMG o0, v0'&>'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call tstEnvVarsMG o0'.'fRe0, v0'&'fRe0
call tstEnvVarsMG o1, v0'&'fRe0'>'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call tstEnvVarsMG o1'.'fVar, v0'&'fRe0'>'fVar
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call vPut o0'>', '*o0*put2'
call tstEnvVarsMG o0, o0'>'
call vPut o0'>'fSt0, '*o0.fSt0*put2'
call tstEnvVarsMG o0'.'fSt0, o0'>'fSt0
call vPut o0'>'fRe0'>', '*o0>fRe0>put2'
call tstEnvVarsMG o1, o0'>'fRe0'>'
call vPut o0'>'fRe0'>'fStr, '*o0>fRe0>fStr*put2'
call tstEnvVarsMG o1'.'fStr, o0'>'fRe0'>'fStr
call vPut v0'&>', '*v0&>*put3'
call tstEnvVarsMG o0, v0'&>'
call vPut v0'&'fSt0, '*v0&fSt0*put3'
call tstEnvVarsMG o0'.'fSt0, v0'&'fSt0
call vPut v0'&'fRe0'>', '*v0&fRe0>*put3'
call tstEnvVarsMG o1, v0'&'fRe0'>'
call vPut v0'&'fRe0'>'fStr, '*v0&fRe0>fStr*put3'
call tstEnvVarsMG o1'.'fStr, v0'&'fRe0'>'fStr
call vPut v0'&'fRe0'>'fVar'&>', '*v0&fRe0>fVar&>*put3'
call tstEnvVarsMG o2, v0'&'fRe0'>'fVar'&>'
call vPut v0'&'fRe0'>'fVar'&fStr', '*v0&fRe0>fVar&fStr*put3'
call tstEnvVarsMG o2'.'fStr, v0'&'fRe0'>'fVar'&fStr'
call tstEnd t, "tstEnvVars"
call tst t, "tstEnvVars"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = vPut('v1', oMutate(tst'.'adr1, m.class_V))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' vHasKey('v1') 'get' vGet('v1')
call tstOut t, 'v2 hasKey' vHasKey('v2')
if 0 then
call tstOut t, 'v2 get' vGet('v2')
call vPut 'theBuf', jBuf()
call pipe '+F' , vGet('theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipe '-'
call pipe '+f',, vGet('theBuf')
call pipeWriteNow
call pipe '-'
call tstOut t, 'v1='vGet('v1') 'o='vGet('v1')
call vPut 'v3', 'v3WieGehts?'
call tstOut t, 'v3='vGet('v3') 'o='vGet('v3')
call vPut 'v4', s2o('v4WieGehts?')
call tstOut t, 'v4='vGet('v4') 'o='vGet('v4')
call vPut 'o0', o0
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
fSt0 = 'fSt0'
fRe0 = 'fRe0'
m.o0 = 'rexx o0-value'
m.o0.fSt0 = 'rexx o0.fSt0'
m.o0.fRe0 = s2o('rexx o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call vPut 'o0&>', 'put o0-value'
call vPut 'o0&fSt0', 'put o0.fSt0'
call vPut 'o0&fRe0', s2o('putO o0.fRe0')
call tstOut t, 'o o0='vGet('o0')
call tstOut t, 's o0='vGet('o0')
call tstOut t, 'o0&fSt0='vGet('o0&fSt0') 'o='vGet('o0&fSt0')
call tstOut t, 'o0&fRe0='vGet('o0&fRe0') 'o='vGet('o0&fRe0')
call tstOut t, 'o0&='vGet('o0&>') 'o='vGet('o0&>')
call tstEnd t
call tst t, "tstEnvVars1"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o1', o1
call vPut 'o1&>', 'put-o1-value'
call vPut 'o1&fStr', 'put-o1.fStr'
call vPut 'o1&fRef', vGet('o0')
call tstOut t, 'm.o1='m.o1 'm.o1.fStr='mGet(o1'.fStr'),
'm.o1.fRef='mGet(o1'.fRef')
call tstOut t, 'o o1='vGet('o1') 's o1='vGet('o1')
call tstOut t, 'o1&fStr='vGet('o1&fStr') 'o='vGet('o1&fStr')
call tstOut t, 'o1&='vGet('o1&>') 'o='vGet('o1&>')
call tstOut t, 'o1&fRef='vGet('o1&fRef') 'o='vGet('o1&fRef')
call tstOut t, 'o1&fRef>fSt0='vGet('o1&fRef>fSt0') ,
'o='vGet('o1&fRef>fSt0')
call tstOut t, 'o1&fRef>fRe0='vGet('o1&fRef>fRe0'),
'o='vGet('o1&fRef>fRe0')
call vPut 'o1&fNest.fSt0', 'put-o1.fNest.fSt0'
call vPut 'o1&fNest.fRe0', s2o('put-o1&fNest.fRe0')
call tstOut t, 'm.o1&fNest.fSt0=' mGet(o1'.fNest.fSt0') ,
'm.o1&fNest.fRe0=' mGet(o1'.fNest.fRe0')
call tstOut t, 'o1&fNest.fSt0='vGet('o1&fNest.fSt0'),
'o='vGet('o1&fNest.fSt0')
call tstOut t, 'o1&fNest&fRe0='vGet('o1&fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
call tst t, "tstEnvVars2"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>'
call vPut 'o2', o2
call vPut 'o2&fRef', vGet('o1')
call tstOut t, 'o2='o2 'getO(o2)='vGet('o2'),
'getO(o2&fRef)='vGet('o2&fRef')
call tstOut t, 'o2&fRef>fStr='vGet('o2&fRef>fStr'),
'o='vGet('o2&fRef>fStr')
call tstOut t, 'o2&fRef>='vGet('o2&fRef>'),
'o='vGet('o2&fRef>')
call tstOut t, 'o2&fRef>fRef='vGet('o2&fRef>fRef') ,
'o='vGet('o2&fRef>fRef')
call tstOut t, 'o2&fRef>fRef>fSt0='vGet('o2&fRef>fRef>fSt0') ,
'o='vGet('o2&fRef>fRef>fSt0')
call tstOut t, 'o2&fRef>fRef>fRe0='vGet('o2&fRef>fRef>fRe0'),
'o='vGet('o2&fRef>fRef>fRe0')
call tstOut t, 'o2&fRef>fNest.fSt0='vGet('o2&fRef>fNest.fSt0'),
'o='vGet('o2&fRef>fNest.fSt0')
call tstOut t, 'o2&fRef>fNest&fRe0='vGet('o2&fRef>fNest.fRe0'),
'o='vGet('o1&fNest.fRe0')
call tstEnd t
cS = classNew('n? TstEnvVarsS u f fStS v,f fStV s v, f fStR s r',
', f fNeS s TstEnvVars0, f = s v')
oS = oNew(cS)
call vPut 'oS', oS
oT = oNew(cS)
call tst t, "tstEnvVarsS"
call mAdd t.trans, o0 '<o0>', o1 '<o1>', o2 '<o2>',
, oS '<oS>', oT '<oT>'
call mPut oS'.fStS', '<put oS.fStS>'
call tstOut t, 'oS='vGet('oS') 'oS&fStS='vGet('oS&fStS')
call mPut oS'.fStV.1', '<put oS.fStV.1>'
call mPut oS'.fStV.0', 1
call tstOut t, 'oS&fStV.0='vGet('oS&fStV.0'),
'oS&fStV.1='vGet('oS&fStV.1')
call mPut oS'.fStR.1', s2o('<put oS.fStR.1>')
call mPut oS'.fStR.2', s2o('<put oS.fStR.2>')
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.fStR.0='mGet(oS'.fStR.0'),
'.2='mGet(oS'.fStR.2')
call tstOut t, 'oS&fStR.0='vGet('oS&fStR.0'),
'.1='vGet('oS&fStR.1') '.2='vGet('oS&fStR.2')
call mPut oS'.1234', '<put oS.1234>'
call mPut oS'.0', 9876
call mPut oS'.fStR.0', 2
call tstOut t, 'm.oS.0='mGet(oS'.0'),
'.1234='mGet(oS'.1234')
call tstOut t, 'oS&0='vGet('oS&0'),
'.12='vGet('oS&12') '.1234='vGet('oS&1234')
call tstEnd t
return
endProcedure tstEnvVars
tstEnvVarsMG: procedure expose m.
parse arg m, g
call tstOut t, 'm.'m'='m.m 'vGet('g')='vGet(g)
return
tstvWith: procedure expose m.
/*
$=/tstEW2/
### start tst tstEW2 ##############################################
tstK1 TSTEW1
tstK1& ]get1 w
tstK1&f1 get1.f1 v
tstK1&f2 ]get1.f2 w
tstK1&F3 get1.f3 v
ttstK1&F3.FEINS get1.f3.fEins v
tstK1&F3.FZWEI ]get1.f3.fZwei w
tstK1&F3.FDREI o ]get1.f3.fDrei w
tstK1&F3.FDREI ]get1.f3.fDrei w
tstK1&F3.1 ]get1.f3.1 w
tstK1&F3.2 TSTEW1
tstK1&F3.2>F1 get1.f1 v
tstK1&F3.2>F3.2>F2 ]get1.f2 w
*** err: undefined var F1
F1 M..
F1 get1.f1 v
f2 ]get1.f2 w
F3 get1.f3 v
F3.FEINS get1.f3.fEins v
F3.FZWEI ]get1.f3.fZwei w
F3.FDREI o ]get1.f3.fDrei w
F3.1 ]get1.f3.1 w
pu1 F1 get1.f1 v
pu2 F1 get2.f1 v
po-2 F1 get1.f1 v
*** err: undefined var F1
po-1 F1 M..
$/tstEW2/ */
call pipeIni
c0 = classNew('n? TstEW0 u f FEINS v,f FZWEI w, f FDREI r,v,s r')
call classMet c0, 'oFlds' /* new would do it, but we donot use it */
cl = classNew('n? TstEW u r TstEW0, f F1 v, f F2 r, f F3 TstEW0')
call classMet cl, 'oFlds' /* new would do it, but we donot use it */
call oMutate tstEW1, cl
m.tstEW1 = s2o('get1 w')
m.tstEW1.f1 = 'get1.f1 v'
m.tstEW1.f2 = s2o('get1.f2 w')
m.tstEW1.f3 = 'get1.f3 v'
m.tstEW1.f3.fEins = 'get1.f3.fEins v'
m.tstEW1.f3.fZwei = s2o('get1.f3.fZwei w')
m.tstEW1.f3.fDrei = s2o('get1.f3.fDrei w')
m.tstEW1.f3.0 = 3
m.tstEW1.f3.1 = s2o('get1.f3.1 w')
m.tstEW1.f3.2 = tstEW1
m.tstEW1.f3.3 = s2o('get1.f3.3 w')
call oMutate tstEW2, cl
m.tstEW2 = s2o('get2 w')
m.tstEW2.f1 = 'get2.f1 v'
m.tstEW2.f2 = s2o('get2.f2 w')
call vPut 'tstK1', tstEW1
call tst t, 'tstEW2'
call tstOut t, 'tstK1 ' vGet('tstK1')
call tstOut t, 'tstK1& ' vGet('tstK1&>')
call tstOut t, 'tstK1&f1 ' vGet('tstK1&F1')
call tstOut t, 'tstK1&f2 ' vGet('tstK1&F2')
call tstOut t, 'tstK1&F3 ' vGet('tstK1&F3')
call tstOut t, 'ttstK1&F3.FEINS ' vGet('tstK1&F3.FEINS')
call tstOut t, 'tstK1&F3.FZWEI ' vGet('tstK1&F3.FZWEI')
call tstOut t, 'tstK1&F3.FDREI o ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.FDREI ' vGet('tstK1&F3.FDREI')
call tstOut t, 'tstK1&F3.1 ' vGet('tstK1&F3.1')
call tstOut t, 'tstK1&F3.2 ' vGet('tstK1&F3.2')
call tstOut t, 'tstK1&F3.2>F1 ' vGet('tstK1&F3.2>F1')
call tstOut t, 'tstK1&F3.2>F3.2>F2' ,
vGet('tstK1&F3.2>F3.2>F2')
call tstOut t, 'F1 ' vGet('F1')
call vWith '+', tstEW1
call tstOut t, 'F1 ' vGet('F1')
call tstOut t, 'f2 ' vGet('F2')
call tstOut t, 'F3 ' vGet('F3')
call tstOut t, 'F3.FEINS ' vGet('F3.FEINS')
call tstOut t, 'F3.FZWEI ' vGet('F3.FZWEI')
call tstOut t, 'F3.FDREI o ' vGet('F3.FDREI')
call tstOut t, 'F3.1 ' vGet('F3.1')
call tstOut t, 'pu1 F1 ' vGet('F1')
call vWith '+', tstEW2
call tstOut t, 'pu2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-2 F1 ' vGet('F1')
call vWith '-'
call tstOut t, 'po-1 F1 ' vGet('F1')
call tstEnd t
/*
$=/tstEW3/
### start tst tstEW3 ##############################################
. s c3&F1 = v(c3&f1)
*** err: null address at &FEINS in c3&F1&FEINS
*** err: undefined var c3&F1&FEINS
. s c3&F1&FEINS = M..
*** err: null address at &FEINS in c3&F3&FEINS
*** err: null address at &FEINS in c3&F3&FEINS
*** err: undefined var c3&F3&FEINS
. s c3&F3&FEINS = M..
. s c3&F3.FEINS = val(c3&F3.FEINS)
*** err: undefined var c3&FEINS
. s c3&FEINS = M..
getO c3&
aft Put s c3&>FEINS = v&&fEins
Push c3 s F3.FEINS = val(c3&F3.FEINS)
aftPut= s F3.FEINS = pushPut(F3.FEINS)
push c4 s F1 = v(c4&f1)
put f2 s F2 = put(f2)
put .. s F3.FEINS = put(f3.fEins)
popW c4 s F1 = v(c3&f1)
*** err: undefined var F1
popW c3 s F1 = M..
. s F222 = f222 pop stop
$/tstEW3/
*/
call tst t, 'tstEW3'
c3 = oNew('TstEW')
call mAdd t.trans, c3 '<c3>'
m.c3.f1 = 'v(c3&f1)'
call vPut 'c3', c3
call tstEnvSG , 'c3&F1'
call tstEnvSG , 'c3&F1&FEINS'
call tstEnvSG , 'c3&F3&FEINS'
call vPut 'c3&F3.FEINS', 'val(c3&F3.FEINS)'
call tstEnvSG , 'c3&F3.FEINS'
call tstEnvSG , 'c3&FEINS'
call tstOut t, 'getO c3&', vGet('c3&')
call vPut 'c3&>', oNew('TstEW0')
call vPut 'c3&>FEINS', 'v&&fEins'
call tstEnvSG 'aft Put', 'c3&>FEINS'
call vWith '+', c3
call tstEnvSG 'Push c3', 'F3.FEINS'
call vPut 'F3.FEINS', 'pushPut(F3.FEINS)'
call tstEnvSG 'aftPut=', 'F3.FEINS'
c4 = oNew('TstEW')
call mAdd t.trans, c4 '<c4>'
m.c4.f1 = 'v(c4&f1)'
call vPut f222, 'f222 no stop'
call vWith '+', c4
call tstEnvSG 'push c4', f1
call vPut f2, 'put(f2)'
call tstEnvSG 'put f2', f2
call vPut f222, 'f222 stopped', 1
call vPut 'F3.FEINS', 'put(f3.fEins)'
call tstEnvSG 'put .. ', 'F3.FEINS'
call vWith '-'
call tstEnvSG 'popW c4', f1
call vWith '-'
call vPut f222, 'f222 pop stop'
call tstEnvSG 'popW c3', f1
call tstEnvSG , f222
call tstEnd t
return
endProcedure tstvWith
tstEnvSG: procedure expose m. t
parse arg txt, nm
call tstOut t, left(txt,10)'s' left(nm, 15)'=' vGet(nm)
return
tstPipeLazy: procedure expose m.
call pipeIni
/*
$=/tstPipeLazy/
### start tst tstPipeLazy #########################################
a1 vor pipeBegin loop lazy 0 writeNow *** <class TstPipeLazyBuf>
bufOpen <
bufClose
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor 2 writeNow in inIx 4
a2 vor writeNow jBuf
jBuf line 1
jBuf line 2
a3 vor writeNow in inIx 1
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd inIx 4
a7 nach barEnd lazy 0 writeNow ***
b1 vor barBegin lazy 0 writeNow *** <class TstPipeLazyRdr>
RdrOpen <
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
rdrClose
b4 vor writeNow
b2 vor writeNow rdr inIx 2
jRead lazyRdr
tst in line 3 drei .schluss..
jRead lazyRdr
b3 vor barLast inIx 4
b5 vor barEnd inIx 4
b6 nach barEnd lazy 0 writeNow ***
a1 vor pipeBegin loop lazy 1 writeAll *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAll in inIx 0
a2 vor writeAll jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAll in inIx 0
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd inIx 4
a7 nach barEnd lazy 1 writeAll ***
b1 vor barBegin lazy 1 writeAll *** <class TstPipeLazyRdr>
b4 vor writeAll
b2 vor writeAll rdr inIx 1
RdrOpen <
jRead lazyRdr
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
jRead lazyRdr
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
jRead lazyRdr
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAll ***
$/tstPipeLazy/ */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = class4Name('TstPipeLazyBuf', '')
if ty == '' then do
ty = classNew('n TstPipeLazyBuf u JRWDeleg', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'call jOpen m.m.deleg, opt',
, 'jClose call tstOut "T", "bufClose";',
'call jClose m.m.deleg')
end
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a2 vor' w 'jBuf'
b = oNew('TstPipeLazyBuf', jBuf('jBuf line 1','jBuf line 2'))
interpret 'call pipe'w 'b'
call out 'a3 vor' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor 2' w 'in inIx' m.t.inIx
interpret 'call pipe'w
call out 'a6 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
ty = class4Name('TstPipeLazyRdr', '')
if ty == '' then
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt',
, 'jRead call out "jRead lazyRdr";' ,
'mr = m.m.rdr; if \ jRead(mr) then return 0;',
"m.m = m.mr; return 1",
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
m.r.rdr = m.j.in
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipe '+N'
call out 'b2 vor' w 'rdr inIx' m.t.inIx
interpret 'call pipe'w 'r'
call out 'b3 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipe '-'
call out 'b6 nach barEnd lazy' lz w '***'
end
call tstEnd t
return
endProcedure tstPipeLazy
tstEnvClass: procedure expose m.
call pipeIni
/*
$=/tstEnvClass/
### start tst tstEnvClass #########################################
a0 vor pipeBegin loop lazy 0 writeNow *** TY
#jIn 2# tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
#jIn eof 4#
a5 vor writeNow
a1 vor jBuf()
a2 vor writeNow b
tstR: @<o20 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc0 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy0
tstR: .f24 = .
tstR: .F25 = value F25 of o20 <o20 of TstEnvClass20>
a3 vor writeNow
tst in line 2 zwei ; .
tst in line 3 drei .schluss..
a4 vor barLast inIx 4
a6 vor barEnd
a7 nach barEnd lazy 0 writeNow ***
a0 vor pipeBegin loop lazy 1 writeAll *** TY
a5 vor writeAll
a1 vor jBuf()
a2 vor writeAll b
tstR: @<o21 of TstEnvClass10> isA :TstEnvClass10
tstR: .f11 = .
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = .
WriteO o2
tstR: @<oc1 of TstEnvClass20> isA :TstEnvClass20 = valueO2Lazy1
tstR: .f24 = .
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAll
#jIn 1# tst in line 1 eins ,
tst in line 1 eins ,
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
#jIn eof 4#
a4 vor barLast inIx 0
a6 vor barEnd
a7 nach barEnd lazy 1 writeAll ***
$/tstEnvClass/ */
call tst t, "tstEnvClass"
t10 = classNew('n? TstEnvClass10 u f f11 v, f F12 v, f f13 v')
t20 = classNew('n? TstEnvClass20 u v, f f24 v, f F25 v')
do lz=0 to 1
if lz then
w = 'writeAll'
else
w = 'writeNow'
m.t.inIx = 1-lz
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipe '+N'
call out 'a1 vor jBuf()'
b = jOpen(jBuf(), m.j.cWri)
o1 = oNew('TstEnvClass10')
m.o1.F12 = 'value F12 of o1' o1
call mAdd t'.TRANS', o1 '<o2'lz 'of TstEnvClass10>'
call jWrite b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopy(oCopy(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWrite b, oc
call out 'a2 vor' w 'b'
interpret 'call pipe'w jClose(b)
call out 'a3 vor' w
interpret 'call pipe'w
call out 'a4 vor barLast inIx' m.t.inIx
call pipe 'P|'
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipe '-'
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
tstDsnEx: procedure expose m.
/*
$=/tstDsnEx/
### start tst tstDsnEx ############################################
dsnExists(A540769.WK.rexx) 1
dsnExists(rzZ/A540769.WK.rexx) 1
dsnExists(A540769.WK.wk.rexxYY) 0
dsnExists(rzZ/A540769.WK.wk.rexxYY) 0
dsnExists(A540769.WK.rexx(wsh)) 1
dsnExists(rzZ/A540769.WK.rexx(wsh)) 1
dsnExists(A540769.WK.rexx(nonono)) 0
dsnExists(rzZ/A540769.WK.rexx(nonono)) 0
dsnExists(A540769.WK.rxxYY(nonon)) 0
dsnExists(rzZ/A540769.WK.rxxYY(nonon)) 0
*** err: error in csm mbrList ?ZZ/A540769.WK.RXXYY(NONON) .
. e 1: CSMSI77E INVALID SYSTEM NAME (MUST BE * OR A VALID NAME) +
(COL:8)
. e 2: CSMSI77E?????SYSTEM=?ZZ +
. +
. ???????+
??????????
dsnExists(qzZ/A540769.WK.rxxYY(nonon)) 0
$/tstDsnEx/
*/
call tst t, 'tstDsnEx'
lst = 'rexx wk.rexxYY rexx(wsh) rexx(nonono) rxxYY(nonon)'
do lx =1 to words(lst)
d1 = 'A540769.WK.'word(lst,lx)
call tstOut t, 'dsnExists('d1')' dsnExists(d1)
call tstOut t, 'dsnExists(rzZ/'d1')' dsnExists('RZZ/'d1)
end
call mAdd t'.TRANS', '00'x '?', '0A'x '?'
call tstOut t, 'dsnExists(qzZ/'d1')' dsnExists('?ZZ/'d1)
call tstEnd t
return
endProceudre tstDsnEx
tstFile: procedure expose m.
call catIni
/*
$=/tstFile/
### start tst tstFile #############################################
write read 0 last 10 vor anfang
write read 1 last 80 links1 1 und rechts | ..
write read 2 last 80 liinks2 2 und rechts | ..
write read 5 last 80 links5 5 rechts5
write read 99 last 80 links99 99 rechts
write read 100 last 80 links100 100 rechts
write read 101 last 80 links101 101 rechts
write read 999 last 80 links999 999 rechts
write read 1000 last 80 links1000 1000 rechts
write read 1001 last 80 links1001 1001 rechts
write read 2109 last 80 links2109 2109 rechts
out > eins 1 +
. .
out > eins 2 schluss. +
. .
buf eins
buf zwei
buf drei
out > zwei mit einer einzigen Zeile +
. .
. links1 1 und rechts | . +
. .
$/tstFile/ */
call tst t, "tstFile"
pds = tstFilename('lib', 'r')
call tstFileWr pds, 0, ' links0', ' und rechts | . '
call tstFileWr pds, 1, ' links1', ' und rechts | . '
call tstFileWr pds, 2, 'liinks2', ' und rechts | . '
call tstFileWr pds, 5, 'links5', 'rechts5'
call tstFileWr pds, 99, 'links99', 'rechts'
call tstFileWr pds, 100, 'links100', 'rechts'
call tstFileWr pds, 101, 'links101', 'rechts'
call tstFileWr pds, 999, 'links999', 'rechts'
call tstFileWr pds, 1000, 'links1000', 'rechts'
call tstFileWr pds, 1001, 'links1001', 'rechts'
call tstFileWr pds, 2109, 'links2109', 'rechts'
pd2 = tstFilename('li2', 'r')
call pipeIni
call pipe '+F', s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipe '-'
call pipe '+F', s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipe '-'
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipe '+ffffff', , s2o(tstPdsMbr(pd2, 'eins')), b,
,jBuf(),
,s2o(tstPdsMbr(pd2, 'zwei')),
,s2o(tstPdsMbr(pds, 'wr0')),
,s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipe '-'
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if m.err.os \== 'LINUX' then
return line
else if recL == '' then
return left(line, 80)
else
return left(line, recL)
endProcedure tstFB
tstPdsMbr: procedure expose m.
parse arg pds, mbr
if m.err.os = 'TSO' then
return pds'('mbr') ::F'
if m.err.os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' m.err.os
endProcedure tstPdsMbr
tstFileWR: procedure expose m.
parse arg dsn, num, le, ri
io = file(tstPdsMbr(dsn, 'wr'num))
call jOpen io, m.j.cWri
do x = 1 to num /* simulate fixBlock 80 on LINUX*/
call jWrite io, tstFB(le x ri)
end
call jClose io
if num > 100 then
call jReset io, tstPdsMbr(dsn, 'wr'num)
call jOpen io, m.j.cRead
m.io = 'vor anfang'
do x = 1 to num
if \ jRead(io) then
call err x 'not jRead'
else if m.io <> le x ri then
call err x 'read mismatch' m.io
end
if jRead(io) then
call err x 'jRead but should be eof 1'
if jRead(io) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.io) strip(m.io,'t')
return
endProcedure tstFileWr
tstFileList: procedure expose m.
call catIni
/*
$=/tstFileList/
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>drei
<<pref 2 List>>vier
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
<<pref 1 vier>>drei
$/tstFileList/ */
/*
$=/tstFileListTSO/
### start tst tstFileListTSO ######################################
empty dir
filled dir
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 2 LIST>>ZWEI
filled dir recursive
<<pref 2 LIST>>DREI
<<pref 2 LIST>>EINS
<<pref 1 VIER>>DREI
<<pref 1 VIER>>EINS
<<pref 1 VIER>>ZWEI
<<pref 2 LIST>>ZWEI
$/tstFileListTSO/ */
if m.err.os = 'TSO' then
call tst t, "tstFileListTSO"
else
call tst t, "tstFileList"
fi = file(tstFileName('FileList', 'r'))
call fileMkDir fi
fl = fileList(fi)
call tstOut t, 'empty dir'
call jWriteNow t, fl
call tstFileListMake t, fi, 2
call tstOut t, 'filled dir'
call jWriteNow t, fl
call tstOut t, 'filled dir recursive'
call jWriteNow t, fileList(fi, 'r')
call tstEnd t
return
endProcedure tstFileList
tstFileListMake: procedure expose m.
parse arg t, fi, lev
if \ fileIsDir(fi) then
call fileMkDir fi
call mAdd t'.TRANS', filePath(fi) || m.file.sep ,
'<<pref' lev right(filePath(fi),4)'>>'
call jCat fileChild(fi, 'eins','::F'),jBuf('zeile eins','eins' lev)
call jCat fileChild(fi, 'zwei','::F'),jBuf('zeile zwei','zwei' lev)
call jCat fileChild(fi, 'drei','::F'),jBuf('zeile drei','drei' lev)
if lev > 1 then
call tstFileListMake t, fileChild(fi, 'vier'), lev-1
return
endProcedure tstFileListMake
tstMail: procedure expose m.
do i=1 to 2
call mailHead xy, 'mail from walter''s rexx' time() i, A540769
call mailText xy, 'und hier kommt der text' ,
, 'und zeile zwei timestamp' i':' date('s') time() ,
, left('und eine lange Zeile 159', 156, '+')159 ,
, left('und eine lange Zeile 160', 157, '+')160 ,
, left('und eine lange Zeile 161', 158, '+')161 ,
, '<ol><li>'left('und eine lange', 200, '+')203 '</li>',
, '<li bgcolor=yellow>und kurz</li></ol>' ,
, '<h1>und Schluss mit html</h1>'
call mailSend xy
call sleep 3
end
return
endprocedure tstMail
tstF: procedure expose m.
/*
$=/tstF/
### start tst tstF ################################################
f(1 23%c345%c67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1\S23%c345%S67%%8, eins, zwei ) =1\S23eins345zwei67%8;
f(1 23%C345%C67%%8, eins, zwei ) =1 23eins345 zwei 67%8;
f(1 23%c345%S67%%8, eins, zwei ) =1 23eins345zwei67%8;
f(1%S2%c3@2%S4@%c5, eins, zwei ) =1eins2 zwei 3zwei4 zwei 5;
f(1%-2C2%3C3@2%3.2C4, eins, zwei ) =1ei2ei 3zwe4;
f(1@F1%c2@f2%c3@F3%c4, eins, zwei ) =1fEins2fZwei3fDrei4;
tstF2 _ %-9C @%5I @%8I @%+8I @%-8I -----
_ 0 0 0 +0 0 .
_ -1.2 -1 -1 -1 -1 .
_ 2.34 2 2 +2 2 .
_ -34.8765 -35 -35 -35 -35 .
_ 567.91234 568 568 +568 568 .
_ -8901 -8901 -8901 -8901 -8901 .
_ 23456 23456 23456 +23456 23456 .
_ -789012 ***** -789012 -789012 -789012 .
_ 34e6 ***** 34000000 ******** 34000000
_ -56e7 ***** ******** ******** ********
_ 89e8 ***** ******** ******** ********
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLa undEinLa undEinLa
tstF2 _ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I -----
_ 0 0.00 0.00 +0.00 0.00 .
_ -1.2 -1.20 -1.20 -1.20 -1.20 .
_ 2.34 2.34 2.34 +2.34 2.34 .
_ -34.8765 ***** -34.88 -34.88 -34.88 .
_ 567.91234 ***** 567.91 +567.91 567.91 .
_ -8901 ***** -8901.00 -8901.00 -8901.00 .
_ 23456 ***** 23456.00 +23456.00 23456.00 .
_ -789012 ***** -789012.00 -789012.00 -789012.00 .
_ 34e6 ***** 34000000.00 +34000000.00 34000000.00 .
_ -56e7 ***** ************ ************ ************
_ 89e8 ***** ************ ************ ************
_ txtli txtli txtli txtli txtli .
_ undEinLan undEi undEinLanger undEinLanger undEinLanger
tstF2 _ %-9C @%7e @% 8E @% 9.3e @% 11.4E -----
_ 0 0.00e00 0.00E00 0.000e00 0.0000E000
_ -1.2 -1.2e00 -1.20E00 -1.200e00 -1.2000E000
_ 2.34 2.34e00 2.34E00 2.340e00 2.3400E000
_ -34.8765 -3.5e01 -3.49E01 -3.488e01 -3.4877E001
_ 567.91234 5.68e02 5.68E02 5.679e02 5.6791E002
_ -8901 -8.9e03 -8.90E03 -8.901e03 -8.9010E003
_ 23456 2.35e04 2.35E04 2.346e04 2.3456E004
_ -789012 -7.9e05 -7.89E05 -7.890e05 -7.8901E005
_ 34e6 3.40e07 3.40E07 3.400e07 3.4000E007
_ -56e7 -5.6e08 -5.60E08 -5.600e08 -5.6000E008
_ 89e8 8.90e09 8.90E09 8.900e09 8.9000E009
_ txtli txtli txtli txtli txtli.
_ undEinLan undEinL undEinLa undEinLan undEinLange
_ 8.76e-07 8.76e-7 8.76E-7 8.760e-7 8.7600E-07
_ 5.43e-11 5.4e-11 5.4E-11 5.43e-11 5.4300E-11
_ -8.76e-07 -8.8e-7 -8.76E-7 -8.760e-7 -8.7600E-07
_ -5.43e-11 -5e-011 -5.4E-11 -5.43e-11 -5.4300E-11
tstF2 _ %-9C @%kt @%kd @%kb -----
_ 0 0s00 0 0 .
_ -1.2 -1s20 -1 -1 .
_ 2.34 2s34 2340m 2 .
_ -34.8765 -0m35 -35 -35 .
_ 567.91234 9m28 568 568 .
_ -8901 -2h28 -9k -9k
_ 23456 6h31 23k 23k
_ -789012 -9d03 -789k -771k
_ 34e6 394d 34M 32M
_ -56e7 -++++ -560M -534M
_ 89e8 +++++ 8900M 8488M
_ txtli txtli txtli txtli
_ undEinLan Text? Text? Text?
_ 8.76e-07 0s00 876n 0 .
_ 5.43e-11 0s00 54p 0 .
_ -8.76e-07 -0s00 -876n -0 .
_ -5.43e-11 -0s00 -54p -0 .
$/tstF/ */
call tst t, 'tstF'
call tstF1 '1 23%c345%c67%%8'
call tstF1 '1\S23%c345%S67%%8'
call tstF1 '1 23%C345%C67%%8'
call tstF1 '1 23%c345%S67%%8'
call tstF1 '1%S2%c3@2%S4@%c5'
call tstF1 '1%-2C2%3C3@2%3.2C4'
call tstF1 '1@F1%c2@f2%c3@F3%c4'
nums = '0 -1.2 2.34 -34.8765 567.91234 -8901 23456' ,
'-789012 34e6 -56e7 89e8 txtli undEinLangerText?'
call tstF2 '_ %-9C @%5I @%8I @%+8I @%-8I', nums
call tstF2 '_ %-9C @%5.2I @%12.2I @%+12.2I @%-12.2I', nums
num2 = ' 8.76e-07 5.43e-11 -8.76e-07 -5.43e-11'
call tstF2 '_ %-9C @%7e @% 8E @% 9.3e @% 11.4E', nums num2
call tstF2 '_ %-9C @%kt @%kd @%kb', nums num2
call tstEnd t
return
endProcedure tstF
tstF1: procedure expose m.
parse arg fmt
e='eins'
z=' zwei '
f2 = 'f2'
m.e.f1 = 'fEins'
m.e.f2 = 'fZwei'
m.e.f3 = 'fDrei'
call tstOut t, "f("fmt"," e"," z") ="f(fmt, e, z)";"
return
endProcedure tstF1
tstF2: procedure expose m.
parse arg fmt, vals
call tstOut t, 'tstF2' fmt '-----'
do vx=1 to words(vals)
call tstOut t, f(fmt, word(vals, vx))
end
return
endProcedure tstF2
tstFWords: procedure expose m.
/*
$=/tstFWords/
### start tst tstFWords ###########################################
??empty?? .
1space .
, %#e-- --
%#a%9c .
*%#a%-7c .
??empty?? eins
1space eins
, %#e-- eins
%#a%9c eins
*%#a%-7c eins .
??empty?? einszwei
1space eins zwei
, %#e-- eins, zwei
%#a%9c eins zwei
*%#a%-7c eins *zwei .
??empty?? einszweidrei
1space eins zwei drei
, %#e-- eins, zwei, drei
%#a%9c eins zwei drei
*%#a%-7c eins *zwei *drei .
$/tstFWords/
*/
ws = ' eins zwei drei '
call tst t, 'tstFWords'
do l=0 to 3
call tstOut t, '??empty?? ' fWords( ,subword(ws,1,l))
call tstOut t, '1space ' fWords(' ' ,subword(ws,1,l))
call tstOut t, ', %#e-- ' fWords(', %#e--' ,subword(ws,1,l))
call tstOut t, '%#a%9c ' fWords('%#a%9c' ,subword(ws,1,l))
call tstOut t, '*%#a%-7c ' fWords('*%#a%-7c' ,subword(ws,1,l))
end
call tstEnd t
return
endProcedure tstFWords
tstFe: procedure expose m.
/*
$=/tstFe/
### start tst tstFe ###############################################
. 1 < 1.00e00> <1.00e00>
. 0 < 0.00e00> <0.00e00>
. -2.1 <-2.10e00> <-2.1e00>
. .3 < 3.00e-1> <3.00e-1>
. -.45678 <-4.57e-1> <-4.6e-1>
. 901 < 9.01e02> <9.01e02>
. -2345 <-2.35e03> <-2.3e03>
. 678e90 < 6.78e92> <6.78e92>
. 123e-4 < 1.23e-2> <1.23e-2>
. 567e-89 < 5.7e-87> <5.7e-87>
. 12e456 < 1.2e457> <1.2e457>
. 78e-901 < 8e-0900> <8e-0900>
. 2345e5789 < 2e05792> <2e05792>
. 123e-4567 < 1e-4565> <1e-4565>
. 8901e23456 < 9e23459> <9e23459>
. -123e-4567 <-1e-4565> <-0e-999>
. 567e890123 <********> <*******>
. 45678e-901234 < 0e-9999> <0e-9999>
. kurz < kurz> <kurz >
. undLangerText <undLange> <undLang>
$/tstFe/
*/
call tst t, 'tstFe'
vAll = '1 0 -2.1 .3 -.45678 901 -2345 678e90 123e-4' ,
'567e-89 12e456 78e-901 2345e5789 123e-4567 8901e23456' ,
'-123e-4567 567e890123 45678e-901234' ,
'kurz undLangerText'
do vx=1 to words(vAll)
v = word(vAll, vx)
call tstOut t, right(v, 20) '<'fe(v, 8, 2, 'e', ' ')'>' ,
'<'fe(v, 7, 1, 'e', '-')'>'
end
call tstEnd t
return
endProcedure
tstFTst: procedure expose m.
/*
$=/tstFTstS/
### start tst tstFTstS ############################################
1956-01-29-23.34.56.987654 SS => 1956-01-29-23.34.56.987654|
1956-01-29-23.34.56.987654 Ss => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 S => 1956-01-29-23.34.56|
1956-01-29-23.34.56.987654 SD => 19560129|
1956-01-29-23.34.56.987654 Sd => 560129|
1956-01-29-23.34.56.987654 SE => 29.01.1956|
1956-01-29-23.34.56.987654 Se => 29.01.56|
1956-01-29-23.34.56.987654 St => 23.34.56|
1956-01-29-23.34.56.987654 ST => 23:34:56.987654|
1956-01-29-23.34.56.987654 SY => GB29|
1956-01-29-23.34.56.987654 SM => B2923345|
1956-01-29-23.34.56.987654 SH => C33456|
1956-01-29-23.34.56.987654 Sj => 56029|
1956-01-29-23.34.56.987654 SJ => 714076|
$/tstFTstS/
$=/tstFTsts/
### start tst tstFTsts ############################################
2014-12-23-16.57.38 sS => 2014-12-23-16.57.38.000000|
2014-12-23-16.57.38 ss => 2014-12-23-16.57.38|
2014-12-23-16.57.38 s => 2014-12-23-16.57.38|
2014-12-23-16.57.38 sD => 20141223|
2014-12-23-16.57.38 sd => 141223|
2014-12-23-16.57.38 sE => 23.12.2014|
2014-12-23-16.57.38 se => 23.12.14|
2014-12-23-16.57.38 st => 16.57.38|
2014-12-23-16.57.38 sT => 16:57:38.000000|
2014-12-23-16.57.38 sY => EM23|
2014-12-23-16.57.38 sM => M2316573|
2014-12-23-16.57.38 sH => B65738|
2014-12-23-16.57.38 sj => 14357|
2014-12-23-16.57.38 sJ => 735589|
2014-12-23-16.57.38 su +> E1KCA3JT|
2014-12-23-16.57.38 sL +> 00CE3F48639FB0000000|
$/tstFTsts/
$=/tstFTstD/
### start tst tstFTstD ############################################
23450618 DS => 2345-06-18-00.00.00.000000|
23450618 Ds => 2345-06-18-00.00.00|
23450618 D => 2345-06-18-00.00.00|
23450618 DD => 23450618|
23450618 Dd => 450618|
23450618 DE => 18.06.2345|
23450618 De => 18.06.45|
23450618 Dt => 00.00.00|
23450618 DT => 00:00:00.000000|
23450618 DY => PG18|
23450618 DM => G1800000|
23450618 DH => A00000|
23450618 Dj => 45169|
23450618 DJ => 856296|
$/tstFTstD/
$=/tstFTstd/
### start tst tstFTstd ############################################
120724 dS => 2012-07-24-00.00.00.000000|
120724 ds => 2012-07-24-00.00.00|
120724 d => 2012-07-24-00.00.00|
120724 dD => 20120724|
120724 dd => 120724|
120724 dE => 24.07.2012|
120724 de => 24.07.12|
120724 dt => 00.00.00|
120724 dT => 00:00:00.000000|
120724 dY => CH24|
120724 dM => H2400000|
120724 dH => A00000|
120724 dj => 12206|
120724 dJ => 734707|
$/tstFTstd/
$=/tstFTstE/
### start tst tstFTstE ############################################
09.12.1345 ES => 1345-12-09-00.00.00.000000|
09.12.1345 Es => 1345-12-09-00.00.00|
09.12.1345 E => 1345-12-09-00.00.00|
09.12.1345 ED => 13451209|
09.12.1345 Ed => 451209|
09.12.1345 EE => 09.12.1345|
09.12.1345 Ee => 09.12.45|
09.12.1345 Et => 00.00.00|
09.12.1345 ET => 00:00:00.000000|
09.12.1345 EY => PM09|
09.12.1345 EM => M0900000|
09.12.1345 EH => A00000|
09.12.1345 Ej => 45343|
09.12.1345 EJ => 491228|
$/tstFTstE/
$=/tstFTste/
### start tst tstFTste ############################################
31.05.2467 eS => 2024-05-31-00.00.00.000000|
31.05.2467 es => 2024-05-31-00.00.00|
31.05.2467 e => 2024-05-31-00.00.00|
31.05.2467 eD => 20240531|
31.05.2467 ed => 240531|
31.05.2467 eE => 31.05.2024|
31.05.2467 ee => 31.05.2467|
31.05.2467 et => 00.00.00|
31.05.2467 eT => 00:00:00.000000|
31.05.2467 eY => OF31|
31.05.2467 eM => F3100000|
31.05.2467 eH => A00000|
31.05.2467 ej => 24152|
31.05.2467 eJ => 739036|
$/tstFTste/
$=/tstFTstt/
### start tst tstFTstt ############################################
12.34.56 tS => 0001-01-01-12.34.56.000000|
12.34.56 ts => 0001-01-01-12.34.56|
12.34.56 t => 0001-01-01-12.34.56|
12.34.56 tD => 00010101|
12.34.56 td => 010101|
12.34.56 tE => 01.01.0001|
12.34.56 te => 01.01.01|
12.34.56 tt => 12.34.56|
12.34.56 tT => 12:34:56.000000|
12.34.56 tY => ??01|
12.34.56 tM => ?0112345|
12.34.56 tH => B23456|
12.34.56 tj => 01001|
12.34.56 tJ => 0|
$/tstFTstt/
$=/tstFTstT/
### start tst tstFTstT ############################################
23.45.06.784019 TS => 0001-01-01-23.45.06.784019|
23.45.06.784019 Ts => 0001-01-01-23.45.06|
23.45.06.784019 T => 0001-01-01-23.45.06|
23.45.06.784019 TD => 00010101|
23.45.06.784019 Td => 010101|
23.45.06.784019 TE => 01.01.0001|
23.45.06.784019 Te => 01.01.01|
23.45.06.784019 Tt => 23.45.06|
23.45.06.784019 TT => 23.45.06.784019|
23.45.06.784019 TY => ??01|
23.45.06.784019 TM => ?0123450|
23.45.06.784019 TH => C34506|
23.45.06.784019 Tj => 01001|
23.45.06.784019 TJ => 0|
$/tstFTstT/
$=/tstFTstY/
### start tst tstFTstY ############################################
FE25 YS => 2015-04-25-00.00.00.000000|
FE25 Ys => 2015-04-25-00.00.00|
FE25 Y => 2015-04-25-00.00.00|
FE25 YD => 20150425|
FE25 Yd => 150425|
FE25 YE => 25.04.2015|
FE25 Ye => 25.04.15|
FE25 Yt => 00.00.00|
FE25 YT => 00:00:00.000000|
FE25 YY => FE25|
FE25 YM => E2500000|
FE25 YH => A00000|
FE25 Yj => 15115|
FE25 YJ => 735712|
$/tstFTstY/
$=/tstFTstM/
### start tst tstFTstM ############################################
I2317495 MS => 0001-08-23-17.49.50.000000|
I2317495 Ms => 0001-08-23-17.49.50|
I2317495 M => 0001-08-23-17.49.50|
I2317495 MD => 00010823|
I2317495 Md => 010823|
I2317495 ME => 23.08.0001|
I2317495 Me => 23.08.01|
I2317495 Mt => 17.49.50|
I2317495 MT => 17:49:50.000000|
I2317495 MY => ?I23|
I2317495 MM => I2317495|
I2317495 MH => B74950|
I2317495 Mj => 01235|
I2317495 MJ => 234|
$/tstFTstM/
$=/tstFTstH/
### start tst tstFTstH ############################################
B23456 HS => 0001-01-01-12.34.56.000000|
B23456 Hs => 0001-01-01-12.34.56|
B23456 H => 0001-01-01-12.34.56|
B23456 HD => 00010101|
B23456 Hd => 010101|
B23456 HE => 01.01.0001|
B23456 He => 01.01.01|
B23456 Ht => 12.34.56|
B23456 HT => 12:34:56.000000|
B23456 HY => ??01|
B23456 HM => ?0112345|
B23456 HH => B23456|
B23456 Hj => 01001|
B23456 HJ => 0|
$/tstFTstH/
$=/tstFTstn/
### start tst tstFTstn ############################################
19560423 17:58:29 nS => 1956-04-23-17.58.29.000000|
19560423 17:58:29 ns => 1956-04-23-17.58.29|
19560423 17:58:29 n => 1956-04-23-17.58.29|
19560423 17:58:29 nD => 19560423|
19560423 17:58:29 nd => 560423|
19560423 17:58:29 nE => 23.04.1956|
19560423 17:58:29 ne => 23.04.56|
19560423 17:58:29 nt => 17.58.29|
19560423 17:58:29 nT => 17:58:29.000000|
19560423 17:58:29 nY => GE23|
19560423 17:58:29 nM => E2317582|
19560423 17:58:29 nH => B75829|
19560423 17:58:29 nj => 56114|
19560423 17:58:29 nJ => 714161|
$/tstFTstn/
$=/tstFTstN/
### start tst tstFTstN ############################################
32101230 10:21:32.456789 NS => 3210-12-30-10.21.32.456789|
32101230 10:21:32.456789 Ns => 3210-12-30-10.21.32|
32101230 10:21:32.456789 N => 3210-12-30-10.21.32|
32101230 10:21:32.456789 ND => 32101230|
32101230 10:21:32.456789 Nd => 101230|
32101230 10:21:32.456789 NE => 30.12.3210|
32101230 10:21:32.456789 Ne => 30.12.10|
32101230 10:21:32.456789 Nt => 10.21.32|
32101230 10:21:32.456789 NT => 10:21:32.456789|
32101230 10:21:32.456789 NY => AM30|
32101230 10:21:32.456789 NM => M3010213|
32101230 10:21:32.456789 NH => B02132|
32101230 10:21:32.456789 Nj => 10364|
32101230 10:21:32.456789 NJ => 1172426|
$/tstFTstN/
*/
say "f('%t ')" f('%t ')
call timeIni
allOut = 'Ss DdEetTYMHjJ'
allIn = 'S1956-01-29-23.34.56.987654' ,
's2014-12-23-16.57.38' ,
'D23450618' ,
'd120724' ,
'E09.12.1345' ,
'e31.05.2467' ,
't12.34.56' ,
'T23.45.06.784019' ,
'YFE25' ,
'MI2317495' ,
'HB23456' ,
'n19560423*17:58:29' ,
'N32101230*10:21:32.456789'
do ix=1 to words(allIn)
parse value word(allIn, ix) with iF 2 iV
iv = translate(iv, ' ', '*')
call tst t, "tstFTst"iF
do ox=1 to length(allOut)
ft = iF || substr(allOut, ox, 1)
call tstOut t, left(iV, 30) ft '=>' f('%t'ft, iV)'|'
if 0 & iF = 'Y' then
say '???' ft '>>>' mGet('F_GEN.%t'ft)
end
if ix=2 then do
call tstOut t, left(iV, 30) iF'u' '+>' f('%t'iF'u', iV)'|'
call tstOut t, left(iV, 30) iF'L' '+>' f('%t'iF'L', iV)'|'
end
call tstEnd t
end
return
endProcedure tstFTst
tstFmt: procedure expose m.
call pipeIni
/*
$=/tstFmt/
### start tst tstFmt ##############################################
= a2i b3b d4 fl5 ex6
-11 -11 b3 d4-11+d4++++ -111.1000000 -1.11000e-12
-1 -10 b d4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.0000000 -1.11900e-10
-8+ -8 b3b- d4-8+d4++ -18.0000000 -1.18000e010
-7 -7 b3b d4-7+d4+ -7.0000000 -1.70000e-07
- -6 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2 b3b d4- -0.1200000 -1.20000e001
-1 -1 b3 d4 -0.1000000 -1.00000e-02
0 0 b d null1 null1
1+ 1 b3 d4 0.1000000 1.00000e-02
2++ 2 b3b d42 0.1200000 1.20000e001
3 3 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7 b3b d47+d4++ 0.1111117 7.00000e-08
8++ 8 b3b8 d48+d4+++ 8.0000000 1.80000e009
9 9 b3b9+ d49+d4++++ 0.9000000 1.19000e-08
10 10 b d410+d4++++ null1 null3
11+ 11 b3 d411+d4+++++ 0.1110000 1.00000e-12
1 12 b3b d412+d4++++++ 11112.0000000 2.00000e012
13 13 b3b1 d 1111.3000000 1.13000e-12
14+ 14 b3b14 d4 111111.0000000 1.40000e013
1 15 b d41 null2 null1
16 16 b3 d416 6.0000000 1.16000e003
17+ 17 b3b d417+ 0.7000000 1.11170e-03
1 18 b3b1 d418+d 11.0000000 1.11800e003
19 19 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.1210000 1.11000e-05
22 22 b3b d422+d4+++ 11111.2000000 2.00000e007
23+ 23 b3b2 d423+d4++++ 0.1111123 1.11230e-09
c3L a2i drei d4 fl5 ex6
-11 -1.10E01 b3 d4-11+d -111.1000000 -1.11000e-12
-1 -1.00E01 b d4-10+d null1 null3
- -9.00E00 b3b-9 d4-9+d4 -11.0000000 -1.11900e-10
-8+ -8.00E00 b3b- d4-8+d4 -18.0000000 -1.18000e010
-7 -7.00E00 b3b d4-7+d4 -7.0000000 -1.70000e-07
- -6.00E00 b3 d4-6+d4 -0.1111160 -6.00000e006
-5+ -5.00E00 b d4-5+d null2 null2
-4 -4.00E00 b3b-4 d4-4+ -11114.0000000 -1.11140e008
- -3.00E00 b3b- d4-3 -0.1130000 -1.13000e-04
-2+ -2.00E00 b3b d4- -0.1200000 -1.20000e001
-1 -1.00E00 b3 d4 -0.1000000 -1.00000e-02
0 0.00E00 b d null1 null1
1+ 1.00E00 b3 d4 0.1000000 1.00000e-02
2++ 2.00E00 b3b d42 0.1200000 1.20000e001
3 3.00E00 b3b3 d43+ 0.1130000 1.13000e-04
4+ 4.00E00 b3b4+ d44+d 11114.0000000 1.11140e008
5++ 5.00E00 b d45+d4 null2 null2
6 6.00E00 b3 d46+d4+ 0.1111160 1.11116e005
7+ 7.00E00 b3b d47+d4+ 0.1111117 7.00000e-08
8++ 8.00E00 b3b8 d48+d4+ 8.0000000 1.80000e009
9 9.00E00 b3b9+ d49+d4+ 0.9000000 1.19000e-08
10 1.00E01 b d410+d4 null1 null3
11+ 1.10E01 b3 d411+d4 0.1110000 1.00000e-12
1 1.20E01 b3b d412+d4 11112.0000000 2.00000e012
13 1.30E01 b3b1 d 1111.3000000 1.13000e-12
14+ 1.40E01 b3b14 d4 111111.0000000 1.40000e013
1 1.50E01 b d41 null2 null1
16 1.60E01 b3 d416 6.0000000 1.16000e003
17+ 1.70E01 b3b d417+ 0.7000000 1.11170e-03
1 1.80E01 b3b1 d418+d 11.0000000 1.11800e003
19 1.90E01 b3b19 d419+d4 0.1190000 9.00000e-05
20+ 2.00E01 b d420+d4 null1 null2
2 2.10E01 b3 d421+d4 11.1210000 1.11000e-05
22 2.20E01 b3b d422+d4 11111.2000000 2.00000e007
23+ 2.30E01 b3b2 d423+d4 0.1111123 1.11230e-09
$/tstFmt/ */
call tst t, "tstFmt"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe '-'
call fTabAuto fTabReset(abc, 1), b
call fTabReset abc, 1
call fTabAddDetect abc, , st , , 'c3L'
call fTabAdd abc, 'a2i', '% 8E'
call fTabAddDetect abc, 'b3b', st , ,'drei'
call fTabAdd abc, 'd4', '%-7C'
call fTabAddDetect abc, 'fl5', st
call fTabAddDetect abc, 'ex6', st
call fTab abc, b
call tstEnd t
return
endProcedure tstFmt
tstFTab: procedure expose m.
/*
$=/tstFTab/
### start tst tstFTab #############################################
testData begin
..---------a2i-b3b------------------d4------fl5-----ex6---
-11 -11 b3 -11+d4++++ -111.100 -1e-012
-1 -10 b 4-10+d4+++ null1 null3
- -9 b3b-9 d4-9+d4+++ -11.000 -1e-010
-8+ -8 b3b- d4-8+d4++ -18.000 -1.2e10
-7 -7 b3b d4-7+d4+ -7.000 -1.7e-7
- -6 b3 d4-6+d4 -0.111 -6.0e06
-5+ -5 b d4-5+d null2 null2
-4 -4 b3b-4 d4-4+ ******** -1.1e08
- -3 b3b- d4-3 -0.113 -1.1e-4
-2+ -2 b3b d4- -0.120 -1.2e01
-1 -1 b3 d4 -0.100 -1.0e-2
0 0 b d null1 null1
1+ 1 b3 d4 0.100 1.00e-2
2++ 2 b3b d42 0.120 1.20e01
3 3 b3b3 d43+ 0.113 1.13e-4
4+ 4 b3b4+ d44+d ******** 1.11e08
5++ 5 b d45+d4 null2 null2
6 6 b3 d46+d4+ 0.111 1.11e05
7+ 7 b3b d47+d4++ 0.111 7.00e-8
8++ 8 b3b8 d48+d4+++ 8.000 1.80e09
9 9 b3b9+ d49+d4++++ 0.900 1.19e-8
10 10 b 410+d4++++ null1 null3
11+ 11 b3 11+d4+++++ 0.111 1.0e-12
1 12 b3b 2+d4++++++ ******** 2.00e12
13 13 b3b1 d 1111.300 1.1e-12
14+ 14 b3b14 d4 ******** 1.40e13
1 15 b d41 null2 null1
16 16 b3 d416 6.000 1.16e03
17+ 17 b3b d417+ 0.700 1.11e-3
1 18 b3b1 d418+d 11.000 1.12e03
19 19 b3b19 d419+d4 0.119 9.00e-5
20+ 20 b d420+d4+ null1 null2
2 21 b3 d421+d4++ 11.121 1.11e-5
22 22 b3b d422+d4+++ ******** 2.00e07
23+ 23 b3b2 423+d4++++ 0.111 1.11e-9
..---------a2i-b3b------------------d4------fl5-----ex6---
testData end
$/tstFTab/ */
call pipeIni
call tst t, "tstFTab"
b = jBuf()
st = b'.BUF'
call pipe '+F', b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipe 'P|'
call fTabReset ft, 2 1, 1 3, '-'
call fTabAddRCT ft, '=' , '%-6C', '.', , 'testData begin',
, 'testData end'
call fTabAddRCT ft, 'a2i' , '%6i'
call fTabAddRCT ft, 'b3b' , '%-12C'
call fTabAddRCT ft, 'd4' , '%10C'
call fTabAddRCT ft, 'fl5' , '%8.3I'
call fTabAddRCT ft, 'ex6' , '%7e'
call fTab ft
call pipe '-'
call tstEnd t
return
endProcedure tstFTab
tstCSV: procedure
/*
$=/tstCSV/
### start tst tstCSV ##############################################
value,value eins,value zwei
value,"value, , eins",value zwei
value,"","value ""zwei"" oder?"
value,,"value ""zwei"" oder?"
$/tstCSV/ */
m.tstCsv.c.1 = ''
m.tstCsv.c.2 = eins
m.tstCsv.c.3 = zwei
m.tstCsv.c.0 = 3
call tst t, "tstCSV"
m.tstCsv.o = 'value'
m.tstCsv.o.eins = 'value eins'
m.tstCsv.o.zwei = 'value zwei'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = 'value, , eins'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = ''
m.tstCsv.o.zwei = 'value "zwei" oder?'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 0)
m.tstCsv.o.eins = '---'
call tstOut t, csv4Obj(tstCsv'.'o, tstCsv'.'c, 1, '---')
call tstEnd t
return
endProcedure tstCSV
tstfUnits: procedure
/*
$=/tstfUnits/
### start tst tstfUnits ###########################################
. 1 ==> 1 =-> -1 =+> +1 =b> 1 .
. 5 ==> 5 =-> -5 =+> +5 =b> 5 .
. 13 ==> 13 =-> -13 =+> +13 =b> 13 .
. 144 ==> 144 =-> -144 =+> +144 =b> 144 .
. 1234 ==> 1234 =-> -1k =+> +1234 =b> 1234 .
. 7890 ==> 7890 =-> -8k =+> +7890 =b> 7890 .
. 0 ==> 0 =-> 0 =+> +0 =b> 0 .
. 234E3 ==> 234k =-> -234k =+> +234k =b> 229k
. 89E6 ==> 89M =-> -89M =+> +89M =b> 85M
. 123E9 ==> 123G =-> -123G =+> +123G =b> 115G
. 4567891E9 ==> 4568T =-> -5P =+> +4568T =b> 4154T
. 0.123 ==> 123m =-> -123m =+> +123m =b> 0 .
. 0.0000456789 ==> 46u =-> -46u =+> +46u =b> 0 .
. 345.567E-12 ==> 346p =-> -346p =+> +346p =b> 0 .
. 123.4567E-15 ==> 123f =-> -123f =+> +123f =b> 0 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> JKLMN =-> JKLMN =+> IJKLMN =b> JKLMN
. 1E77 ==> +++++ =-> -++++ =+> ++++++ =b> +++++.
. 1E-77 ==> 0f =-> -0f =+> +0f =b> 0 .
. 18.543E18 ==> 19E =-> -19E =+> +19E =b> 16E
. 20.987E20 ==> 2099E =-> -++++ =+> +2099E =b> 1820E
. 1 ==> 1.000 =-> -1.000 =+> +1.000 =b> 1.000 .
. 5 ==> 5.000 =-> -5.000 =+> +5.000 =b> 5.000 .
. 13 ==> 13.000 =-> -0.013k =+> +0.013k =b> 13.000 .
. 144 ==> 0.144k =-> -0.144k =+> +0.144k =b> 0.141k
. 1234 ==> 1.234k =-> -1.234k =+> +1.234k =b> 1.205k
. 7890 ==> 7.890k =-> -7.890k =+> +7.890k =b> 7.705k
. 0 ==> 0.000 =-> 0.000 =+> +0.000 =b> 0.000 .
. 234E3 ==> 0.234M =-> -0.234M =+> +0.234M =b> 0.223M
. 89E6 ==> 89.000M =-> -0.089G =+> +0.089G =b> 84.877M
. 123E9 ==> 0.123T =-> -0.123T =+> +0.123T =b> 0.112T
. 4567891E9 ==> 4.568P =-> -4.568P =+> +4.568P =b> 4.057P
. 0.123 ==> 0.123 =-> -0.123 =+> +0.123 =b> 0.123 .
. 0.0000456789 ==> 45.679u =-> -0.046m =+> +0.046m =b> 0.000 .
. 345.567E-12 ==> 0.346n =-> -0.346n =+> +0.346n =b> 0.000 .
. 123.4567E-15 ==> 0.123p =-> -0.123p =+> +0.123p =b> 0.000 .
. ABC ==> ABC =-> -ABC =+> ABC =b> ABC
ABCDEFGHIJKLMN ==> HIJKLMN =-> HIJKLMN =+> HIJKLMN =b> HIJKLMN
. 1E77 ==> +++++++ =-> -++++++ =+> +++++++ =b> +++++++.
. 1E-77 ==> 0.000f =-> -0.000f =+> +0.000f =b> 0.000 .
. 18.543E18 ==> 18.543E =-> -19E =+> +19E =b> 16.083E
. 20.987E20 ==> 2099E =-> -2099E =+> +2099E =b> 1820E
$/tstfUnits/
$=/tstfUnitst/
### start tst tstfUnitst ##########################################
. .3 ==> 0s30 ++> 0s30 -+> -0s30 --> -0s30
. .8 ==> 0s80 ++> 0s80 -+> -0s80 --> -0s80
. 1 ==> 1s00 ++> 1s00 -+> -1s00 --> -1s00
. 1.2 ==> 1s20 ++> 1s20 -+> -1s20 --> -1s20
. 59 ==> 59s00 ++> 59s00 -+> -0m59 --> -59s00
. 59.07 ==> 59s07 ++> 59s07 -+> -0m59 --> -59s07
. 59.997 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 60.1 ==> 1m00 ++> 1m00 -+> -1m00 --> -1m00
. 611 ==> 10m11 ++> 10m11 -+> -0h10 --> -10m11
. 3599.4 ==> 59m59 ++> 59m59 -+> -1h00 --> -59m59
. 3599.5 ==> 1h00 ++> 1h00 -+> -1h00 --> -1h00
. 3661 ==> 1h01 ++> 1h01 -+> -1h01 --> -1h01
. 83400 ==> 23h10 ++> 23h10 -+> -0d23 --> -23h10
. 84700 ==> 23h32 ++> 23h32 -+> -1d00 --> -23h32
. 86400 ==> 1d00 ++> 1d00 -+> -1d00 --> -1d00
. 89900 ==> 1d01 ++> 1d01 -+> -1d01 --> -1d01
. 8467200 ==> 98d00 ++> 98d00 -+> -98d --> -98d00
. 8595936.00 ==> 99d12 ++> 99d12 -+> -99d --> -99d12
. 8638704.00 ==> 100d ++> 100d -+> -100d --> -100d
. 8640000 ==> 100d ++> 100d -+> -100d --> -100d
. 863913600 ==> 9999d ++> 9999d -+> -++++ --> -9999d
. 863965440 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
. 8.6400E+9 ==> +++++ ++> +++++ -+> -++++ --> -+++++.
$/tstfUnitst/ */
call jIni
call tst t, "tstfUnits"
d = 86400
lst = 1 5 13 144 1234 7890 0 234e3 89e6 123e9,
4567891e9 0.123 0.0000456789 345.567e-12 123.4567e-15 ,
abc abcdefghijklmn 1e77 1e-77 18.543e18 20.987e20
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd') ,
'=->' fUnits( '-'word(lst, wx), 'd') ,
'=+>' fUnits( word(lst, wx), 'd', , , '+'),
'=b>' fUnits( word(lst, wx), 'b')
end
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 'd', 7, 3) ,
'=->' fUnits( '-'word(lst, wx), 'd', 7, 3) ,
'=+>' fUnits( word(lst, wx), 'd', 7, 3, '+'),
'=b>' fUnits( word(lst, wx), 'b', 7, 3)
end
call tstEnd t
call tst t, "tstfUnitst"
d = 86400
lst = .3 .8 1 1.2 59 59.07 59.997 60 60.1 611 ,
3599.4 3599.5 3661 d-3000 d-1700 d d+3500 ,
d * 98 d * 99.49 d * 99.985 d*100 d * 9999 d * 9999.6 ,
d * 1e5
do wx=1 to words(lst)
call tstOut t, right(word(lst, wx), 14) ,
'==>' fUnits( word(lst, wx), 't' ) ,
'++>' fUnits( word(lst, wx), 't', , , ' '),
'-+>' fUnits('-'word(lst, wx), 't' ),
'-->' fUnits('-'word(lst, wx), 't', , , ' ')
end
call tstEnd t
return
endProcedure tstfUnits
tstSb: procedure expose m.
/*
$=/tstSb/
### start tst tstSb ###############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
string : 1 'eins?''' v=eins?'
space : 1 >
string : 1 "zwei""" v=zwei"
string ? : 1 ?drei??? v=drei?
*** err: scanErr ending Apostroph missing
. e 1: last token " scanPosition noEnd
. e 2: pos 28 in string 'eins?''' "zwei"""?drei???"noEnd
string : 0 " v=noEnd
$/tstSb/ */
call pipeIni
call tst t, 'tstSb'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call scanSrc s, "'eins?'''" '"zwei"""?drei???"noEnd'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'space :' scanWhile(s, ' ') m.s.tok'>'
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call out 'string ? :' scanString(s, '?') m.s.tok 'v='m.s.val
call out 'string :' scanString(s) m.s.tok 'v='m.s.val
call tstEnd t
return
endProcedure tstSb
tstSb2: procedure expose m.
/*
$=/tstSb2/
### start tst tstSb2 ##############################################
end : 0
char 3 : 1 abc
lit d? : 0 .
lit de : 1 de
lit de ? fg fgh: 1 fg
while HIJ : 0 .
end : 0
while Jih : 1 hi
while ? klj: 1 jklkl ?
end : 1
while ? klj: 0 .
char 3 : 0 .
lit : 0 .
until cba : 0 .
until ?qd : 1 abc
until ?qr : 1 defdef .
until ?qr : 0 .
strEnd ? : 1 ?
strEnd ? : 0 ?
strEnd ? : 1 ab??cd????gh?
strEnd ") ": 1 ab) .
strEnd ") ": 1 ab) cd) ) gh) .
$/tstSb2/ */
call pipeIni
call tst t, 'tstSb2'
call scanSrc s, 'abcdefghijklkl ?'
call out 'end :' scanEnd(s)
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit d? :' scanLit(s, 'd?') m.s.tok
call out 'lit de :' scanLit(s, 'de') m.s.tok
call out 'lit de ? fg fgh:',
scanLit(s, 'de', '?', 'fg', 'fgh') m.s.tok
call out 'while HIJ :' scanWhile(s, 'HIJ') m.s.tok
call out 'end :' scanEnd(s)
call out 'while Jih :' scanWhile(s, 'Jih') m.s.tok
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'end :' scanEnd(s)
call out 'while ? klj:' scanWhile(s, '? klj') m.s.tok
call out 'char 3 :' scanChar(s, 3) m.s.tok
call out 'lit :' scanLit(s) m.s.tok
call scanSrc s, 'abcdefdef ?'
call out 'until cba :' scanUntil(s, 'cba') m.s.tok
call out 'until ?qd :' scanUntil(s, '?qd') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'until ?qr :' scanUntil(s, '?qr') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab??cd????gh?ijk'
call out 'strEnd ? :' scanStrEnd(s, '?') m.s.tok
call scanSrc s, 'ab) cd) ) gh) jk) )'
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call out 'strEnd ") ":' scanStrEnd(s, ') ') m.s.tok
call tstEnd t
return
endProcedure tstSb2
tstScan: procedure expose m.
/*
$=/tstScan.1/
### start tst tstScan.1 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan v tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan q tok 5: "st1" key val st1
scan v tok 1: key val st1
scan a tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan v tok 1: key val str2'mit'apo's
$/tstScan.1/ */
call tst t, 'tstScan.1'
call tstScan1 'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.2/
### start tst tstScan.2 ###########################################
scan src a034,Und hr123sdfER"st1" 'str2''mit''apo''s' .
scan n tok 4: a034 key val .
scan , tok 1: , key val .
scan n tok 3: Und key val .
scan b tok 1: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 1: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 1: key val str2'mit'apo's
$/tstScan.2/ */
call tst t, 'tstScan.2'
call tstScan1 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
/*
$=/tstScan.3/
### start tst tstScan.3 ###########################################
scan src a034,'wie 789abc
scan n tok 4: a034 key val .
scan , tok 1: , key val .
*** err: scanErr ending Apostroph missing
. e 1: last token ' scanPosition wie 789abc
. e 2: pos 7 in string a034,'wie 789abc
scan w tok 1: w key val wie 789abc
scan n tok 2: ie key val wie 789abc
scan s tok 1: key val wie 789abc
*** err: scanErr illegal char after number 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val wie 789abc
scan n tok 3: abc key val wie 789abc
$/tstScan.3/ */
call tst t, 'tstScan.3'
call tstScan1 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
/*
$=/tstScan.4/
### start tst tstScan.4 ###########################################
scan src litEinsefr 23 sdfER'str1'litZwei "str2""mit quo"s .
scan l tok 7: litEins key val .
scan n tok 3: efr key val .
scan b tok 1: key val .
scan d tok 2: 23 key val .
scan b tok 1: key val .
scan n tok 5: sdfER key val .
scan a tok 6: 'str1' key val str1
scan l tok 7: litZwei key val str1
scan b tok 1: key val str1
scan q tok 15: "str2""mit quo" key val str2"mit quo
scan n tok 1: s key val str2"mit quo
scan b tok 1: key val str2"mit quo
$/tstScan.4/ */
call tst t, 'tstScan.4'
call tstScan1 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
/*
$=/tstScan.5/
### start tst tstScan.5 ###########################################
scan src aha q3 = f ab=cdEf eF='strIng' .
scan s tok 1: key val .
scan k tok 0: key aha val def
scan k tok 1: f key q3 val f
scan s tok 1: key q3 val f
scan k tok 4: cdEf key ab val cdEf
scan s tok 1: key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan s tok 1: key eF val strIng
$/tstScan.5/ */
call tst t, 'tstScan.5'
call tstScan1 'k1'," aha q3 = f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg classs, ln
call tstOut t, 'scan src' ln
call scanSrc scanOpt(s), ln
m.s.key = ''
m.s.val = ''
do forever
x = tstScanType(s, classs)
if x == '' then
leave
call tstOut t, 'scan' x 'tok' length(m.s.tok)':' m.s.tok ,
'key' m.s.key 'val' m.s.val
end
return
endProcedure tstScan1
tstScanType: procedure expose m.
parse arg s, opt
cx = 1
a2 = ''
res = 0
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.tstScanType.src = opt
m.tstScanType.pos = cx
call scanString tstScanType
a2 = m.tstScanType.val
cx = m.tstScanType.pos
end
if f == 'a' then
res = scanString(s, "'")
else if f == 'b' then
res = scanSpace(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
if a2 == 0 then
res = scanNatIA(s)
else
res = scanNat(s)
else if f == 'k' then
res = scanKeyValue(s, 'def')
else if f == 'l' then
res = scanLit(s, a2)
else if f == 'q' then
res = scanString(s, '"')
else if f == 'v' then
res = scanVerify(s, a2)
else if f == 'w' then
res = scanWord(s)
else if f == 'y' then
res = scanVerify(s, a2, 'm')
if res then
return f
end
return scanType(s)
endProcedure tstScanType
tstScanRead: procedure expose m.
/*
$=/tstScanRead/
### start tst tstScanRead #########################################
name erste
space
name Zeile
space
nextLine
nextLine
space
name dritte
space
name Zeile
space
name schluss
space
$/tstScanRead/ */
call scanReadIni
call tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(jReset0(scanRead(b)), m.j.cRead)
do while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanVerify(s, ' ') then call tstOut t, 'space'
else if scanReadNL(s) then call tstOut t, 'nextLine'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
end
call jClose s
call tstEnd t
/*
$=/tstScanReadMitSpaceLn/
### start tst tstScanReadMitSpaceLn ###############################
name erste
spaceLn
name Zeile
spaceLn
name dritte
spaceLn
name Zeile
spaceLn
name schluss
spaceLn
$/tstScanReadMitSpaceLn/ */
call tst t, 'tstScanReadMitSpaceLn'
s = scanReadOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpace(s) then call out 'spaceLn'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call scanReadClose s
call tstEnd t
/*
$=/tstScanJRead/
### start tst tstScanJRead ########################################
1 jRead n tok erste val .
2 jRead s tok val .
3 jRead n tok Zeile val .
4 jRead s tok val .
5 jRead n tok dritte val .
6 jRead s tok val .
7 jRead n tok Zeile val .
8 jRead s tok val .
9 jRead n tok schluss val .
10 jRead s tok val .
11 jRead 0 tok 1 val 1
12 jRead s tok val 1
13 jRead + tok + val 1
14 jRead s tok val 1
15 jRead 0 tok 2. val 2..
16 jRead s tok val 2..
17 jRead + tok + val 2..
18 jRead . tok . val 2..
19 jRead s tok val 2..
20 jRead 0 tok +.3 val +.3
21 jRead 0 tok -45e-3 val -45E-3
22 jRead s tok val -45E-3
23 jRead " tok "a""b" val a"b
24 jRead s tok val a"b
25 jRead ' tok 'c''d' val c'd
className 1: ScanRes 18: ScanRes
$/tstScanJRead/ */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(jReset0(scanRead(jClose(b))), '<')
do x=1 while jRead(s)
v = m.s
call out x 'jRead' m.v.type 'tok' m.v.tok 'val' m.v.val
v.x = v
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
/*
$=/tstScanReadPos/
### start tst tstScanReadPos ######################################
1
2
345678
4
5678
4
$/tstScanReadPos/ */
call tst t, 'tstScanReadPos'
b = jBuf(1, 2, 345678, 4)
call scanReadOpen scanReadReset(scanOpt(tstScn), b)
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call scanSetPos tstScn, 3 3
do while scanNat(scanSkip(tstScn))
call tstOut t, m.tstScn.tok
end
call tstEnd t
return
endProcedure tstScanRead
tstScanUtilInto: procedure expose m.
/*
$=/tstScanUtilIntoL/
TEMPLATE P3
DSN('DBAF.DA540769.A802A.P00003.BV5I3NRN.REC')
DISP(OLD,KEEP,KEEP)
TEMPLATE P4
DSN('DBAF.DA540769.A802A.P00004.BV5I3NTK.REC')
DISP(OLD,KEEP,KEEP)
LOAD DATA LOG NO RESUME NO REPLACE COPYDDN(TCOPYD)
STATISTICS INDEX(ALL) REPORT NO UPDATE ALL
EBCDIC CCSID(00500,00000,00000)
SORTKEYS
-- ENFORCE NO
SORTDEVT DISK
SORTNUM 160
WORKDDN(TSYUTD,TSOUTD)
INTO TABLE OA1P.TWB981 PART 1 INDDN TREC134
WORKDDN(TSYUTS,TSOUTS)
INTO TABLE "A540769"
."TWK802A1"
PART 00001 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
, "TS3"
POSITION( 00016:00041) TIMESTAMP EXTERNAL
, "TI4"
POSITION( 00042:00049) TIME EXTERNAL
, "DA5"
POSITION( 00050:00059) DATE EXTERNAL
, "IN6"
POSITION( 00060:00063) INTEGER
, "RE7"
POSITION( 00064:00067) FLOAT(21)
)
INTO TABLE "A540769"."TWK802A1"
PART 00002 INDDN P0
WHEN(00001:00002) = X'0041'
( "DE1"
POSITION( 00003:00010) DECIMAL
, "CH2"
POSITION( 00011:00015) CHAR(00005)
)
dobido
$/tstScanUtilIntoL/
$=/tstScanUtilInto/
### start tst tstScanUtilInto #####################################
-- 1 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. , "TS3"
. POSITION( 00016:00041) TIMESTAMP EXTERNAL
. , "TI4"
. POSITION( 00042:00049) TIME EXTERNAL
. , "DA5"
. POSITION( 00050:00059) DATE EXTERNAL
. , "IN6"
. POSITION( 00060:00063) INTEGER
. , "RE7"
. POSITION( 00064:00067) FLOAT(21)
. ) .
. -- table OA1P.TWB981 part 00001
-- 2 scanUtilInto
. ( "DE1"
. POSITION( 00003:00010) DECIMAL
. , "CH2"
. POSITION( 00011:00015) CHAR(00005)
. ) .
. -- table A540769.TWK802A1 part 00002
-- 3 scanUtilInto
$/tstScanUtilInto/ */
call scanReadIni
b = jBuf()
call mAddst b'.BUF', mapInline('tstScanUtilIntoL')
call tst t, 'tstScanUtilInto'
s = jOpen(jReset0(scanUtilOpt(ScanRead(b))), '<')
do ix=1
call out '--' ix 'scanUtilInto'
if \ scanUtilInto(s) then
leave
call out ' -- table' m.s.tb 'part' m.s.part
end
call tstEnd t
return
endProcedure tstSCanUtilInto
tstScanWin: procedure expose m.
/*
$=/tstScanWin/
### start tst tstScanWin ##########################################
info 0: last token scanPosition erste Zeile dr+
itteZe\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name dritteZeeeile
info 5: last token dritteZeeeile scanPosition zeile4 +
. fuenfueberSechs\npos 1 in line 4: zeile4
spaceNL
name zeile4
spaceNL
name fuenfueberSechsUnddSiebenUNDundUndUAcht
spaceNL
info 10: last token scanPosition undZehnueberElfundNochWeiterZwoe+
lfundim1\npos 9 in line 10: undZehn
name undZehnueberElfundNochWeiterZwoelfundim13
spaceNL
name Punkt
infoE 14: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWin/ */
call scanWinIni
call tst t, 'tstScanWin'
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = jOpen(jReset0(scanWin(b, '15@2')), m.j.cRead)
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanEnd(s)
if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanName(s) then call tstOut t, 'name' m.s.tok
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinRead/
### start tst tstScanWinRead ######################################
info 0: last token scanPosition erste Zeile z3 +
com Ze\npos 1 in line 1: erste Zeile
name erste
spaceNL
name Zeile
spaceNL
name z3
info 5: last token z3 scanPosition com Zeeeile z4 come4 f+
uenf\npos 4 in line 3: z3 com Zeeeile
spaceNL
name z4
spaceNL
name fuenf
spaceNL
info 10: last token scanPosition com Sechs com sieben comA+
cht com\npos 15 in line 5: fuenf c
name com
spaceNL
name Sechs
spaceNL
name com
info 15: last token com scanPosition sieben comAcht com com +
. com\npos 2 in line 7: m sieben com
spaceNL
name sieben
spaceNL
name Acht
spaceNL
info 20: last token scanPosition ueberElfundNochWeit com elfundim+
13\npos 1 in line 11: ueberElfundNoch
name ueberElfundNochWeit
spaceNL
name im13
spaceNL
name Punkt
info 25: last token Punkt scanPosition \natEnd after line 13: im13 +
. Punkt
infoE 26: last token Punkt scanPosition \natEnd after line 13: im13+
. Punkt
$/tstScanWinRead/ */
call tst t, 'tstScanWinRead'
b = jBuf('?erste Zeile?',,'? z3 com Zeeeile?', '? z4 come4 ',
,'? fuenf c?', '?om Sechs co?', '?m sieben com?',
,'?Acht com com ?', '? com ?', '? com undZehn?',
,'?ueberElfundNoch?', '?Weit com elfund?', '?im13 Punkt?')
s = jReset0(scanWin(b, '15@2'))
call scanOpt s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s, m.j.cRead))
do sx=1 while \scanEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if \scanEnd(s) then call scanErr s, 'cannot scan'
if sx // 5 = 0 then
call tstOut t, 'info' sx':' scanInfo(s)
end
call tstOut t, 'infoE' sx':' scanInfo(s)
call tstEnd t
/*
$=/tstScanWinPos/
### start tst tstScanWinPos #######################################
infoA1 1: last token 1 scanPosition 2 +
. 3\npos 2 in line 1: 1
1
2
345678
4
infoB1: last token scanPosition \natEnd after line 4: 4
infoC1: last token scanPosition 678 4\npos 4 in line+
. 3: 345678
678
4
infoA0 1: last token -2 scanPosition -1 -0 1 +
. 2\npos 3 in line -2: -2
-2
-1
-0
1
2
345678
4
infoB0: last token scanPosition \natEnd after line 4: 4
infoC0: last token scanPosition 5678 4\npos 3 in line 3: 345678
5678
4
$/tstScanWinPos/ */
call tst t, 'tstScanWinPos'
b = jBuf(1, 2, 345678, 4)
do ox=1 to 0 by -1
if ox then
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 20))
else
s = scanWinOpen(scanWinReset(scanOpt(tstScn), b, 10),
,'-2 -1 -0')
do nx=1 while scanNum(scanSkip(s))
if nx = 1 then
call tstOut t, 'infoA'ox nx':' scanInfo(s)
call tstOut t, m.s.tok
end
call tstOut t, 'infoB'ox':' scanInfo(s)
call scanSetPos s, 3 3+ox
call tstOut t, 'infoC'ox':' scanInfo(s)
do while scanNat(scanSkip(s))
call tstOut t, m.s.tok
end
call scanClose s
end
call tstEnd t
return
endProcedure tstScanWin
tstScanSqlStmt: procedure expose m.
/*
$=/tstScanSqlStmt/
### start tst tstScanSqlStmt ######################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
cmd8 .
$/tstScanSqlStmt/ */
call pipeIni
call scanWinIni
call tst t, 'tstScanSqlStmt'
b = jBuf('select -- /* c1', ' /* c1 */ current/* c2 " '' ',
,'c3"', ' c4 */time', 'stamp-- c5', 'from s.1; /* c6 */ ;' ,
,';update ";--""''/*";; del123',
, 'ete ''*/''''"'' / 3 - 1 -- c7', '/*c8 */ ' ,
, ';terminator test; ','terminator|; und-- ', 'so| | |',
, 'term: --#SET TERMINATOR : oder', 'ist: ',
, 'term> /*--#SET TERMINATOR > oder', ' */ in com nein >:')
call scanWinOpen scanSqlStmtOpt(scanWinReset(tstJcat, b, 30), ';')
call scanSqlOpt tstJcat
do sx=1 until nx = ''
nx = scanSqlStmt(tstJCat)
call tstOut t, 'cmd'sx nx
end
call scanReadCLose tstJCat
call tstEnd t
/*
$=/tstScanSqlStmtRdr/
### start tst tstScanSqlStmtRdr ###################################
cmd1 select current time stamp from s.1
cmd2 update ";--""'/*"
cmd3 delete '*/''"' / 3 - 1
cmd4 terminator test
cmd5 und so
cmd6 term: ist
cmd7 term> in com nein >
$/tstScanSqlStmtRdr/ */
call tst t, 'tstScanSqlStmtRdr'
r = jOpen(ScanSqlStmtRdr(b, 30), '<')
do sx=1 while jRead(r)
call tstOut t, 'cmd'sx m.r
end
call jClose r
call tstEnd t
return
endProcedure tstScanSqlStmt
tstScanSql: procedure expose m.
call scanWinIni
/*
$=/tstScanSqlId/
### start tst tstScanSqlId ########################################
sqlId ABC
spaceNL
sqlId AB__345EF
spaceNL
$/tstScanSqlId/ */
call tst t, 'tstScanSqlId'
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlDelimited/
### start tst tstScanSqlDelimited #################################
sqlDeId ABC
spaceNL
sqlDeId AB_3F
spaceNL
sqlDeId abc
spaceNL
sqlDeId ab_Ef
spaceNL
$/tstScanSqlDelimited/ */
call tst t, 'tstScanSqlDelimited'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlQualified/
### start tst tstScanSqlQualified #################################
sqlQuId ABC 1 ABC
sqlQuId AB_3F 1 AB_3F
sqlQuId abc 1 abc
sqlQuId ab_Ef 1 ab_Ef
sqlQuId EINS.Zwei.DREI 3 EINS
sqlQuId vi er.fu enf 2 vi er
$/tstScanSqlQualified/ */
call tst t, 'tstScanSqlQualified'
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',right('"ab_', 72),'Ef"-- kom',
, 'eins."Zwei', '" -- com', ' . -- com', ' -- com',
, 'drei -- ko', '"vi er"."fu enf " -- co')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNum/
### start tst tstScanSqlNum #######################################
sqlNum 1
spaceNL
sqlNum 2..
spaceNL
sqlNum .3
spaceNL
sqlNum 4.5
spaceNL
sqlNum +6
spaceNL
sqlNum +7.03
spaceNL
sqlNum -8
spaceNL
sqlNum -.9
spaceNL
sqlNum 1E2
spaceNL
sqlNum -2.E-2
spaceNL
sqlNum +.3E+3
spaceNL
$/tstScanSqlNum/ */
call tst t, 'tstScanSqlNum'
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlNumUnit/
### start tst tstScanSqlNumUnit ###################################
sqlNumUnit 1 KB
spaceNL
sqlNumUnit .3 MB
sqlNumUnit .5
sqlNumUnit +6.E-5 B
spaceNL
sqlNumUnit -7
char *
spaceNL
sqlNumUnit -.8
char T
char B
spaceNL
*** err: scanErr bad unit TB after +9..
. e 1: last token Tb scanPosition .
. e 2: pos 41 in line 1: 1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.T+
b
sqlNumUnit +9..
spaceNL
$/tstScanSqlNumUnit/ */
call tst t, 'tstScanSqlNumUnit'
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while \scanEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpace(s) then call tstOut t, 'spaceNL'
else if scanChar(s ,1) then call tstOut t, 'char' m.s.tok
else call scanErr s, 'cannot scan'
end
call tstEnd t
/*
$=/tstScanSqlClass/
### start tst tstScanSqlClass #####################################
i a 1 A
d "bC" 1 bC
q d.e 2 D.E
q f." g".h 3 F. g.H
s 'ij''kl' 3 ij'kl
s x'f1f2' 3 12
s X'f3F4F5' 3 345
.. . 3 .
n .0 3 .0
n 123.4 3 123.4
n 5 3 5
i g 1 G
$/tstScanSqlClass/ */
call tst t, 'tstScanSqlClass'
b = jBuf('a "bC" d.e f." g".h' "'ij''kl' x'f1f2' X'f3F4F5'" ,
, '. .0 123.4 5 g')
h = scanOpen(scanSqlReset(tstScn, b))
do sx=1 while scanSqlClass(h)
call tstOut t, m.h.sqlClass m.h.tok m.h.val.0 m.h.val
end
call tstEnd t
return
endProcedure tstScanSql
/****** tstData begin *************************************************/
tstData: procedure expose m.
parse arg ty 2 le 'n' nu, l, r, num
abs = abs(num)
if nu \== '' then do
if abs // 5 = 0 then
return 'null' || (abs % 5 // nu + 1)
end
if ty = 'c' then do
if le = '' then
le = 8
le = abs // le + 1
if r = '' then
r = '+'
return left(l || num || r, le, right(r, 1))
end
if pos(ty, 'ief') < 1 then
call err 'bad type' ty
nn = abs
if abbrev(num, '-') | abbrev(num, '+') then
parse var num si 2 nn
else
si = ''
if ty == 'e' then
ex = 'e' || left('-', abs // 2) || (abs // 15)
else
ex = ''
if le \== '' then
nn = right(nn, abs // max(1, le - length(si||ex)) + 1, 1)
if ty \== 'i' & (abs // 4) \= 0 & length(nn) > 1 then
nn = overlay('.', nn, length(nn) - abs // length(nn))
return si || nn || ex
endProcedure tstData
tstDataClassFo: procedure expose m.
parse arg flds
ty = ''
do fx=1 by 2 to words(flds)
if word(flds, fx) = '.' then
ty = ty', v'
else
ty = ty', f' word(flds, fx) 'v'
end
t = classNew('n* tstData u' substr(ty, 2))
fo = oNew(m.t.name)
ff = oFlds(fo)
do fx=1 to m.ff.0
f = fo || left('.', m.ff.fx \== '') || m.ff.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
ff = oFlds(fo)
do x=f to t
o = oCopy(fo)
do fx=1 to m.ff.0
f = o || left('.', m.ff.fx \== '') || m.ff.fx
m.f = tstData(m.f, m.ff.fx, '+'m.ff.fx'+', x)
end
call out o
end
return
endProcedure tstDataClassOut
/****** tst **********************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
tstUtTime: procedure expose m.
say 'begin' utTime() sysvar('sysnode')
do 3000000
end
call sleep 1
say 'end ' utTime()
return
tstUtc2d: procedure expose m.
/*
$=/tstUtc2d/
### start tst tstUtc2d ############################################
. ff 255
. ffff 65535
. 10000 65536 65536 = 1 * 16 ** 4
. 10001 65537
. ffffff 16777215
. 1000000 16777216 16777216 = 1 * 16 ** 6
. 1000001 16777217
. 20000FF 33554687
. 100000000 4294967296 4294967296 = 1 * 16 ** 8
. 300000000 12884901888 12884901888 = 3 * 16 ** 8
. 3020000EF 12918456559
$/tstUtc2d/
*/
numeric digits 33
call tst t, 'tstUtc2d'
all = 'ff ffff 10000 10001 ffffff 1000000 1000001 20000FF' ,
'100000000 300000000 3020000EF'
do ax = 1 to words(all)
a = word(all, ax)
if substr(a, 2) = 0 then
b = right(left(a, 1) * 16 ** (length(a)-1), 15) ,
'=' left(a, 1) '* 16 **' (length(a)-1)
else
b = ''
call tstout t, right(a, 15)right(utc2d(x2c(a)), 15)b
end
call tstEnd t
return
endProcedure tstUtc2d
tstCI: procedure expose m.
parse arg m, nm
m.m.CIO = 0
signal tstCIwork
tstCIO: procedure expose m.
parse arg m, nm
m.m.CIO = 1
tstCIwork:
m.m.name = nm
m.m.cmp.1 = left('### start tst' nm '', 67, '#')
do ix=2 to arg()-1
m.m.cmp.ix = arg(ix+1)
end
m.m.cmp.0 = ix-1
if m.m.CIO then
call tstCO m
return
tstCO: procedure expose m.
parse arg m
call tst2dpSay m.m.name, m'.CMP', 68
return
/*--- initialise m as tester with name nm
use inline input nm as compare lines -----------------------*/
tstReset: procedure expose m.
parse arg m, nm
call tstIni
m.m.name = nm
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
m.err.count = 0
m.tst.act = m
if \ datatype(m.m.trans.0, 'n') then
m.m.trans.0 = 0
m.m.trans.old = m.m.trans.0
return
endProcedure tstReset
tst: procedure expose m.
parse arg m, nm, cmpSt
call tstReset m, nm
m.tst.tests = m.tst.tests+1
if cmpSt == '' then do
cmpSt = mCut(t'.CMP', 0)
call tst4dp cmpSt, mapInline(nm)
end
m.m.cmp = cmpSt
m.m.moreOutOk = 0
call mAdd mCut(m'.IN', 0), 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei .schluss.'
call tstOut m, left('### start tst' nm '', 67, '#')
call errReset 'h', 'return tstErrHandler(ggTxt)'
m.m.errCleanup = m.err.cleanup
if m.tst.ini.j \== 1 then do
m.tst_m = m
/* call err implement outDest 'i', 'call tstOut' quote(m)', msg'
*/ end
else do
drop m.tst_m
m.m.jWriting = 0
call jOpen jReset(oMutatName(m, 'Tst')), '>'
m.m.in.jReading = 0
call jOpen jReset(oMutatName(m'.IN', 'Tst')), '<'
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m'.IN'
m.j.out = m
end
else do
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
call pipe '+Ff', m , m'.IN'
end
end
return m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt opt2
cmp = m.m.cmp
m.m.jReading = 0
m.m.jWriting = 0
drop m.tst_m
if m.tst.ini.j == 1 then do
m.m.jReading = 0
m.m.jWriting = 0
if m.tst.ini.e \== 1 then do
m.j.in = m.m.oldJin
m.j.out = m.m.oldOut
end
else do
if m.j.in \== m'.IN' | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipe '-'
if m.pipe.0 <> 2 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 2'
end
end
if m.m.err = 0 then
if m.m.errCleanup \= m.err.cleanup then
call tstErr m, 'err.Cleanup' m.err.cleanup '<> old',
m.m.errCleanup
if m.m.out.0 \= m.cmp.0 & \ (m.m.moreOutOk,
& m.m.out.0 > m.cmp.0) then do
call tstErr m, 'old' m.cmp.0 'lines \= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.cmp.0)
say 'old - ' m.cmp.nx
end
end
call errReset 'h'
m.tst.act = ''
soll = 0
if opt = 'err' then do
soll = opt2
if m.m.err \= soll then
call err soll 'errors expected, but got' m.m.err
end
if m.m.err \= soll then do
say 'new lines:' (m.m.out.0 - 1)
call tst2dpSay m.m.name, m'.OUT', 68
end
say left('###' m.m.name 'end with' m.m.err 'errors ', 67, '#')
if 1 & m.m.err \= soll then
call err 'dying because of' m.m.err 'errors'
m.m.trans.0 = m.m.trans.old
return
endProcedure tstEnd
tst2dp: procedure expose m.
parse arg st, dp, ml
dx = m.dp.0
do sx=1 to m.st.0
li = m.st.sx
cx = 1
do until cx > length(li)
c = substr(li, cx, 1)
ou = left('.', strip(c) == '' | pos(c, '.+') > 0)
ex = min(length(li),cx+ml-length(ou)-2)
ou = ou || substr(li, cx, ex+1-cx)
dx = dx + 1
c = right(ou, 1)
if ex < length(li) then
m.dp.dx = ou || '+'
else if strip(c) == '' | pos(c, '.+') > 0 then
m.dp.dx = ou || '.'
else
m.dp.dx = ou
cx = ex +1
end
end
m.dp.0 = dx
return
endProcedure tst2dp
tst2dpSay: procedure expose m.
parse arg name, st, ml
say '$=/'name'/'
call tst2dp st, mCut('TST.TMP', 0), 68
do nx=1 to m.tst.tmp.0
say ' ' m.tst.tmp.nx
end
say '$/'name'/'
return tst2dpSay
tst4dp: procedure expose m.
parse arg st, dp
sx = m.st.0
inData = 0
data = ''
do dx=1 to m.dp.0
li = strip(m.dp.dx)
if pos(left(li, 1), '.+') > 0 then
li = substr(li, 2)
if right(li, 1) == '+' then do
inData = 1
data = data || left(li, length(li)-1)
iterate
end
if right(li, 1) == '.' then
li = left(li, length(li)-1)
sx = sx + 1
m.st.sx = repAll(data || li, '$ä', '/*', '$ö', '*/')
inData = 0
data = ''
end
m.st.0 = sx
if inData then
call err 'end inData'
return
endProcedure tst4dp
/*--- write to test: say lines and compare them ----------------------*/
tstOut: procedure expose m.
parse arg m, arg
do tx=m.m.trans.0 by -1 to 1
arg = repAll(arg, word(m.m.trans.tx, 1),
, subword(m.m.trans.tx, 2))
end
call mAdd m'.OUT', arg
nx = m.m.out.0
cmp = m.m.cmp
c = m.cmp.nx
if nx > m.cmp.0 then do
if nx = m.cmp.0+1 & \ m.m.moreOutOK then
call tstErr m, 'more new Lines' nx
end
else if c \== arg then do
do cx=1 to min(length(c), length(arg)) ,
while substr(c, cx, 1) == substr(arg, cx, 1)
end
msg = 'old line' nx '<> new overnext, firstDiff' cx',',
'len old' length(c)', new' length(arg)
if cx > 10 then
msg = overlay('|', msg, cx-10)
call tstErr m, msg
say c
end
say arg
return 0
endProcedure tstOut
jWrite1Met: procedure expose m.
parse arg f1
return "jWrite if m.m.buf.0\==1 then call err 'bad jWrite1Met';" ,
"var = m'.BUF.1'; m.m.buf.0 = 0;" f1
jWriteBMet: procedure expose m.
parse arg f1, fe
return "jWrite" ,
copies("do wx=1 to m.m.buf.0;" ,
"var = m'.BUF.'wx;" f1"; end;", f1 <> '') ,
copies("vBu = m'.BUF';" fe";", fe <> ''),
"m.m.bufI0 = m.m.bufI0 + m.m.buf.0; m.m.buf.0 = 0"
tstWrite: procedure expose m.
parse arg m, var
cl = objClass(var)
if cl == m.class_N then do
call tstOut m, 'tstR: @ obj null'
end
else if cl == m.class_S then do
call tstOut m, var
end
else if abbrev(var, m.o_escW) then do
call tstOut m, o2String(var)
end
else if cl == m.class_V then do
call tstOut m, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut m, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut m, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut m, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut m, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
do tx=m.m.trans.0 by -1 to 1 ,
while word(m.m.trans.tx, 1) \== var
end
if tx < 1 then
call mAdd M'.TRANS', var 'tstWriteoV' ||(m.m.trans.0+1)
call classOut , var, 'tstR: '
end
return
endProcedure tstWrite
tstRead: procedure expose m.
parse arg mP
if right(mP, 3) \== '.IN' then
call err 'tstRead bad m' mP
m = left(mP, length(mP)-3)
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
call tstOut m, '#jIn' ix'#' m.m.in.ix
m.mP = m.m.in.ix
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstRead
tstFilename: procedure expose m.
parse arg suf, opt
if m.err.os == 'TSO' then do
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' then do
if sysDsn("'"dsn"'") \== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
call csiOpen 'TST.CSI', dsn'.**'
do while csiNext('TST.CSI', 'TST.FINA')
say 'deleting csiNext' m.tst.fina
call adrTso "delete '"m.tst.fina"'"
end
end
return dsn
end
else if m.err.os == 'LINUX' then do
if abbrev(suf, '/') then
fn = suf
else
fn = .Stream%%new('~/tmp/tst/'suf)%%qualify /* full path */
cx = lastPos('/', fn)
if cx > 0 then do
dir = left(fn, cx-1)
if \sysIsFileDirectory(dir) then
call adrSh "mkdir -p" dir
if \sysIsFileDirectory(dir) then
call err 'tstFileName could not create dir' dir
end
if opt \= 'r' then
nop
else if sysIsFile(fn) then
call sysFileDelete fn
else if sysIsFileDirectory(fn) then
call adrSh 'rm -r' fn
return fn
end
else
call err 'tstFilename does not implement os' m.err.os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
/* say '###### astStatsTotals'
do sx=1 to words(m.comp_astStats)
k = word(m.comp_astStats, sx)
say f('%5c %7i %7i %7i', k, m.comp_astStats.k,
, m.comp_astStatT.k, m.comp_astStat1.k)
end
say '######' */
say '######' m.tst.tests 'tests with' ,
m.tst.err 'errors in' m.tst.errNames
say '######'
say '######'
if m.tst.err \== 0 then
call err m.tst.err 'errors total'
return
endProcedure tstTotal
/*--- test err: message, count it and continue -----------------------*/
tstErr: procedure expose m.
parse arg m, msg
say '### error' msg
m.m.err = m.m.err + 1
m.tst.err = m.tst.err + 1
nm = m.m.name
if wordPos(nm, m.tst.errNames) < 1 then
m.tst.errNames = m.tst.errNames nm
return 0
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
m = m.tst.act
if m == '' then
call err ggTxt
m.err.count = m.err.count + 1
call splitNl err, errMsg(' }'ggTxt)
call tstOut m.tst.act, '*** err:' m.err.1
do x=2 to m.err.0
call tstOut m, ' e' (x-1)':' m.err.x
end
return 0
endSubroutine tstErrHandler
tstTrc: procedure expose m.
parse arg msg
m.tst.trc = m.tst.trc + 1
say 'tstTrc' m.tst.trc msg
return m.tst.trc
endProcedure tstTrc
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini \== 1 then do
m.tst.ini = 1
call mapIni
m.tst.err = 0
m.tst.trc = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
end
if m.tst.ini.j \== 1 & m.j.ini == 1 then do
m.tst.ini.j = 1
call classNew 'n Tst u JRW', 'm',
, "jOpen",
, "jRead return tstRead(m)",
, jWrite1Met("call tstWrite m, m.var")
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copy tstAll end **************************************************/
/* copy wshCopy begin ************************************************/
wshIni: procedure expose m.
call compIni
call sqlIni
call scanWinIni
return
endProcedure wshIni
/* copy wshCopy end ************************************************/
/* copy db2Util begin ************************************************/
tstDb2Ut: procedure expose m.
/*
$=/tstDb2Ut/
$/tstDb2Ut/
*/
call pipeIni
call tst t, 'tstDb2Ut'
call mAdd mCut(t'.IN', 0), ' template old ,' ,
, 'LOAD DATA INDDN oldDD ' ,
, '( cols )'
call db2UtilPunch 'rep iDsn=DSN.INPUT.UNL'
call tstEnd t
return
endProcedure tstDb2Ut
/* ???????????? achtung nicht fertig |
Idee: allgemein Punch Umformungs Utility
aber man müsste wohl auf scan Util umstellen
und abstürzen wenn man etwas nicht versteht
GrundGerüst von cadb2 umgebaut
????????????????? */
db2UtilPunch: procedure expose m.
parse upper arg args
call scanSrc scanOpt(s), args
a.rep = 1
a.tb = ''
a.trunc = 0
a.iDD = ''
a.iDSN = ''
do while scanKeyValue(scanSkip(s), 1)
ky = m.s.key
say '????ky' ky m.s.val
if wordPos(ky, 'REP TB TRUNC IDD IDSN') < 1 then
call scanErr s, 'bad key' ky
a.ky = m.s.val
end
if a.iDSN \== '' then do
if a.iDD == '' then
a.iDD = 'IDSN'
call out ' TEMPLATE' a.iDD 'DSN('a.iDsn')'
end
do while in() & word(m.in, 1) <> 'LOAD'
call out m.in
end
ll = space(m.in, 1)
if \ abbrev(ll, 'LOAD DATA ') then
call err 'bad load line:' m.in
call out subword(m.in, 1, 2) 'LOG NO'
if abbrev(ll, 'LOAD DATA INDDN ') then
call db2UtilPunchInDDn word(ll, 4)
else if \ abbrev(ll, 'LOAD DATA LOG ') then
call err 'bad load line' ix':' m.i.ix
if a.rep then
call out ' STATISTICS INDEX(ALL) UPDATE ALL'
call out ' DISCARDS 1'
call out ' ERRDDN TERRD'
call out ' MAPDDN TMAPD '
call out ' WORKDDN (TSYUTD,TSOUTD) '
call mAdd o, ' SORTDEVT DISK '
do ix=ix+1 to m.i.0
if pos('CHAR(', m.i.ix) > 0 then
call mAdd o, strip(m.i.ix, 't') 'TRUNCATE'
else if word(m.i.ix, 1) word(m.i.ix, 3) == 'PART INDDN' then
call mAdd o, m.i.ix,
, ' RESUME NO REPLACE COPYDDN(TCOPYD)' ,
, ' DISCARDDN TDISC '
else
call mAdd o, m.i.ix
end
call writeDsn oDsn ':~'iDsn, 'M.O.', , 1
return
endProcedure db2UtilPunch
db2UtilPunchInDDn:
parse arg inDDn
if a.iDD == '' then
ll = ' INDDN' inDDn
else
ll = ' INDDN' a.iDD
if a.rep then
call out ll 'RESUME NO REPLACE COPYDDN(TCOPYD)'
else
call out ll 'RESUME YES'
call out ' DISCARDDN TDISC'
return
endSubroutine db2UtilPunchInDDn
/* copy db2Util end ************************************************/
/* 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 - 69 then
return (left(y, 2) + 1)substr(s4, 3)
else
return s4
endProcedure timeYear24
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeYear2Y: procedure expose m.
parse arg y
return substr('ABCDEFGHIJKLMNOPQRST' , ((y + 10) // 20) + 1, 1)
/*--- convert 2 or 4 digit year Y (A=0...T=19) ----------------------*/
timeY2Year: procedure expose m.
parse arg i
j = pos(i, 'ABCDEFGHIJKLMNOPQRST') - 1
if j < 0 then
call err 'timeYearY24 bad input' i
y = left(date('S'), 4)
r = y - (y+10) // 20 + j
if r < y - 15 then
return r + 20
else if r > y + 4 then
return r - 20
else
return r
endProcedure timeY2Year
/*--- 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)
/*--- convert numeric hour 78 to H8 (A=0..D=3) ----------------------*/
timeHour2H: procedure expose m.
parse arg h
h = right(h, 2, 0)
return substr('ABCD', left(h, 1)+1, 1)substr(h, 2)
/*--- convert H8 to numeric Hour 78 (A=0..D=3) ----------------------*/
timeH2Hour: procedure expose m.
parse arg h
p = pos(left(h, 1), 'ABCD') - 1
if p < 0 | length(h) \== 2 then
call err 'bad H hour' h
return p || substr(h, 2)
/*--- read timeZoneOffset and leapSeconds registers
and set variables for uniq ----------------------------------*/
timeIni: procedure expose m.
parse arg debug
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
m.time_ini = 1
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 sort begin ****************************************************/
sortComparator: procedure expose m.
parse arg cmp, le, ri
if cmp == '' then
cmp = '<<='
if length(cmp) < 6 then
m.sort_comparator = 'cmp =' le cmp ri
else if pos(';', cmp) < 1 then
m.sort_comparator = "aLe =" le"; aRi =" ri"; cmp =" cmp
else
m.sort_comparator = "aLe =" le "; aRi =" ri";" cmp
return
endProcedure sort
sortWords: procedure expose m.
parse arg wrds, cmp
if words(wrds) <= 1 then
return strip(wrds)
m.sort_ii.0 = words(wrds)
do sx=1 to m.sort_ii.0
m.sort_ii.sx = word(wrds, sx)
end
call sort sort_ii, sort_oo, cmp
r = m.sort_oo.1
do sx=2 to m.sort_oo.0
r = r m.sort_oo.sx
end
return r
endProcedure sortWords
sortWordsQ: procedure expose m.
parse arg wrds, cmp
call sortComparator cmp, 'word(le, lx)', 'word(ri, rx)'
return strip(sortWord1(wrds))
endProcedure sortWordsQ
sortWord1: procedure expose m.
parse arg wrds
if words(wrds) <= 1 then
return wrds
h = words(wrds) % 2
le = sortWord1(subWord(wrds, 1, h))
ri = sortWord1(subWord(wrds, h+1))
lx = 1
rx = 1
res = ''
do forever
interpret m.sort_comparator
if cmp then do
res = res word(le, lx)
if lx >= words(le) then
return res subword(ri, rx)
lx = lx + 1
end
else do
res = res word(ri, rx)
if rx >= words(ri) then
return res subword(le, lx)
rx = rx + 1
end
end
endProcedure sortWord1
sort: procedure expose m.
parse arg i, o, cmp
call sortComparator cmp, 'm.l.l0', 'm.r.r0'
call sort1 i, 1, m.i.0, o, 1, sort_work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort_comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask
if symbol('m.match_m.mask') == 'VAR' then
interpret m.match_m.mask
else
interpret matchGen('MATCH_M.'mask, mask, 'm')
endProcedure match
matchGG: procedure expose m.
parse arg wert, cd, vars
interpret cd
endProcedure matchGG
matchVars: procedure expose m.
parse arg wert, mask, vars
if symbol('m.match_v.mask') == 'VAR' then
interpret m.match_v.mask
else
interpret matchGen('MATCH_V.'mask, mask, 'v')
endProcedure match
matchRep: procedure expose m.
parse arg wert, mask, mOut
vars = 'MATCH_VV'
mm = mask'\>'mOut
if symbol('m.match_r.mm') == 'VAR' then
interpret m.match_r.mm
else
interpret matchGen('MATCH_R.'mm, mask, 'r', mOut)
endProcedure matchRep
matchGen: procedure expose m.
parse arg m, mask, opt, mOut
a = matchScan(match_sM, mask)
if symbol('m.match_g') \== 'VAR' then
m.match_g = 0
if opt \== 'r' then do
r = matchgenMat(a, opt, 1, m.a.0, 0)
end
else do
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchgenMat(a, 'v', 1, m.a.0, 0)
o = matchScan(match_sO, mOut)
r = matchGenRep(o, m.a.wildC)
r = 'if matchGG(wert, m.'sub', vars) then return' r';' ,
'else return "";'
end
m.m = r
return r
endProcedure matchGen
matchScan: procedure expose m.
parse arg a, mask, opt
s = match_scan
call scanSrc s, mask
ax = 0
vx = 0
m.a.wildC = ''
do forever
if scanUntil(s, '*?&\') then do
if m.a.ax == 'c' then do
m.a.ax.val = m.a.ax.val || m.s.tok
end
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if scanChar(s, 1) then do
if pos(m.s.tok, '*?') > 0 then do
ax = ax + 1
vx = vx + 1
m.a.ax = m.s.tok
m.a.ax.ref = vx
m.a.wildC = m.a.wildC || m.s.tok
end
else if m.s.tok == '\' then do
call scanChar s, 1
if pos(m.s.tok, '\*?&') < 1 then
return scanErr(s, 'bad char after \')
if abbrev(m.a.ax, 'c') then
m.a.ax.val = m.a.ax.val || m.s.tok
else do
ax = ax + 1
m.a.ax = 'c'
m.a.ax.val = m.s.tok
end
end
else if m.s.tok == '&' then do
if opt \== 'r' then
call scanErr s, '& in input'
if \ scanChar(s,1) | pos(m.s.tok, 'ms123456789')<1 then
call scanErr s, 'bad & name' m.s.tok
ax = ax + 1
m.a.ax = '&'
m.a.ax.ref = m.s.tok
end
else
call scanErr s, 'bad char 1 after until'
end
else
leave
end
m.a.0 = ax
if vx \== length(m.a.wildC) then
call scanErr 'vars' m.a.wildC 'mismatches' vx
return a
endProcedure matchScan
matchGenMat: procedure expose m.
parse arg a, opt, fx, tx, minLL
ml = 0
if fx == 1 then do
do ax=1 to m.a.0
if m.a.ax == '?' then
ml = ml + 1
else if m.a.ax == 'c' then
ml = ml + length(m.a.ax.val)
m.a.minLen.ax = ml
end
end
r = ''
ret1 = ''
ret1After = ''
lO = 0
do fy=fx to tx
if m.a.fy == 'c' then do
r = r 'if substr(wert,' (1+lO)
if fy < m.a.0 then
r = r',' length(m.a.fy.val)
r = r') \==' quote(m.a.fy.val, "'") 'then return 0;'
lO = lO + length(m.a.fy.val)
end
else if m.a.fy == '?' then do
lO = lO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' lO', 1);'
end
else if m.a.fy == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
rO = 0
do ty=tx by -1 to fy
if m.a.ty == 'c' then do
rO = rO + length(m.a.ty.val)
r = r 'if substr(wert, length(wert) -' (rO - 1)',' ,
length(m.a.ty.val)')' ,
'\==' quote(m.a.ty.val, "'") 'then return 0;'
end
else if m.a.ty == '?' then do
rO = rO + 1
if opt == 'v' then
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert, length(wert) -' (rO-1)', 1);'
end
else if m.a.ty == '*' then
leave
else
call err 'bad match ast' a'.'fy m.a.fy
end
if fy > ty then do /* every thing is handled with fix len */
if fx = tx & abbrev(m.a.fx, 'c') then
r = 'if wert \==' quote(m.a.fx.val, "'") ,
'then return 0;'
else
r = 'if length(wert) \==' (lO + rO) 'then return 0;' r
end
else do
myMiLe = m.a.minLen.ty
if fy > 1 then do
fq = fy -1
myMiLe = myMiLe - m.a.minLen.fq
end
if minLL < myMiLe then
r = 'if length(wert) <' myMiLe 'then return 0;' r
if fy = ty & m.a.fy == '*' then /* single * */
ret1 = ret1 'm.vars.'m.a.fy.ref ,
'= substr(wert,' (1+lO)', length(wert) -' (lO+rO)');'
else if fy < ty & abbrev(m.a.fy, '*') ,
& abbrev(m.a.ty, '*') then do
/* several variable length parts */
suMiLe = m.a.minLen.ty - m.a.minLen.fy
m.match_g = m.match_g + 1
sub = 'MATCH_G'm.match_g
m.sub = matchGenMat(a, opt, fy+1, ty, suMiLe)
if rO = 0 then
subV = 'substr(wert, lx)'
else do
r = r 'wSub = left(wert, length(wert) -' rO');'
subV = 'substr(wSub, lx)'
end
r = r 'do lx = length(wert) -' (suMiLe+rO-1) ,
'by -1 to' (lO+1)';' ,
'if \ matchGG('subV', m.'sub', vars) then' ,
'iterate;'
ret1 = ret1 'm.vars.'m.a.fy.ref '= substr(wert,' (lO+1) ,
|| ', lx -' (lO+1)');'
ret1After = 'end; return 0;'
end
else
call err 'matchGenMat bad case' a'.'fy m.a.fy a'.'ty m.a.ty
end
if opt == 'v' & fx == 1 then do
if r <> '' then
r = 'm.vars.0 = -9;' r
ret1 = ret1 'm.vars.0 =' length(m.a.wildC)';'
end
r = r ret1 'return 1;' ret1After
return r
endProcedure matchGenMat
matchGenRep: procedure expose m.
parse arg o, wildC
xQ = 0
xS = 0
do ox=1 to m.o.0
if m.o.ox == '?' then do
xQ = pos('?', wildC, xQ+1)
if xQ < 1 then
call err 'unmatchted ?' ox
m.o.ox.re2 = xQ
end
else if m.o.ox == '*' then do
xS = pos('*', wildC, xS+1)
if xS < 1 then
call err 'unmatchted *' ox
m.o.ox.re2 = xS
end
else if m.o.ox == '&' & m.o.ox.ref >> '0' then do
if m.o.ox.ref > length(wildC) then
call err '&'m.o.ox.ref 'but wildcards' wildC
xQ = m.o.ox.ref
xS = xQ
m.o.ox.re2 = xQ
end
end
r = ''
do ox=1 to m.o.0
if abbrev(m.o.ox, 'c') then
r = r '||' quote(m.o.ox.val, "'")
else if m.o.ox == '&' & m.o.ox.re2 == 's' then
r = r '|| wert'
else if m.o.ox == '&' & m.o.ox.re2 == 'm' then
r = r '||' quote(mask, "'")
else if pos(m.o.ox, '*?&') > 0 then
r = r '|| m.vars.'m.o.ox.re2
end
if r=='' then
return "''"
else
return substr(r, 5)
endProcedure matchGenRep
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/***** initialisation *************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
call mNewArea 'COMP.AST', '='
m.comp_chOp = '.-<@|?%^'
m.comp_chKind = '.-=#@:%^'
m.comp_chKiNO = '=:#'
m.comp_chKiNBOE = '=<#:' /* nonBLock only expression not Primary*/
call mPut 'COMP_INFO..', "object"
call mPut 'COMP_INFO.-', "string"
call mPut 'COMP_INFO.=', "skeleton"
call mPut 'COMP_INFO.#', "text"
call mPut 'COMP_INFO.@', "rexxShell"
call mPut 'COMP_INFO.:', "pureShell"
m.comp_chDol = '$'
m.comp_chSpa = ' 'x2c('09')
call mPut 'COMP_EXTYPE.b', m.comp_chDol'{}' /* braces */
call mPut 'COMP_EXTYPE.d', m.comp_chDol /* data */
call mPut 'COMP_EXTYPE.s', m.comp_chDol /* strip */
call mPut 'COMP_EXTYPE.w', m.comp_chDol||m.comp_chSpa /* word */
m.comp.idChars = m.ut_alfNum'@_'
m.comp.wCatC = 'compile'
m.comp.wCatS = 'do withNew with for forWith ct proc arg table'
m.comp_astOps = m.comp_chOp'])&'
m.comp_astOut = '.-@<^' /*ast kind for call out */
m.comp_astStats = ''
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = in2File(src)
return nn
endProcedure comp
/*--- compile and run ------------------------------------------------*/
compRun: procedure expose m.
parse arg spec, inO, ouO, infoA
cmp = comp(inO)
r = compile(cmp, spec)
if infoA \== '' then
m.infoA = 'run'
if ouO \== '' then
call pipe '+F', ouO
call oRun r
if ouO \== '' then
call pipe '-'
return 0
endProcedure compRun
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
ki = '@'
spec = strip(spec, 'l')
if spec \== '' then
if pos(left(spec, 1), m.comp_chKind'*') > 0 then do
ki = left(spec, 1)
spec = substr(spec, 2)
end
call compBegin m, ki, spec
s = m.m.scan
res = compileWsh(m)
if 0 then
call compAstSay res, 0
if \ scanEnd(s) & m.m.out == '' then
return scanErr(s, m.comp_info.ki "expected: compile",
ki "stopped before end of input")
call compEnd m
if res == '' then
return ''
cd = compAst2Rx(m, ']', res)
if 0 then
say cd
return oRunner(cd)
endProcedure compile
compBegin: procedure expose m.
parse arg m, ki, spec
m.m.scan = m'.scan'
m.m.out = ''
m.m.end = ''
m.m.defKind = ki
s = m.m.scan
if m.m.cmpRdr == '' then
call scanOpt scanSrc(s, spec), , '0123456789'
else
call scanReadOpen scanReadReset(scanOpt(s, , '0123456789'),
, m.m.cmpRdr), spec' '
return m
endProcedure compBegin
compEnd: procedure expose m.
parse arg m
if m.m.cmpRdr \== '' then
call scanReadClose m.m.scan
return m
endProcedure compEnd
/*--- compile wsh until eof or unknown syntax ------------------------*/
compileWsh: procedure expose m.
parse arg m
s = m.m.scan
res = compAst(m, '[')
eOld = m.err.count
do while m.m.out == '' & \ scanEnd(s)
one = ''
if \ scanLit(s, '$#') then do
oldPos = scanPos(s)
one = compileOne(m, m.m.defKind)
if one == '' | m.one.0 = 0 then
if oldPos == scanPos(s) then
leave
end
else if pos(scanLook(s, 1), m.comp_chKind'*') > 0 then do
call scanChar s, 1
m.m.defKind = m.s.tok
one = compileOne(m, m.m.defKind)
end
else if \ scanName(s) then do
call scanErr s, 'kind or hook expected after $#'
end
else if m.s.tok == 'out' then do
m.m.out = scanPos(s)
leave
end
else if m.s.tok == 'end' then do
if m.m.end = '' then
m.m.end = scanPos(s)
one = compileOne(m)
end
else if m.s.tok == 'version' then do
call scanSpace s
vers = 'v41 v42'
if \ scanWord(s) | wordPos(m.s.tok, vers) < 1 then
call scanErr s, 'only versions' vers 'are supported'
call scanNl s, 1
end
else do
say 'interpreting hook' m.s.tok':' strip(scanLook(s))
interpret 'one = wshHook_'m.s.tok'(m)'
end
if m.err.count <> eOld then
return ''
if one \== '' then
call mAdd res, one
end
return compUnnest(res)
endProcedure compileWsh
/*--- compile or use hook for one part from spec or input -----------*/
compileOne: procedure expose m.
parse arg m, ki, hook
s = m.m.scan
m.m.comp_assVars = 0
call compSpComment m
if ki == '*' | m.m.end \== '' then do
do until scanLook(s, 2) == '$#' | scanEnd(s)
call scanNl s, 1
end
return ''
end
return compUnit(m, ki, '$#')
endProcedure compileOne
/*--- parse the whole syntax of a unit ------------------------------*/
compUnit: procedure expose m.
parse arg m, ki, stopper
s = m.m.scan
if pos(ki, m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ki 'in compUnit(...'stopper')')
else if ki <> '#' then do
a = compAst(m, '[')
do forever
one = compPipe(m, ki)
if one \== '' then
call mAdd a, one
if \ scanLit(m.m.scan, '$;', '$<>') then
return compUnNest(a)
end
end
else do
res = compAST(m, '[')
call scanChar s
if verify(m.s.tok, m.comp_chSpa) > 0 then
call mAdd res, compAst(m, '=', strip(m.s.tok, 't'))
do while scanNL(s, 1) & \ abbrev(m.s.src, stopper)
call mAdd res, compAst(m, '=', strip(m.s.src, 't'))
end
return res
end
endProcedure compUnit
compUnnest: procedure expose m.
parse arg a
do while m.a.0 = 1 & pos(m.a.kind, '[-.;') > 0
n = m.a.1
if m.a.kind \== m.n.kind then
return a
call mFree a
a = n
end
return a
endProcedure compUnnest
/*--- compile an expression, type d=data, b=block w=word, s=strip ---*/
compExpr: procedure expose m.
parse arg m, type, ki, textEnd
s = m.m.scan
if symbol('m.comp_exType.type') \== 'VAR' then
call err s, 'bad type' type 'in compExpr'
if ki == '#' then do
if textEnd == '' then
call scanChar(s)
else if textEnd <= m.s.pos then
return ''
else
call scanChar s, textEnd - m.s.pos
if type == 's' then
res = compAst(m, '=', strip(m.s.tok))
else
res = compAst(m, '=', , m.s.tok)
res = compAST(m, '-', , res)
m.res.containsC = 1
m.res.containsD = 1
return res
end
else if ki == '%' | ki == '^' then do
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
return ''
if m.vr.var == 'c' then
res = compAst(m, 'M')
else
res = compAst(m, ki, , compASTAddOp(m, vr, '&'))
call compSpComment m
if textEnd == '' | textEnd < m.s.pos then do
ex = compOpBE(m, '=', 1, , textEnd)
if ex \== '' then do
call mAdd res, ex
call compSpComment m
end
end
m.res.containsC = 1
m.res.containsD = 1
return res
end
if length(ki) \== 1 | pos(ki, '.-=@') < 1 then
return scanErr(s, 'bad kind' ki 'in compExpr')
res = compAST(m, translate(ki, '-;', '=@'))
m.res.containsC = 0
txtKi = translate(ki, '++=+', '.-=@')
laPrim = 0
gotTxt = 0
if pos(type, 'sb') > 0 then
m.res.containsC = compSpComment(m) >= 2
do forever
if textEnd \== '' then
if m.s.pos >= textEnd then
leave
if scanVerify(s, m.comp_exType.type, 'm') then do
if textEnd \== '' then
if m.s.pos > textEnd then do
m.s.tok = left(m.s.tok, length(m.s.tok) ,
+ textEnd - m.s.pos)
m.s.pos = textEnd
end
one = compAST(m, txtKi, m.s.tok)
if verify(m.s.tok, m.comp_chSpa) > 0 then
gotTxt = 1
end
else do
old = scanPos(s)
if \ scanLit(s, m.comp_chDol) then
leave
if pos(scanLook(s, 1), '.-') > 0 then
one = compCheckNN(m, compOpBE(m, , 1, 0),
, 'primary block or expression expected')
else
one = compPrimary(m)
if one = '' then do
call scanBackPos s, old
leave
end
laPrim = m.res.0 + 1
end
call mAdd res, one
if compComment(m) then
m.res.containsC = 1
end
if pos(type, 'bs') > 0 then do
do rx=m.res.0 by -1 to laPrim+1
one = m.res.rx
m.one.text = strip(m.one.text, 't')
if length(m.one.text) <> 0 then
leave
call mFree one
end
m.res.0 = rx
end
m.res.containsD = laPrim > 0 | gotTxt
return compAstFree0(res, '')
endProcedure compExpr
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ops
s = m.m.scan
if scanString(s) then
return compASTAddOp(m, compAST(m, '=', m.s.val), ops)
r = compVar(m, left('c', right(ops, 1) == '^'))
if r == '' then
return ''
if m.r.var \== 'c' then
return compASTAddOp(m, compAst(m, '&', m.r.var, r), ops)
else
return compASTAddOp(m, compAst(m, 'M'),
, left(ops, length(ops)-1))
endProcedure compPrimary
/*--- oPBE ops (primary or block or expression)
oDef = default Kind, oPre = opPrefix,
uniq=1 extract unique, uniq='<' prefix <
withEx <> 0: expression allowed ------------------------------*/
compOpBE: procedure expose m.
parse arg m, oDef, uniq, withEx, textEnd
s = m.m.scan
old = scanPos(s)
op = compOpKind(m, oDef)
if uniq == '<' & left(op, 1) \== '<' then
op = left('<', uniq == '<') || op
if pos(scanLook(s, 1), '/[') > 0 then do
if uniq == 1 & length(op) == 1 then
if op == '.' then
op = '|.'
else if op == '=' then
op = '-='
else if pos(op, '-@<') > 0 then
op = op || op
return compBlock(m, op)
end
if compSpComment(m) == 0 ,
& pos(right(op, 1), m.comp_chKiNBOE) <= 0 then
return compPrimary(m, op)
if withEx \== 0 then do
res = compExpr(m, 's', right(op, 1), textEnd)
/* if pos(right(op, 1), m.comp_chKiNO) > 0 then
op = left(op, length(op)-1) ?????? */
if res \== '' then
return compASTAddOp(m, res, left(op, length(op)-1))
end
call scanBackPos s, old
return ''
endProcedure compOPBE
/*--- compile var of ^or % clause ------------------------------------*/
compCallVar: procedure expose m.
parse arg m, ki
call compSpComment m
vr = compVar(m, left('c', ki == '^'))
if vr == '' then
call scanErr m.m.scan, 'var expected after' ki
call compSpComment m
if m.vr.var == 'c' then
return compAst(m, 'M')
else
return compAst(m, ki, , compASTAddOp(m, vr, '&'))
endProcedure compCallVar
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAST(m, 'P', ' ', '', '')
do forever
one = compExprStmts(m, ki)
if one \== '' then do
if m.res.0 > 2 then
call scanErr s, '$| before statements needed'
call mAdd res, one
end
pre = left(m.comp_chDol, scanLit(s, m.comp_chDol))
if scanLook(s, 2) == '<>' then
leave
if scanLit(s, '<') then do
if m.res.2 == '' then
m.res.2 = compAst(m, '.')
else
call mAdd m.res.2, compAst(m, '+', ', ')
call mAdd m.res.2, compOpBE(m, '<', '<')
m.res.text = m.res.text'f'
end
else if scanLit(s, '>>', '>') then do
if m.res.1 <> '' then
call scanErr s, 'duplicate output'
m.res.text = if(m.s.tok == '>', 'F', 'A') ,
||substr(m.res.text, 2)
m.res.1 = compOpBE(m, '<', '<')
end
else if scanLit(s, '|') then do
if m.res.0 < 3 then
call scanErr s, 'stmts expected before |'
call compSpNlComment m
call mAdd res, compCheckNE(m, compExprStmts(m, ki),
, 'stmts or expressions after | expected')
end
else
leave
end
call scanBack s, pre
if m.res.0 > 3 | m.res.1 \== '' | m.res.2 \== '' then
return res
one = if(m.res.0 = 3, m.res.3)
call mFree res
return one
endProcedure compPipe
/*--- compile expressions and stmts ---------------------------------*/
compExprStmts: procedure expose m.
parse arg m, ki
kiTxt = translate(ki, ';-', '@=')
s = m.m.scan
res = compAst(m, '[')
withNew = ''
nlLe = 0 /* sophisticated logic using left and right NLs*/
tb = ''
do forever
if tb \== '' then do
fx=0
fy = m.tb.0
fL = m.tb.fy
aa = ''
do forever
call compSpComment m
px = m.s.pos
do until px < m.ff.end | fx >= m.tb.0
fx = fx + 1
ff = m.tb.fx
end
if fx > m.tb.0 then do
if compExpr(m, 's', m.fL.colKind) == '' then
leave
call err 'fallout table'
end
e1 = compExpr(m, 's', m.ff.colKind, m.ff.end)
if e1 == '' then
leave
else if fx > m.tb.0 then
call err 'fallout table'
if m.ff.colOps \== '' then
e1 = compAstAddOp(m, e1, m.ff.colOps)
if aa == '' then
aa = compAst(m, '[')
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
end
if aa \== '' then
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.tb.class"')")),
, aa, compAst(m, '*', '].'))
/* px = m.s.pos
e1 = compExpr(m, 'w', '=')
if e1 \== '' then do
aa = compAst(m, '[')
fx = 0
do until e1 == ''
do fx=fx+1 to m.tb.0 until px < m.ff.end
ff = m.tb.fx
end
if fx > m.tb.0 then
call scanErr s, 'right of all table fields'
if m.s.pos <= m.ff.pos then
call scanErr s, 'before table field' m.ff.name
call mAdd aa, compAst(m, 'A', ,
, compAst(m, '=', m.ff.name), e1)
call compSpComment m
px = m.s.pos
e1 = compExpr(m, 'w', '=')
end
call mAdd res, compAst(m, 'F', 'with',
, compAst(m, 'o', "oNew('"m.tb.class"')"),
, aa, compAst(m, '*', '$.'))
end
*/ nlRi = scanNL(s)
end
else if ki == ':' then do
call compSpNlComment m, '*'
nlRi = 0
end
else if ki == '@' then do
call compSpNlComment m
one = compExpr(m, 's', ki)
if one == '' then
nlRi = 0
else if m.one.0 < 1 then
call scanErr s, 'assert not empty' m.one.0
else do
do forever /* scan all continued rexx lines */
nlRi = 1
la = m.one.0
la = m.one.la
if m.la.kind \== '+' then
leave
m.la.text = strip(m.la.text, 't')
if right(m.la.text, 1) \== ',' then
leave
m.la.text = strip(left(m.la.text,
, length(m.la.text)-1), 't')' '
call compSpNlComment m
cont = compExpr(m, 's', '@')
if cont == '' | m.cont.kind \== m.one.kind then
call scanErr s, 'bad rexx continuation'
call mAddSt one, cont
call mFree cont
end
call mAdd res, one
end
end
else if ki == '%' | ki == '^' then do
do cc=0 while compSpNlComment(m)
end
one = compExpr(m, 's', ki)
nlRi = one \== ''
if nlRi then
call mAdd res, one
end
else do
do cc=0 while compComment(m)
end
one = compExpr(m, 'd', ki)
nlRi = scanNL(s)
if one == '' then do
if nlLe & nlRi & cc < 1 then
call mAdd res,compAst(m, kiTxt, ,compAst(m,'='))
end
else if m.one.containsD | (nlLe & nlRi,
& \ (cc > 0 | m.one.containsC)) then do
call mAdd res, one
end
else do
call mFree one
end
end
nlLe = nlRi
if \ nlRi then do
one = compStmt(m, ki)
if one \== '' then do
call mAdd res, one
end
else if scanLit(s, 'table', '$table') then do
tb = compTable(m, ki)
end
else do
if withNew \== '' then do
r = compAst(m, 'F', 'withNew', '', res,
, compAst(m, '*', '].'))
m.r.class = classNew('n* CompTable u' ,
substr(m.m.comp_assVars, 3))
m.r.1 = compAst(m, '.', ,
, compAst(m, '+', "oNew('"m.r.class"')"))
res = withNew
call mAdd res, r
m.m.comp_assVars = assVars
end
if scanLit(s, 'withNew', '$withNew') then do
withNew = res
assVars = m.m.comp_assVars
m.m.comp_assVars = ''
res = compAst(m, '[')
end
else
return compAstFree0(res)
end
end
end
endProcedure compExprStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compAss(m)
if res \== '' then
return res
pre = ''
old = scanPos(s)
if scanLit(s,m.comp_chDol'$',m.comp_chDol'@',m.comp_chDol,'@') then
pre = m.s.tok
if pre == m.comp_chDol'$' then
return compCheckNN(m, compOpBE(m,'=', 1),
, 'block or expression expected after $$')
if right(pre, 1) == '@' then do
one = compOpBE(m, '@')
if one \== '' then
return compAstAddOp(m, one, ')')
end
wCat = compName(m, 'sv')
fu = m.s.tok
if right(pre, 1) == '@' & wCat \== 's' then
call scanErr s, 'primary, block or expression expected'
if fu == 'arg' then do
res = compAst(m, 'R')
do forever
call compSpComment m
if scanLit(s, ',') then
a1 = compAst(m, '+', ',')
else do
gotV = 1
a1 = compVar(m, 'v')
end
if a1 \== '' then
call mAdd res, a1
else if gotV == 1 then
return res
else
call scanErr s, 'empty arg'
end
end
if fu == 'ct' then do
call compSpComment m
return compAst(m, 'C', , compCheckNN(m, compStmt(m, ki),
, 'ct statement'))
end
if fu == 'do' then do
call compSpComment m
pre = compExpr(m, 's', '@')
res = compAst(m, 'D', , pre)
p1 = m.pre.1
if pre \== '' then do
txt = ''
do px=1 to m.pre.0
pC = m.pre.px
if m.pC.kind \== '+' then
leave
txt = txt m.pC.text
cx = pos('=', txt)
if cx > 0 then do
m.res.text = strip(left(txt, cx-1))
leave
end
end
end
call compSpComment m
call mAdd res, compCheckNN(m, compStmt(m, ki), 'stmt after do')
return res
end
if wordPos(fu, 'for forWith with') > 0 then do
res = compAst(m, 'F', fu)
call compSpComment m
if fu \== 'with' then do
b = compVar(m)
end
else do
b = compAss(m)
if b == '' then
b = compCheckNE(m, compExpr(m, 's', '.'),
, "assignment or expression after with")
end
call compSpComment m
st = compCheckNN(m, compStmt(m, ki), "var? statement after" fu)
if b = '' then do
b = compBlockName(m, st)
if b \== '' then
b = compAst(m, '=', b)
else if \ abbrev(fu, 'for') then
call scanErr s, "variable or named block after" fu
end
call mAdd res, b, st
return res
end
if fu == 'proc' then do
call compSpComment m
nm = ''
if compName(m, 'v') == 'v' then do
nm = m.s.tok
call compSpComment m
end
st = compCheckNN(m, compStmt(m, ki), 'proc statement')
if nm == '' then do
nm = compBlockName(m, st)
if nm == '' then
call scanErr s, 'var or namedBlock expected after proc'
end
return compAst(m, 'B', '', compAst(m, '=', nm), st)
end
call scanBack s, pre || fu
return ''
endProcedure compStmt
compBlockName: procedure expose m.
parse arg m, a
a1 = m.a.1
if m.a.kind == '[' then
return m.a.text
else if m.a.kind == '*' & m.a1.kind == '[' then
return m.a1.text
return ''
endProcedure compBlockName
compVar: procedure expose m.
parse arg m, vk
if pos('o', vk) > 0 then call err(sdf)/0
s = m.m.scan
ty = compName(m, 'v' || vk)
if ty \== '' then do
r = compAst(m, '=', m.s.tok)
m.r.var = ty
return r
end
if \ scanLit(s, '{') then
return ''
call scanLit s, '?', '>'
f = m.s.tok
r = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after {'
m.r.var = f
return r
endProcedure compVar
compAss: procedure expose m.
parse arg m, vk
s = m.m.scan
old = scanPos(s)
call scanLit s, m.comp_chDol'=', '='
pr = m.s.tok
if pr \== '' then
call compSpComment m
v = compVar(m, vk)
if v \== '' then do
call compSpComment m
if \ scanLit(s, '=') then do
call scanBackPos s, old
return ''
end
end
else if pr == '' then
return ''
else
oldInfo = scanInfo(s)
eb = compCheckNE(m, compOpBE(m, '=', 1),
, 'block or expression in assignment after' pr)
if m.eb.kind == '[' then
eb = compAstAddOp(m, eb, '-')
if v == '' then do
v = compBlockName(m, eb)
if v == '' then
call scanEr3 s, 'var or namedBlock expected',
'in assignment after' pr, oldInfo
v = compAst(m, '=', v)
m.v.var = 'v'
end
if m.m.comp_assVars \== 0 then
if m.v.kind == '=' & m.v.var == 'v' then do
if words(m.v.text) \= 1 then
call compAstErr v, 'bad var'
if m.eb.kind == '*' then
ki = left(m.eb.text, 1)
else
ki = m.eb.kind
if pos(ki, '-=s') > 0 then
f = ', f' m.v.text 'v'
else if pos(ki, '.<@o') > 0 then
f = ', f' m.v.text 'r'
else
call compAstErr eb, 'string or object'
if pos(f, m.m.comp_assVars) < 1 then
m.m.comp_assVars = m.m.comp_assVars || f
end
return compAst(m, 'A', , v, eb)
endProcedure compAss
/*--- block deals with the correct kind and operators
the content is parsed by compUnit ------------------------------*/
compBlock: procedure expose m.
parse arg m, ops
s = m.m.scan
if \ scanLit(s, '[', '/') then
return ''
start = m.s.tok
if ops == '' | pos(right(ops, 1), m.comp_chKind) < 1 then
return scanErr(s, 'bad kind' ops 'for block')
ki = right(ops, 1)
ops = left(ops, length(ops)-1)
starter = start
if start == '[' then
stopper = m.comp_chDol']'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = m.comp_chDol || starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
res = compUnit(m, ki, stopper)
if \ scanLit(s, stopper, substr(stopper, 2)) then
call scanErr s, 'ending' stopper 'expected after' starter
if abbrev(starter, '/') then
m.res.text = substr(starter, 2, length(starter)-2)
return compAstAddOp(m, res, ops)
endProcedure compBlock
/*--- compile table body and return table ----------------------------*/
compTable: procedure expose m.
parse arg m, ki
s = m.m.scan
call compSpComment m
if scanNl(s) then
call compSpComment m
res = compAst(m, 'T', 'c')
flds = ''
pB = 1
do forever
opKi = compOpKind(m)
if compName(m, 'v') \== 'v' then
if opKi == '' then
leave
else
call scanErr s, 'table col expected after' opKi
f1 = compAst(m, 'T')
m.f1.pos = pB
if opKi == '' then
opKi = translate(ki, '=', ':')
m.f1.colKind = right(opKi, 1)
m.f1.colOps = left(opKi, length(opKi)-1)
m.f1.name = m.s.tok
if pos(left(opKi, 1), '-=#') > 0 then
flds = flds', f' m.s.tok 'v'
else
flds = flds', f' m.s.tok 'r'
call compSpComment m
pB = m.s.pos
m.f1.end = pB
m.f1.text = 'f blabla' m.f1.name m.f1.pos pB opKi
call mAdd res, f1
if scanLit(s, ',') then
call compSpComment m
end /* ?????????????????????????
do while compName(m, 'v') == 'v'
f1 = compAst(m, 'T')
m.f1.end = m.s.pos
m.f1.pos = m.s.pos - length(m.s.tok)
m.f1.name = m.s.tok
m.f1.text = 'f' m.f1.name m.f1.pos m.f1.end
call mAdd res, f1
flds = flds', f' m.s.tok 'v'
call compSpComment m
end ???????? */
if \ scanNl(s) then
call scanErr s, 'name or nl after table expected'
if m.res.0 < 1 then
call scanErr s, 'no names in table'
m.f1.end = ''
m.res.class = classNew('n* CompTable u' substr(flds, 3))
m.res.text = 'c' cl
return res
endProcedure compTable
/**** lexicals ********************************************************/
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
got = 0
do forever
if scanLit(s, m.comp_chDol'**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, m.comp_chDol'*+') then
call scanNL s, 1
else if scanLit(s, m.comp_chDol'*(') then do
do forever
if scanVerify(s, m.comp_chDol, 'm') then iterate
if scanNL(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, m.comp_chDol) then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, m.comp_chDol) then iterate
if scanString(s) then iterate
end
end
else
return got
got = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m, xtra
s = m.m.scan
got = 0
do forever
if scanVerify(s, m.comp_chSpa) then
got = bitOr(got, 1)
else if compComment(m) then
got = bitOr(got, 2)
else if xtra == '' then
return got
else if \ scanLit(s, xtra) then
return got
else do
got = bitOr(got, 4)
m.s.pos = 1+length(m.s.src)
end
end
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m, xtra
found = 0
do forever
if compSpComment(m, xtra) < 1 then
if \ scanNL(m.m.scan) then
return found
found = 1
end
endProcedure compSpNlComment
/*--- scan a name in one of the categories
v=var, c=compile, s=stmt ----------------------------------*/
compName: procedure expose m.
parse arg m, cats
s = m.m.scan
if \ scanName(s) then
return ''
if wordPos(m.s.tok, m.comp.wCatS) > 0 then do
if pos('s', cats) > 0 then
return 's'
end
else if wordPos(m.s.tok, m.comp.wCatC) > 0 then do
if pos('c', cats) > 0 then
return 'c'
end
else if pos('v', cats) > 0 then do
return 'v'
end
call scanBack s, m.s.tok
return ''
endProcedure compName
compOpKind: procedure expose m.
parse arg m, op
s = m.m.scan
if scanVerify(s, m.comp_chOp || m.comp_chKiNO) then
op = m.s.tok
else if op == '' then
return ''
/* ??????? temporary until old syntax vanished ????? */
x = verify(op, '%^', 'm')
if x > 0 & x < length(op) then
call scanErr s, 'old syntax? run not at end'
if right(op, 1) == '<' then
op = op'='
kx = verify(op, m.comp_chKiNO, 'm')
if kx \== 0 & kx \== length(op) then
call scanErr s, 'kind' substr(op, kx, 1) 'not after ops'
if pos(right(op, 1), m.comp_chKind) == 0 then
call scanErr s, 'no kind after ops' op
return op
endProcedure compOpKind
compSpNlComment: procedure expose m.
/**** small helper routines ******************************************/
/*--- if va == null then issue an error with msg --------------------*/
compCheckNN: procedure expose m.
parse arg m, va, msg
if va == '' then
call scanErr m.m.scan, msg 'expected'
return va
endProcedure compCheckNN
/*--- return true iff expression is empty ---------------------------*/
compIsEmpty: procedure expose m.
parse arg m, a, block0
do forever
if a == '' then
return 1
else if m.a.kind == '*' then
a = m.a.1
else if m.a.kind \== '[' then
return 0
else if block0 then
return 0
else if m.a.0 = 1 then
a = m.a.1
else
return m.a.0 < 1
end
endProcedure compIsEmpty
/*--- if va == null or empty then issue an error with msg -----------*/
compCheckNE: procedure expose m.
parse arg m, ex, msg
e1 = left(ex, 1)
if compIsEmpty(m, ex, 1) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/**** AST = Astract Syntax Tree ****************************************
------- atoms, no children
= string constant
+ rexx fragment
------- containers (any number of children)
- string expression
. object expression
; rexx statements
[ block
------- molecules
* operand chain ==> 1 operands in text, as in syntax plus
) run ($@ stmt), & variable access, ] execute
& variable access==> 1
A assignment ==> 2
B proc ==> 2
C ct ==> 1
D do ==> 2
F for + with ==> 2
P Pipe ==> * 1=input 2=output , 3..* piped stmtBlocks
R aRg * list of arguments/separators
T Table
M compile
% RunOut ==> 1,2 (Run, arguments)
^ RunRet ==> 1,2 (Run, arguments)
***********************************************************************/
/*--- create a new AST -----------------------------------------------*/
compAST: procedure expose m.
parse arg m, ki, txt
n = mNew('COMP.AST')
if length(ki) <> 1 then
return err('compAST bad kind' ki) / 0
m.n.kind = ki
m.n.text = txt
if pos(ki, '[;-.*&ABCDFPRTM%^') > 0 then do
do cx=1 to arg()-3
m.n.cx = arg(cx+3)
end
m.n.0 = cx-1
if ki == '*' then do
if verify(txt, m.comp_astOps) > 0 then
return err('compAst ki=* bad ops:' txt) / 0
end
else if txt \== '' & pos(ki, '&*FPT') < 1 then
return err('kind' ki 'text='txt'|')/0
end
else if pos(ki, '=+') > 0 then do
m.n.0 = 'kind'ki
end
else do
return err( "compAst kind '"ki"' not supported") / 0
end
return n
endProcedure compAST
/*--- free AST if empty ----------------------------------------------*/
compASTFree0: procedure expose m.
parse arg a, ret
if m.a.0 > 0 then
return a
call mFree a
return ret
endProcedure compAstFree0
/*--- add operandands to an AST -------------------------------------*/
compASTAddOp: procedure expose m.
parse arg m, a, ops
if verify(ops, m.comp_astOps) > 0 then
return err('addOp bad ops:' ops) / 0
k = if(m.a.kind=='*', left(m.a.text, 1), m.a.kind)
do while right(ops, 1) == k
ops = left(ops, length(ops)-1)
end
if ops == '' then
return a
if ki \== '*' then
return compAst(m, '*', ops, a)
m.a.text = ops || m.a.text
return a
endProcedure compAstAddOp
/*--- return the kind of an AST --------------------------------------*/
compASTKind: procedure expose m.
parse arg m, a
m.m.astOps = ''
if \ abbrev(a, 'COMP.AST.') then
return left(a, 1)
c = a
do while m.c.kind == 'ops'
if m.c.text \== '' then
return left(m.c.text, 1)
c = m.c.1
end
if a == c then
return '?'
return compAstKind(m, c)
endProcedure compASTKind
compAstSay: procedure expose m.
parse arg a, lv
if \ abbrev(a, 'COMP.AST.') then do
if a \== '' then
return err('bad ast' a)
say left('', 19)': * empty ast'
return
end
say lefPad(left('', lv) m.a.kind, 10) ,
|| rigPad(if(dataType(m.a.0, 'n'), m.a.0), 3),
'@'rigPad(substr(a, 10), 4)':' m.a.text'|'
if dataType(m.a.0, 'n') then do cx=1 to m.a.0
call compAstSay m.a.cx, lv+1
end
return
endProcedure compAstSay
compAstErr: procedure expose m.
parse arg a, txt
call errSay txt
call compAstSay a, 0
return err(txt)
endProcedure compAstErr
/*--- return the code for an AST with operand chain trg --------------*/
compCode2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ')]') > 0 then
return compCode2rx(m, oR, strip(f))
if pos(o1, '-.<|?@') > 0 then
return compRun2rx(m, ops, quote(oRunner(f)))
call err 'compCode2rx bad ops' ops 'code='f
endProcedure compCode2rx
compCon2rx: procedure expose m.
parse arg m, ops, f, a
do ox=length(ops) by -1 to 1 while pos(substr(ops,ox,1), '.-')>0
end
if substr(ops, ox+1, 1) == '.' then
f = s2o(f)
if length(f) < 20 then
v = quote(f, "'")
else if a \== '' & m.a.text == f then
v = 'm.'a'.text'
else
v = 'm.'compAst(m, '=', f)'.text'
if substr(ops, ox+1, 1) == '.' then
return compObj2rx(m, left(ops, ox), v)
else
return compString2rx(m, left(ops, ox), v)
endProcedure compCon2rx
compString2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, ']') then
return compCode2rx(m, oR, 'call out' f)
if o1 == '-' then
return compString2rx(m, oR, f)
if o1 == '.' then
return compObj2rx(m, oR, 's2o('f')')
if o1 == '&' then do
o2 = substr('1'ops, length(ops), 1)
if pos(o2, '.<^%@)') < 1 then
return compString2rx(m, oR, 'vGet('f')')
else
return compObj2rx(m, oR, 'vGet('f')')
end
if o1 == '<' then
return compFile2rx(m, oR, 'file('f')')
call err 'compString2rx bad ops' ops
endProcedure compString2rx
compObj2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '.' then
return compObj2rx(m, oR, f)
if o1 == '-' then
return compString2rx(m, oR, 'o2string('f')')
if o1 == ']' then
return compCode2rx(m, oR, 'call out' f)
if o1 == '<' then
return compFile2rx(m, oR, 'o2file('f')')
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%^') > 0 then
return compRun2rx(m, ops, f)
call err 'compObj2rx bad ops' ops 'for' f
endProcedure compObj2rx
compRun2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if o1 == '@' then
return compRun2Rx(m, oR, f)
if pos(o1, ')%') > 0 then
return compCode2Rx(m, oR, 'call oRun' f)
if o1 == '^' then
if pos(right(oR, 1), '.<^%') < 1 then
return compString2Rx(m, oR, 'oRun('f')')
else
return compObj2Rx(m, oR, 'oRun('f')')
return compObj2rx(m, ops, f)
endProcedure compRun2rx
compFile2rx: procedure expose m.
parse arg m, ops, f
if ops == '' then
return f
o1 = right(ops, 1)
oR = left(ops, length(ops)-1)
if pos(o1, '<.@') > 0 then
return compFile2rx(m, oR, f)
if o1 == '|' | o1 == '?' then
return compObj2Rx(m, oR, 'jSingle('f ||if(o1=='?', ", ''")')')
return compRun2rx(m, ops, f)
endProcedure compFile2rx
compAst2rx: procedure expose m.
parse arg m, ops, a
ki = m.a.kind
/* astStats ausgeschaltet
if pos(ki, m.comp_astStats) < 1 then do
m.comp_astStats = m.comp_astStats ki
m.comp_astStats.ki = 0
m.comp_astStatT.ki = 0
end
m.comp_astStats.ki = m.comp_astStats.ki + 1
if m.a.text \== '' then
m.comp_astStatT.ki = m.comp_astStatT.ki + 1
if ki == '*' then do
k2 = vGet(a'.1>>KIND')
if symbol('m.comp_astStat1.k2') \== 'VAR' then
m.comp_astStat1.k2 = 1
else
m.comp_astStat1.k2 = m.comp_astStat1.k2 + 1
end */
if ki == '+' & ops == '' then
return m.a.text
if ki == '=' then
return compCon2Rx(m, ops, m.a.text, a)
if ki == '*' then
return compAst2Rx(m, ops || m.a.text, m.a.1)
o1 = right(ops, 1)
oR = left(ops, max(0, length(ops)-1))
if ki == '-' then
return compString2rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == '.' then
return compObj2Rx(m, ops, compCatRexxAll(m, a,,, ' || '))
if ki == ';' then
return compCode2Rx(m, ops, compCatRexxAll(m, a,,,' || '))
if ki == '[' then do
a1 = m.a.1
if m.a.0 == 1 & m.a1.kind == '[' then
return compAst2Rx(m, ops, a1)
if o1 == '-' then do
res = compAst2CatStr(m, a)
if res \== '' then /* () necessary if part of expression */
return compString2rx(m, oR, '('strip(res)')')
end
if o1 == '.' then
return compAst2Rx(m, ops'|', a)
if pos(o1, '|?') > 0 then
if m.a.0 = 1 & compAstOut(a1) then
return compAst2Rx(m, oR, a1)
res = ''
do ax=1 to m.a.0
res = res';' compAst2rx(m, ']', m.a.ax)
end
if verify(res, '; ') = 0 then
res = 'nop'
else
res = 'do'res'; end'
if pos(o1, '-@])') > 0 then
return compCode2Rx(m, ops, res)
if pos(o1, '|?<') > 0 then
return compCode2Rx(m, ops'<@', res)
end
if ki == '&' then do
nm = compAst2Rx(m, '-', m.a.1)
if m.a.text=='' | m.a.text=='v' then
return compString2rx(m, ops'&', nm)
else if m.a.text == '?' then
return compString2rx(m, ops, 'vIsDefined('nm')')
else if m.a.text == '>' then
return compString2rx(m, ops, 'vIn('nm')')
else
call compAstErr a, 'bad text' m.a.text 'in ast &'
end
if ki == '%' | ki == '^' then do
c1 = compAst2Rx(m, '.', m.a.1)
if m.a.0 > 1 then
c1 = c1',' compAst2Rx(m, '', m.a.2)
return compRun2Rx(m, ops || ki, c1)
end
if ki == 'A' then do /* assignment */
nm = compAst2Rx(m, '-', m.a.1)
vl = m.a.2
if m.vl.kind == '=' | m.vl.kind == '-' ,
| (m.vl.kind == '*' & right(m.vl.text, 1) == '-') then
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '-', vl))
else
return compCode2Rx(m, ops,
, 'call vPut' nm',' compAst2Rx(m, '.', vl))
end
if ki == 'B' then do /* proc */
call vPut utInter('return' compAst2Rx(m, '-', m.a.1)),
, oRunner(compAst2Rx(m ,']', m.a.2))
return ''
end
if ki == 'C' then do /* ct */
call utInter compAst2Rx(m, ']', m.a.1)
return ''
end
if ki == 'D' then do /* do */
res = 'do' compAst2rx(m, '', m.a.1)
if m.a.text \== '' then
res = res"; call vPut '"m.a.text"'," m.a.text
return compCode2Rx(m, ops, res';' compAst2Rx(m, ']', m.a.2),
|| "; end")
end
if ki == 'F' then do /* for... */
a1 = m.a.1
st = compAst2Rx(m, ']', m.a.2)
if abbrev(m.a.text, 'for') then do
if m.a.1 == '' then
v = "''"
else
v = compAst2Rx(m, '-', m.a.1)
if m.a.text == 'for' then
s1 = 'do while vIn('v')'
else if m.a.text \== 'forWith' then
call compAstErr a, 'bad for...'
else
s1 = 'call vWith "+"; do while vForWith('v')'
return compCode2Rx(m, ops, s1';' st'; end')
end
else if \ abbrev(m.a.text, 'with') then
call compAstErr a, 'bad with...'
if m.a1.kind \== 'A' then do
v = compAst2Rx(m, '.', a1)
end
else do
v = compAst2Rx(m, ,a1)
if \ abbrev(v, 'call vPut ') | pos(';', v) > 0 then
call scanErr s, 'bad vPut' v
v = 'vPut('substr(v, 11)')'
end
ret1 = 'call vWith "+",' v';' st
if m.a.0 <= 2 then
return ret1"; call vWith '-'"
a3 = m.a.3
if m.a3.kind \== '*' then
call compAstErr a, 'for/with a.3 not *'
return ret1';' compObj2Rx(m, m.a3.text, "vWith('-')")
end
if ki == 'P' then do /* pipe */
if ((left(m.a.text, 1) == ' ') \== (m.a.1 == '')) ,
| ((substr(m.a.text, 2) == '') \== (m.a.2 == '')) ,
| (m.a.0 <= 3 & m.a.text == '') then
call compAstErr a, 'bad/trivial astPipe'
res = ''
do ax=3 to m.a.0
a1 = ''
if ax < m.a.0 then /* handle output */
t1 = 'N'
else if m.a.1 == '' then
t1 = 'P'
else do
t1 = left(m.a.text, 1)
a1 = compAst2Rx(m, '.', m.a.1)
end
if ax == 3 then do /* handle input */
t1 = '+'t1 || substr(m.a.text, 2)
if m.a.2 \== '' then
a1 = a1',' compAst2Rx(m, '.', m.a.2)
end
else
t1 = t1'|'
res = res"; call pipe '"t1"'," a1 ,
";" compAst2Rx(m, ']', m.a.ax)
end
return compCode2Rx(m, ops, substr(res, 3)"; call pipe '-'")
end
if ki == 'R' then do /* aRg statement */
prs = 'parse arg ,'
pts = ''
do ax=1 to m.a.0
a1 = m.a.ax
if m.a1.kind = '+' & m.a1.text == ',' then
prs = prs','
else do
prs = prs 'ggAA'ax
pts = pts'; call vPut' compAst2Rx(m, '-', a1)', ggAA'ax
end
end
return compCode2rx(m, ops, prs pts)
end
if ki == 'M' then do
if m.a.0 = 0 then
args = ''
else
args = ',' compAst2Rx(m, , m.a.1)
return compRun2rx(m, ops, 'compile(comp(in2Buf())' args')')
end
call compAstErr a, 'compAst2rx bad ops='ops 'kind='ki 'ast='a
endProcedure compAst2rx
compAstOut: procedure expose m.
parse arg a
if m.a.kind \== '*' then
return pos(m.a.kind, m.comp_astOut) > 0
return pos(left(m.a.text, 1), m.comp_astOut) > 0
endProcedure compAstOut
compAst2CatStr: procedure expose m.
parse arg m, a
res = ''
if compAstOut(a) then
res = compCatRexx(res, compAst2rx(m, , a), ' ')
else if m.a.kind \== '[' then
return ''
else do ax=1 to m.a.0
b = compAst2CatStr(m, m.a.ax)
if b == '' then
return ''
res = compCatRexx(res, b, ' ')
end
return res
endProcedure compAst2CatStr
compCatRexxAll: procedure expose m.
parse arg m, a, ops, mi, sep
res = ''
do ax=1 to m.a.0
a1 = m.a.ax
res = compCatRexx(res, compAst2rx(m, ops, m.a.ax), mi , sep)
end
return strip(res)
endProcedure compCatRexxAll
/*--- cat two rexx parts, avoid strange effects--------------------*/
compCatRexx: procedure expose m.
parse arg le, ri, mi, sep
if mi \== '' then
return le || mi || ri
lr = right(le, 1)
rl = left(ri, 1)
if (lr == "'" | lr == '"') then do
if rl == lr then /* "a","b" -> "ab" */
return left(le, length(le)-1) || substr(ri, 2)
else if rl == '(' then /* "a",( -> "a" || ( */
return le||sep||ri /* avoid function call */
end
else if pos(lr, m.comp.idChars) > 0 then
if pos(rl, m.comp.idChars'(') > 0 then
return le || sep || ri /* a,b -> a || b */
return le || ri
endProcedure compCatRexx
/* copy comp 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, onlyIfMatch
if arg() > 3 then
call err 'deimplement onlyIfMatch???'
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
if onlyIfMatch == 1 then
nx = m.m.pos
else
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 = ' ''"'
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.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 (optional 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',
, '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.m = oClaCopy('"ts"', m, ''); return 1"
call classNew "n EditRead u JRW", "m" ,
, "jRead return editRead(m)",
, "jOpen" ,
, "jReset m.m.linex = arg - 1"
call classNew 'n ScanSqlStmtRdr u JRW', 'm',
, "jReset call scanSqlStmtRdrReset m, arg, arg2, arg3",
, "jOpen call scanOpen m'.SCAN'" ,
, "jClose call scanClose m'.SCAN'" ,
, "jRead r = scanSqlStmt(m'.SCAN');if r==''then return 0" ,
"; m.m = r; return 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 scanOpen
/*--- 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')
/*--- 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')
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 scanReadReset(scanOpt(oNew('ScanRead'), n1, np, co), rdr)
scanReadReset: procedure expose m.
parse arg m, m.m.rdr
return oMutatName(m, '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
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
m.m.src = m.r
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.scanComment \= '' then
untC = untC || left(m.m.scanComment, 1)
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
m.m.tok = res
c9 = scanLook(m, 9)
do sx=1 to words(untWrds)
if abbrev(c9, word(untWrds, sx)) then
return 1
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
m.m.lineX = m.m.lineX + 1
if adrEdit('(ll) = line' m.m.lineX, 12) \= 0 then
return 0
m.m = ll
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',
, "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 scanWinReset(scanSqlOpt(oNew('ScanWin')), rdr, wOpts)
/*--- set the reader and window attributes of scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, m.m.rdr, winOpt
return scanWinOpt(oMutatName(m, 'ScanWin'), winOpt)
/*--- set the window scanner attributes -----------------------------*/
scanWinOpt: procedure expose m.
parse arg m, cuLe wiFo 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 */
m.m.posMin = word(wiba 3, 1) * cuLe /* room to go back */
m.m.posLim = m.m.posMin + 3 * cuLe
m.m.winTot = m.m.posLim + cuLe * (1 + word(wiFo 5, 1))
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
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 \== '')
do lx=1
if lx > 100 then
say '????iterating' scanLook(m)
if m.m.stop == '' then
scTx = scanTextCom(m, '''"' ,fuCo)
else
scTx = scanTextCom(m, '''"'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
tx = scanLook(m)
ok = word(tx, 2) == 'TERMINATOR' ,
& length(word(tx, 3)) == 1
if ok then
ok = scanCom(m)
if ok then do
m.m.stop = word(tx, 3)
if \ (right(res, 1) == ' ' ,
| scanLook(m, 1) == ' ') then
res = res' '
end
else if scanChar(m, 1) then
res = res || m.m.tok
else
call scanErr m, 'no char, now what?'
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
interpret objMet(m, 'scanSqlIn2Scan')
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 oMutatName(m, 'ScanSqlStmtRdr')
endProcedure scanSqlStmtRdrReset
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilOpt: procedure expose m.
parse arg m
call scanSqlOpt m
m.m.scanNestCom = 0
m.m.utilBrackets = 0
m.scanUtil = 'BACKUP CATENFM CATMAINT CHECK' ,
'COPY COPYTOCOPY DIAGNOSE EXEC LISTDEF LOAD' ,
'MERGECOPY MODIFY OPTIONS QUIESCE REBUILD' ,
'RECOVER REORG REPAIR REPORT RESTORE' ,
'RUNSTATS STOSPACE TEMPLATE UNLOAD'
return m
endProcedure scanUtilOpt
/*--- scan next token and put its class in m.sc.utilClass:
'u' a utility name
'n' a name
'"' a quoted name
"'" an apostroph'd string
'.' a .
',' a ,
'v' a value
'' at end
---------------------------------------------------------------*/
scanUtil: procedure expose m.
parse arg sc
m.sc.utilSpace = scanSpace(sc)
ty = '?'
if scanLit(sc, '(') then do
m.sc.utilBrackets = m.sc.utilBrackets + 1
end
else if scanLIT(sc, ')') then do
m.sc.utilBrackets = m.sc.utilBrackets - 1
if m.sc.utilBrackets < 0 then
call scanErr sc, 'unmatched closing bracket )'
end
else if scanLit(sc, ',') then do
end
else if scanLit(sc, '.') then do
end
else if scanString(sc, "'") then do
end
else if scanString(sc, '"') then do
end
else if scanName(sc) then do
m.sc.val = translate(m.sc.tok)
if m.sc.utilBrackets > 0 then
ty = 'n'
else if 0 < wordPos(m.sc.val, m.scanUtil) then
ty = 'u'
else
ty = 'n'
end
else if scanVerify(sc, ' (),''"', 'm') then do
ty = 'v'
m.sc.val = translate(m.sc.tok)
end
else if \scanEnd(sc) then do
call scanErr sc, 'scanUtil stopped before end'
end
else do
ty = ''
m.sc.val = ''
end
if ty == '?' then
m.sc.utilClass = left(m.sc.tok, 1)
else
m.sc.utilClass = ty
return m.sc.utilClass
endProcedure scanUtil
/*--- scan a value or a bracketed list of values ---------------------*/
scanUtilValue: procedure expose m.
parse arg sc, remApo, nl
if remApo = '' | rempApo = 0 then
remApo = "nv"
else if rempApo = 1 then
remApo = "nv'"
if '(' \== scanUtil(sc) then
return scanUtilValueOne(sc, remApo)
v = ''
brx = m.sc.utilBrackets
oLine = word(scanPos(sc), 1)
do forever
call scanUtil sc
one = scanUtilValueOne(sc, remApo)
if one == '' then
call scanErr sc, 'eof in brackets'
else if brx > m.sc.utilBrackets then
return v
nLine = word(scanPos(sc), 1)
if \ m.sc.utilSpace then
v = v || one
else if nl \== '' & oLine <> nLine then
v = v || nl || one
else
v = v' 'one
oLine = nLine
end
endProcedure scanUtilValue
scanUtilValueOne: procedure expose m.
parse arg sc, valTy
if m.sc.utilClass == '' then
return ''
else if m.sc.utilClass == 'u' then
call scanErr sc, 'util in scanUtilValueOne'
if pos(m.sc.utilClass, valTy) > 0 then
return m.sc.val
else
return m.sc.tok
endProcedure scanUtilValueOne
/*--- skip over nested brackets --------------------------------------*/
scanUtilSkipBrackets: procedure expose m.
parse arg m, br, doCat
if br \== '' then
lim = m.m.utilBrackets - br
else if scanLit(m, '(') then do
lim = m.m.utilBrackets
m.m.utilBrackets = lim + 1
end
else
return 0
doCat = doCat == 1
res = ''
do while scanUtil(m) \== ''
if m.m.utilBrackets <= lim then do
if doCat then
m.m.val = res
return 1
end
if doCat then
res = res m.m.tok
end
return scanErr(m, 'eof with' m.m.utilBrackets 'open (')
endProcedure skipBrackets
/*--- analyze a punch file write intoField to stdOut -----------------*/
scanUtilInto: procedure expose m.
parse arg m
if m.m.utilBrackets \== 0 then
call scanErr m, 'scanUtilInto with brackets' m.m.utilBrackets
/*sc = scanUtilReader(m.j.in)
call jOpen sc, 'r'
*/ do forever
cl = scanUtil(m)
if cl == '' then
return 0
if cl = 'n' & m.m.tok == 'INTO' then
leave
end
if scanUtil(m) \== 'n' | m.m.tok \== 'TABLE' then
call scanErr m, 'bad into table '
if \ scanSqlQuId(scanSkip(m)) then
call scanErr m, 'table name expected'
if m.m.utilBrackets \== 0 then
call scanErr m, 'into table in brackets' m.m.utilBrackets
m.m.tb = m.m.val
m.m.part = ''
m.m.when = ''
do forever
cl = scanUtil(m)
if cl == '' then
call scanErr m, 'eof after into'
if cl == 'n' & m.m.tok == 'PART' then do
if scanUtil(m) == 'v' then
m.m.part = m.m.val
else
call scanErr m, 'bad part'
end
else if cl == 'n' & wordPos(m.m.val, 'WHEN WORKDDN') > 0 then do
call scanUtilSkipBrackets m
end
else if cl == '(' then do
leave
end
end
oX = m.m.lineX
oL = overlay('', m.m.src, 1, m.m.pos-2)
do while m.m.utilBrackets > 0
call scanUtil m
if oX \== m.m.lineX then do
call out strip(oL, 't')
oX = m.m.lineX
oL = m.m.src
end
end
call out left(oL, m.m.pos)
/* call jClose sc
*/ return 1
endProcedure scanUtilInto
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call mapReset v
m.v_with.0 = 0
m.v_withMap = ''
m.v_with.0.map = ''
m.pipe.0 = 1
m.pipe.1.in = m.j.in
m.pipe.1.out = m.j.out
call pipe '+'
return
endProcedure pipeIni
/*-------------------------------
+- push pop frame
PYNFA ouput: Parent saY Newcat File, Appendtofile
psf| input: parent string file oldOut
old --> new
pipeBegin --> pipe '+N'
pipeBeLa f --> pipe '+F'
pipeLast --> pipe 'P|'
pipeLast f --> pipe 'F|', f
pipeEnd --> pipe '-'
--------------------------------*/
pipe: procedure expose m.
parse arg opts, aO
ox = 1; oc = substr(opts, ox, 1)
ax = m.pipe.0
px = ax -1
if oc == '-' then do
if px < 2 then
call err 'pipe pop empty'
call jClose m.pipe.ax.out
call jClose m.pipe.ax.in
ax = px
m.pipe.0 = ax
px = ax-1
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc == '+' then do
px = ax
ax = ax+ 1
m.pipe.0 = ax
m.pipe.ax.in = jOpen(m.pipe.px.in, '<')
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
ox = ox+1; oc = substr(opts, ox, 1)
end
oOut = m.pipe.ax.out
if pos(oc, 'NYPFA') > 0 then do
call jClose oOut
if oc == 'Y' then
m.pipe.ax.out = jOpen(m.pipe.1.out, '>')
else if oc == 'P' then
m.pipe.ax.out = jOpen(m.pipe.px.out, '>')
else if oc == 'N' then
m.pipe.ax.out = jOpen(Cat(), '>')
else if oc == 'F' then
m.pipe.ax.out = jOpen(o2file(aO), '>')
else if oc == 'A' then
m.pipe.ax.out = jOpen(o2file(aO), '>>')
ox = ox+1; oc = substr(opts, ox, 1)
end
if oc \== ' ' then do
call jClose m.pipe.ax.in
if substr(opts, ox+1) = '' & oc \== 's' then
ct = ''
else
ct = jOpen(Cat(), '>')
lx = 3
do forever
if oc == 's' then do
call jWrite ct, arg(lx)
lx = lx + 1
end
else do
if oc == 'p' then
i1 = m.pipe.px.in
else if oc == '|' then
i1 = oOut
else if oc == 'f' then do
i1 = arg(lx)
lx = lx + 1
end
else
call err 'implement' oc 'in pipe' opts
if ct \== '' then
call jWriteAll ct, o2File(i1)
end
ox = ox + 1
if substr(opts, ox, 1) == ' ' then
leave
else if ct == '' then
call err 'pipe loop but ct empty'
else
oc = substr(opts, ox, 1)
end
if ct == '' then
m.pipe.ax.in = jOpen(o2file(i1), '<')
else
m.pipe.ax.in = jOpen(jClose(ct), '<')
if lx > 3 & lx <> arg() + 1 then
call err 'pipe opts' opts 'but' arg() 'args not' (lx-1)
end
m.j.in = m.pipe.ax.in
m.j.out = m.pipe.ax.out
return
endProcedure pipe
/*--- write all from rdr (rsp in) to out, not lazy ----------------*/
pipeWriteNow: procedure expose m.
parse arg rdr
call jWriteNow m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteNow
/*--- write all from rdr (rsp in) to out, possibly lazy -----------*/
pipeWriteAll: procedure expose m.
parse arg rdr
call jWriteAll m.j.out, if(rdr == '', m.j.in, rdr)
return
endProcedure pipeWriteAll
pipePreSuf: procedure expose m.
parse arg le, ri
do while in()
call out le || m.in || ri
end
return
endProcedure pipePreSuf
vIsDefined: procedure expose m.
parse arg na
return '' \== vAdr(na, 'g')
endProcedure vIsDefined
vWith: procedure expose m.
parse arg fun, o
if fun == '-' then do
tBe = m.v_with.0
tos = tBe - 1
if tos < 0 then
call err 'pop empty withStack'
m.v_with.0 = tos
m.v_withMap = m.v_with.tos.map
return m.v_with.tBe.obj
end
else if fun \== '+' then
call err 'bad fun vWith('fun',' o')'
par = m.v_with.0
tos = par + 1
m.v_with.0 = tos
if symbol('m.v_with.tos.obj') == 'VAR' then
if objClass(o) == objClass(m.v_with.tos.obj) then do
m.v_with.tos.obj = o
m.v_withMap = m.v_with.tos.map
return
end
m.v_with.tos.obj = o
if par > 0 then
key = m.v_with.par.classes
else
key = ''
if o \== '' then
key = strip(key objClass(o))
m.v_with.tos.classes = key
if symbol('m.v_withManager.key') == 'VAR' then do
m.v_with.tos.map = m.v_withManager.key
m.v_withMap = m.v_withManager.key
return
end
m = mapNew()
m.v_with.tos.map = m
m.v_withMap = m
m.v_withManager.key = m
do kx=1 to words(key)
c1 = word(key, kx)
call vWithAdd m, kx, classMet(c1, 'oFlds')
call vWithAdd m, kx, classMet(c1, 'stms')
end
return
endProcedure vWith
vWithAdd: procedure expose m.
parse arg m, kx, ff
do fx=1 to m.ff.0
n1 = m.ff.fx
dx = pos('.', n1)
if dx > 1 then
n1 = left(n1, dx-1)
else if dx = 1 | n1 = '' then
iterate
call mPut m'.'n1, kx
end
return
endProcedure vWithAdd
vForWith: procedure expose m.
parse arg var
call vWith '-'
if \ vIn(var) then
return 0
call vWith '+', m.in
return 1
endProcedure vForWith
vGet: procedure expose m.
parse arg na
a = vAdr(na, 'g')
if a = '' then
call err 'undefined var' na
return m.a
endProcedure vGet
vPut: procedure expose m.
parse arg na, val
a = vAdr(na, 'p')
m.a = val
return val
endProcedure vPut
/*--- find the final address
return f || a with address a and
f = m -> mapGet(a), o -> obect m.a, s -> string m.a ---*/
vAdrXXX: procedure expose m.
parse arg na, f
cx = 1
do forever
cy = verify(na, '&>', 'm', cx)
if cy = 0 then do
if cy <= length(na) then
a = a'.'substr(na, cx)
leave
end
a = a'.'substr(na, cx, cy-cx-1)
if substr(na, cy, 1) == '>' then do
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdr: procedure expose m.
parse arg na, f
cx = 0
cx = verify(na, '&>', 'm')
if cx > 0 then
a = left(na, cx-1)
else do
a = na
cx = length(na)+1
end
nxt = 0
do forever
cy = verify(na, '&>', 'm', cx+1)
if cy > 0 then
fld = substr(na, cx+1, cy-cx-1)
else
fld = substr(na, cx+1)
if substr(na, cx, 1) == '>' then do
if nxt then
a = vAdrByM(a)
if fld \== '' then
a = a'.'fld
end
else do
if nxt then
a = vAdrByM(a)
mp = m.v_withMap
aL = a
if pos('.', a) > 0 then
aL = left(a, pos('.', a)-1)
if mp \== '' & symbol('m.mp.aL') == 'VAR' then do
wx = m.mp.aL
a = m.v_with.wx.obj'.'a
end
else if cx >= length(na) then
return mapAdr(v, a, f)
else
a = mapAdr(v, a, 'g')
if fld \== '' then
a = vAdrByM(a)'.'fld
end
if cy < 1 then do
if f == 'g' then
if symbol('m.a') \== 'VAR' then
return ''
return a
end
cx = cy
nxt = 1
end
endProcedure vAdr
vAdrByM:
parse arg axx
if axx = '' then
return err('null address at' substr(na, cx) 'in' na)
if symbol('m.axx') \== 'VAR' then
return err('undef address' axx 'at' substr(na, cx) 'in' na)
ayy = m.axx
if ayy == '' then
return err('null address at' substr(na, cx) 'in' na)
return ayy
endProcedure vAdrByM
vIn: procedure expose m.
parse arg na
if \ in() then
return 0
if na \== '' then
call vPut na, m.in
return 1
endProcedure vIn
vRead: procedure expose m. /* old name ????????????? */
parse arg na
return vIn(na)
vHasKey: procedure expose m.
parse arg na
return mapHasKey(v, na)
vRemove: procedure expose m.
parse arg na
return mapRemove(v, na)
/* copy pipe end ******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat') /* calls catReset */
do ax=1 to arg()
call catWriteAll m, arg(ax)
end
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
m.m.RWs.0 = 0
m.m.catWr = ''
m.m.catRd = ''
m.m.catIx = -9e9
m.m.catKeepOpen = ''
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call jClose m.m.catWr
call mAdd m'.RWS', m.m.catWr
m.m.catWr = ''
end
if m.m.catRd \== '' then do
call jClose m.m.catRd
m.m.catRd = ''
end
m.m.catIx = -9e9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
if oo == m.j.cRead then do
m.m.catIx = 0
call catNextRdr m
m.m.jReading = 1
end
else if oo == m.j.cWri | oo == m.j.cApp then do
if oo == m.j.cWri then
m.m.RWs.0 = 0
m.m.catIx = -9e9
m.m.jWriting = 1
end
else do
call err 'catOpen('m',' oo') bad opt'
end
return m
endProcedure catOpen
/*--- return and open next reader ------------------------------------*/
catNextRdr: procedure expose m.
parse arg m
if m.m.catRd \== '' then
call jClose m.m.catRd
cx = m.m.catIx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then do
m.m.catRd = ''
return 0
end
m.m.catRd = m.m.RWs.cx
if cx = word(m.m.catKeepOpen, 1) then
m.m.catKeepOpen = subWord(m.catKeepOpen, 2)
else
call jOpen m.m.catRd , m.j.cRead
return 1
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m
do while m.m.catRd \== ''
cr = m.m.catRd
if jRead(cr) then do
m.m = m.cr
return 1
end
call catNextRdr m
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWrite m.m.catWr, line
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catWr \== '' then do
call mAdd m'.RWS', jClose(m.m.catWr)
m.m.catWr = ''
end
do ax=2 by 1 to arg()
r = o2File(arg(ax))
call mAdd m'.RWS', r
if m.r.jReading then do
m.m.catKeepOpen = m.m.rws.0 m.m.catKeepOpen
call jOpen r, m.j.cRead
end
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
return oNew('File', str)
endProcedure file
fileChild: procedure expose m.
parse arg m, name, opt
interpret objMet(m, 'fileChild')
endProcedure fileChild
fileRm: procedure expose m.
parse arg m
interpret objMet(m, 'fileRm')
return
endProcedure fileRm
filePath: procedure expose m.
parse arg m
interpret objMet(m, 'filePath')
endProcedure filePath
fileIsFile: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsFile')
endProcedure fileIsFile
fileIsDir: procedure expose m.
parse arg m
interpret objMet(m, 'fileIsDir')
endProcedure fileIsDir
fileMkDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileMkDir')
return
endProcedure fileRm
fileRmDir: procedure expose m.
parse arg m, opt
interpret objMet(m, 'fileRmDir')
return
endProcedure fileRm
/*--- create a reader/WriteO for the filelist of a directory----------*/
fileList: procedure expose m.
parse arg m, opt
str = oIfStr(m, '')
if str == '' then
return oNew('FileList', filePath(m), opt)
else
return oNew('FileList', dsn2Jcl(str), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call errIni
call jIni
call classNew "n Cat u JRW", "m",
, "jOpen call catOpen m, opt",
, "jReset call catReset m, arg",
, "jClose call catClose m",
, "jRead return catRead(m)",
, jWrite1Met("call catWrite m, m.var"),
, "jWriteAll call catWriteAll m, rdr; return"
if m.err.os == 'TSO' then
call fileTsoIni
else if m.err.os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' m.err.os
return
endProcedure catIni
/* copy cat end ****************************************************/
/* copy mail begin ***************************************************/
mailHead: procedure expose m.
parse arg m, subj, rec, snd
m.m.1 = 'sender='if(snd=='', userid(), snd)
m.m.2 = 'type=TEXT/HTML'
m.m.3 = 'to='rec
m.m.4 = 'subject='subj
m.m.5 = 'SEND=Y'
m.m.6 = 'TEXT=<HTML>'
m.m.7 = 'TEXT=<HEAD>'
m.m.8 = 'TEXT=</HEAD>'
m.m.9 = 'TEXT=<BODY>'
m.m.10 = 'TESTINFO=Y'
m.m.0 = 10
return m
endProce4 re mailHead
/*--- add one or several arguments to stem m.a -----------------------*/
mailText: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = 'text='arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mailText
mailSend: procedure expose m.
parse arg m, dsn
call mAdd m,'INFO=Y' ,
,'TEXT=</BODY>' ,
,'TEXT=</HTML>'
call dsnAlloc 'dd(mailIn)' if(dsn<> '', dsn, 'new') '::v4092'
call writeDD mailIn, 'M.'m'.'
call tsoClose mailIn
if m.mail_libAdd \== 0 then do
dsnOs3560 = 'PCL.U0000.P0.'iirz2dsn(sysVar(sysNode)) ,
|| 'AKT.PERM.@008.LLB'
call adrTSO "TLIB ADD DATASET('"dsnOs3560"') STEPLIB"
end
address LINKMVS 'OS3560'
if rc <> 0 then
call err 'call OS3560 failed Rc('rc')'
if m.mail_libAdd \== 0 then
call adrTSO "TLIB delete DATASET('"dsnOs3560"') STEPLIB"
call tsoFree mailIn
return 0
endProcedure mailSend
/* copy mail end *****************************************************/
/* copy fiLinux begin *************************************************/
/*--- send ggShCmd to shell bash,
fail if rc <> 0 or not listed in ggRet -----------------------*/
adrSh: procedure expose m. /* really no need for variables???? */
parse arg ggShCmd, ggRet
address 'bash' ggShCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrSh rc' rc 'for' ggShCmd
endProcedure adrSh
fileLinuxReset: procedure expose m.
parse arg m, nm
m.m.spec = nm
if abbrev(nm, '&') then do
if nm == '&in' then do
m.m.stream = .input
m.m.jReading = 1
end
else if nm == '&out' then do
m.m.stream = .output
m.m.jWriting = 1
end
else do
call err 'bad spec' nm
end
end
else do
m.m.stream = .Stream%%new(nm)
m.m.stream%%init(m.m.stream%%qualify)
end
return m
endProcedure fileLinuxReset
fileLinuxOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
res = m.m.stream%%open(read shareread)
m.m.jReading = 1
end
else do
if opt == m.j.cApp then
res = m.m.stream%%open(write append)
else if opt == m.j.cWri then
res = m.m.stream%%open(write replace)
else
call err 'fileLinuxOpen('m',' opt') with bad opt'
m.m.jWriting = 1
end
if res \== 'READY:' then
call err 'fileLinuxOpen fails' res':' opt ,
"'"m.m.stream%%qualify"'"
return m
endProcedure fileLinuxOpen
fileLinuxClose:
parse arg m
res = m.m.stream%%close
if res \== 'READY:' then
call err 'fileLinuxClose' res':' m.m.stream%%qualify
return m
endProcedure fileLinuxClose
fileLinuxRead: procedure expose m.
parse arg m, var
res = m.m.stream%%lineIn
if res == '' then
if m.m.stream%%state \== 'READY' then
return 0
m.var = res
m.o.o2c.var = m.class_V
return 1
endProcedure fileLinuxRead
fileLinuxWrite: procedure expose m.
parse arg m, line
if m.m.stream%%lineOut(line) then
call err 'fileLinuxWrite'
return
endProcedure fileLinuxWrite
fileLinuxRmDir: procedure expose m.
parse arg m, opt
if opt == '' then
return adrSh('rmdir' m.m.spec)
else if opt == '-r' then
return adrSh('rm -r' m.m.spec)
else
call err 'bad opt' opt 'in fileLinuxRmDir'
endProcedure fileLInuxRmDir
fileLinuxListReset: procedure expose m.
parse arg m, m.m.spec, o
if o == 'r' then
m.m.opt = 'S'
else if o == '' then
m.m.opt = ''
else
call err 'bad opt' o 'in fileLinuxListReset'
m.m.rx = 'closed'
return m
endProcedure fileLinuxListReset
fileLinuxListOpen: procedure expose m.
parse arg m
if m \== translate(m) then
call err 'bad m for fileLinuxList:' m
if m.m.opt == '' then
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST')
else
rc = sysFileTree(m.m.spec'/*', 'm.'m'.LIST', m.m.opt)
if rc \== 0 then
call err 'rc' rc 'in sysFileTree('m.m.spec', m.'m'.LIST)'
m.m.rx = 0
m.m.jReading = 1
return m
endProcedure fileLinuxListOpen
fileLinuxListRead: procedure expose m.
parse arg m, var
x = m.m.rx + 1
if x > m.m.list.0 then
return 0
m.var = substr(m.m.list.x, 43)
m.m.rx = x
call oMutate var, m.class_V
return 1
endProcedure fileLinuxListRead
fileLinuxIni: procedure expose m.
if m.fileLinux.ini == 1 then
return
m.fileLinux.ini = 1
m.file.sep = '/'
call jIni
call classNew "n File u JRW", "m",
, "jReset call fileLinuxReset m, arg",
, "jOpen call fileLinuxOpen m, opt",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)"
call classNew "n FileList u JRW", "m",
, "jReset call fileLinuxListReset m, arg, arg2",
, "jOpen call fileLinuxListOpen m, opt",
, "jClose m.m.rx = 'closed'",
, "jRead return fileLinuxListRead(m, var)"
return
endProcedure fileLinuxIni
/* copy fiLinux end *************************************************/
/* copy fileTso begin *************************************************/
fileTsoReset: procedure expose m.
parse arg m, sp
m.m.readIx = 'c'
m.m.bufMax = 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
sc = dsnSpec(m.m.spec)
s1 = translate(word(sc, 1))
sr = translate(subword(sc, 4))
if s1 = 'INTRDR' | right(s1,7) = '/INTRDR' ,
| wordPos('WRITER(INTRDR)', sr) > 0 then
m.m.stripT = 80
else
m.m.stripT = copies('t',
, pos(':V', sr) < 1 | pos('RECFM(V', sr) > 0)
if opt == m.j.cRead then do
aa = dsnAlloc(sc, 'SHR', m.m.defDD)
aDD = word(aa, 1)
aDsn = m.tso_dsn.aDD
if aDsn <> '' then
if pos('(', aDsn) > 0 & pos('/', aDsn) < 1 then
if sysDsn("'"m.tso_dsn.aDD"'") <> 'OK' then
call err 'cannot read' m.tso_dsn.aDD':',
sysDsn("'"m.tso_dsn.aDD"'")
call tsoOpen word(aa, 1), 'R'
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(sc, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(sc, '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
m.m.dsn = mGet('TSO_DSN.'m.m.dd)
return m
endProcedure fileTsoOpen
fileTsoClose: procedure expose m.
parse arg m
if m.m.jWriting then
if m.m.buf.0 > 0 then
call fileTsoWrite m
call tsoClose m.m.dd
call tsoFree m.m.free
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoWrite: procedure expose m.
parse arg m
if m.m.stripT == 't' then do bx=1 to m.m.buf.0
m.m.buf.bx = strip(m.m.buf.bx, 't')
end
else if m.m.stripT \== '' then do bx=1 to m.m.buf.0
m.m.buf.bx = left(m.m.buf.bx, m.m.stripT)
end
call writeDD m.m.dd, 'M.'m'.BUF.', , m.m.tso_truncOk == 1
m.m.buf.0 = 0
return
endProcedure fileTsoWrite
fSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure fSub
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
f = oNew('FileEdit', spec)
m.f.editArgs = vw
return f
endProcedure fEdit
fileTsoEditOpen: procedure expose m.
parse arg m, opt
call fileTsoOpen m, opt
m.m.maxL = tsoDSIMaxl(m.m.dd)
return m
endProcedure fileTsoEditOpen
fileTsoEditClose: procedure expose m.
parse arg m
dsn = m.m.dsn
parse var m.m.editArgs eTy eAr
upper eTy
if abbrev('VIEW', eTy) 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.'m'.BUF.') then return 0",
, "jWrite call fileTsoWrite m, line",
, "filePath return word(dsnSpec(m.m.spec), 1)" ,
, "fileIsFile" um "'fileIsFile'" ,
, "fileIsDir return 1" ,
, "fileChild return file(word(m.m.spec, 1)'.'name opt)",
, "fileRm" um "'fileRm'" ,
, "fileMkDir" ,
, "fileRmDir" um "'fileRmDir'"
/* , "filePath return m.m.stream%%qualify",
, "fileIsFile return sysIsFile(m.m.stream%%qualify)" ,
, "fileIsDir return sysIsFileDirectory(m.m.stream%%qualify)" ,
, "fileChild return file(m.m.stream%%qualify'/'name)",
, "fileRm return adrSh(m.m.spec)",
, "fileMkDir return adrSh('mkdir' m.m.stream%%qualify)" ,
, "fileRmDir return fileLinuxRmDir(m, opt)" */
call classNew "n FileList u JRW", "m",
, "jReset if arg2 == 'r' then m.m.dsnMask=arg'.**';",
"else m.m.dsnMask=arg'.*';",
, "jOpen call csiOpen m, m.m.dsnMask",
, "jClose" ,
, "jRead return csiNext(m, m)"
call classNew "n FileEdit u File, f MAXL v", "m",
, "jOpen call fileTsoEditOpen m, opt",
, "jWrite call fileTsoWrite m, o2Text(line, m.m.maxL)",
, "jClose call fileTsoEditClose m"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy mat begin *****************************************************/
sqrt: procedure expose m.
parse arg n
if n < 2 then
return n
k = 1
g = n
do while k+1 < g
m = (g + k) % 2
if m * m <= n then
k = m
else
g = m
end
return k
endProcedure sqrt
isPrime: procedure expose m.
parse arg n
if n < 2 then
return 0
if n // 2 = 0 then
return n = 2
do q=3 by 2 to sqrt(n)
if n // q = 0 then
return 0
end
return 1
endProcedure isPrime
nxPrime: procedure expose m.
parse arg n
do i = n + (\ (n // 2)) by 2
if isPrime(i) then
return i
end
endProcedure nxPrime
permut: procedure expose m.
parse arg m, p
m.m.1 = 1
do i=2 while p > 0
j = i - (p // i)
m.m.i = m.m.j
m.m.j = i
p = p % i
end
m.m.0 = i-1
return i-1
endProcedure permut
/* copy mat end *****************************************************/
/* copy sqlDiv begin **************************************************/
/*--- generate the format m for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlFTabReset: procedure expose m.
parse arg ff, c, maxCh, maxBlo, maxDe
return sqlFTabOpts(fTabReset(ff, , , '-'), c, maxCh, maxBlo, maxDe)
sqlFTabOpts: procedure expose m.
parse arg ff, cx, m.ff.maxChar, m.ff.blobMax, m.ff.maxDec
if m.ff.maxChar == '' then
m.ff.maxChar = 32
if m.ff.blobMax == '' then
m.ff.blobMax = 200
bf = '%-'max(m.ff.blobMax, 4)'C'
m.ff.flds = ''
m.ff.sqlX = cx
m.ff.sqlOthers = 0
m.ff.sql2fmt.384 = '%-10C' /* date */
m.ff.sql2fmt.388 = '%-8C' /* time */
m.ff.sql2fmt.392 = '%-26C' /* timestamp */
m.ff.sql2fmt.400 = 'c' /* graphic string */
m.ff.sql2fmt.404 = bf /* BLOB */
m.ff.sql2fmt.408 = bf /* CLOB */
m.ff.sql2fmt.412 = bf /* DBCLOB */
m.ff.sql2fmt.448 = 'c' /* varchar */
m.ff.sql2fmt.452 = 'c' /* char */
m.ff.sql2fmt.452 = 'c' /* long varchar */
m.ff.sql2fmt.460 = 'c' /* null term. string */
m.ff.sql2fmt.464 = 'c' /* graphic varchar */
m.ff.sql2fmt.468 = 'c' /* graphic char */
m.ff.sql2fmt.472 = 'c' /* long graphic varchar */
m.ff.sql2fmt.480 = '%-7e' /* float */
m.ff.sql2fmt.484 = 'd' /* packed decimal */
m.ff.sql2fmt.492 = '%20i' /* bigInt */
m.ff.sql2fmt.496 = '%11i' /* int */
m.ff.sql2fmt.500 = '%6i' /* smallInt */
m.ff.sql2fmt.904 = '%-34H' /* rowID 17 Byte Binary */
return ff
endProcedure sqlFTabOpts
/*--- set a defaultFormat for type tx in fTab ff ---------------------*/
sqlFTabDef: procedure expose m.
parse arg ff, tx, m.ff.sql2fmt.tx
return ff
sqlFTabAdd: procedure expose m.
parse arg m, c1 aDone, f1, l1
if symbol('m.m.set.c1') == 'VAR' then do
sx = m.m.set.c1
if word(m.m.set.sx, 1) == c1 & sx <= m.m.set.0 then do
parse var m.m.set.sx c1 aDone
f1 = m.m.set.sx.fmt
l1 = m.m.set.sx.labelTi
end
end
cx = m.m.sqlX
f2x = classMet(sqlFetchClass(cx), 'f2x')
if symbol('m.f2x.c1') \== 'VAR' then
call err 'colName not found' c1
kx = m.f2x.c1
t1 = m.sql.cx.d.kx.sqlName
if l1 == '' then
l1 = t1
if f1 == '' then do
ty = m.sql.cx.d.kx.sqlType
le = m.sql.cx.d.kx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('m.m.sql2fmt.ty') <> 'VAR' then
call err 'sqlType' ty 'col' c1 'not supported'
f1 = m.m.sql2fmt.ty
if f1 == 'c' then
f1 = '%-'min(le, m.m.maxChar)'C'
else if f1 == 'd' then do
trace ?r
pr = le % 256
de = le // 256
f1 = '%'pr'.'de'i'
end
if \ abbrev(f1, '%') then
call err 'sqlType' ty 'col' c1 'bad format' f1
end
call fTabAddRCT m, c1 aDone, f1, t1, l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return m
endProcedure sqlFTabAdd
sqlFTabOthers: procedure expose m.
parse arg m, doNot
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
m.m.sqlOthers = 1
do kx=1 to m.sql.cx.d.sqlD
c1 = word(ff, kx)
wx = wordPos(c1, m.m.cols)
if (wx < 1 | m.m.wx.done \== 1) & wordPos(c1, doNot) < 1 then
call sqlFTabAdd m, c1
end
return m
endProcedure sqlFTabOthers
sqlFTab: procedure expose m.
parse arg m
call fTabBegin m
do while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out f(m.m.fmt, 'sqlFTab')
end
return fTabEnd(m)
endProcedure sqlFTab
sqlFTabCol: procedure expose m.
parse arg m
if pos('c', m.m.generated) < 1 then
call fTabColGen m
do rx=1 while sqlRxFetch(m.m.sqlX, 'sqlFTab')
call out left('--- row' rx '', 80, '-')
call fTabCol m, 'sqlFTab'
end
call out left('--- end of' (rx-1) 'rows ', 80, '-')
return
endProcedure sqlFTabCol
sqlCatTb: procedure expose m.
parse arg ty gOnly, wh, ord, fTab, paPlus
tb = tkrTable(, ty)
if gOnly == 1 then
edFun = ''
else
edFun = tkrTable(, ty, 'e')
cx = 1
ft = 'ft'm.tb.alias
call sqlFTabOpts FTabReset(ft, 'c 1', '1 c', '-'),
,cx , 12, if(fTab, , 2000)
call sqlFTabDef ft, 492, '%7e'
call FTabSet ft, 'CONTOKEN' , '%-16H'
call FTabSet ft, 'DCONTOKEN' , '%-16H'
call FTabSet ft, 'DBNAME' , '%-8C', 'db'
call FTabSet ft, 'DSNAME' , '%-44C'
call FTabSet ft, 'DSNUM' , '%5i'
call FTabSet ft, 'PARTITION' ,'%5i' , 'part'
call FTabSet ft, 'PIT_RBA' , '%-12H'
call FTabSet ft, 'RBA1' , '%-12H'
call FTabSet ft, 'RBA2' , '%-12H'
call FTabSet ft, 'START_RBA' ,'%-12H'
call FTabSet ft, 'TSNAME' , '%-8C', 'ts'
call FTabSet ft, 'VERSION' , '%-28C'
if edFun \== '' then do
interpret 'sq =' edFun'(ft, tb, wh, ord)'
end
else do
cl = sqlColList(m.tb.table, m.ft.blobMax)
sq = 'select' cl tkrTable( , tb, 'f') wh ,
'order by' if(ord=='', m.tb.order, ord)
call sqlQuery cx, sq
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
end
if fTab then
call sqlFTab ft
else
call sqlFTabCol ft
call sqlClose cx
call sqlCatTbTrailer space(m.TKR.path paPlus, 1), sq
return 0
endProcedure sqlCatTb
sqlCatTbVlsep:
return '+++'
sqlCatTbVl: procedure expose m.
parse arg ft, tb, sep
if sep == '' then
sep = sqlCatTbVLsep()
if m.tb.vlKey == '' then
return
ky = m.tb.vlKey
ff = ''
tt = ''
do kx=1 to m.ky.0
tt = tt || sep || m.ky.kx.col
ff = ff || sep'@'m.ky.kx.col'%S'
end
call fTabAddRCT ft, substr(tt,length(sep)+1) ,
, substr(ff,length(sep)+1)
return
endProcedure sqlCatTbVl
sqlCatTbTrailer: procedure expose m.
parse arg pa, sq
ox = lastPos(' order by ', sq)
if ox < 1 then
call err 'order by not found in' sq
ord = substr(sq, ox+10)
sq = left(sq, ox-1)
sqUp = translate(sq)
call out ''
call out 'dbSys:' m.sql_dbSys
call out 'path:' pa
int = ''
iNx = ' '
br = ''
cx = 1
stops = '(select from where'
do while cx < length(sq)
nx = -1
do sx=1 to words(stops)
n2 = pos(word(stops, sx), sq, cx+1)
if n2 > cx & (nx < 1 | n2 < nx) then
nx = n2
end
if nx < 0 then
leave
call out int || substr(sq, cx, nx-cx)
int = iNx
if substr(sq, nx, 3) = '(se' then do
iNx = iNx' '
br = left(br, length(int))')'
end
cx = nx
end
ll = strip(substr(sq, cx))
bq = strip(br)
do while bq <> ''
if right(bq, 1) \== ')' | right(ll, 1) \== ')' then
call err 'missing ) bq:' bq', ll:' ll
ll = strip(left(ll, length(ll) - 1))
bq = strip(left(bq, length(bq) - 1))
end
call out int || ll
if br <> '' then
call out br
if ord <> '' then
call out ' order by' ord
return
endProcedure sqlCatTbTrailer
sqlCatIxKeys: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select ikK.colSeq, ikK.colName, ikK.ordering, ikK.period' ,
', ik.creator, ik.name, ik.tbCreator, ik.tbName, ikC.*' ,
tkrTable(, tb ,'f') wh,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-16C','index'
call sqlFTabAdd ft, colSeq , '%5i', 'coSeq'
call sqlFTabAdd ft, colName, '%-16C', 'column'
call sqlFTabAdd ft, ordering
call sqlFTabAdd ft, period
call sqlFTabAdd ft, COLNO
call sqlFTabAdd ft, COLTYPE
call sqlFTabAdd ft, LENGTH
call sqlFTabAdd ft, SCALE
call sqlFTabAdd ft, NULLS
call sqlFTabOthers ft, 'COL9 COL10 COL11 COL47'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIxKeys
sqlCatIXStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select *' tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, CREATOR, '%-8C', 'creator'
call sqlFTabAdd ft, NAME , , 'index'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatIXStats
sqlCatTables: procedure expose m.
parse arg ft, tb, wh, ord
al = m.tb.alias
sq = 'select' al'.*, tsX.type tsType, tsX.partitions',
', tsX.pgSize, tsX.dsSize' ,
', timestamp(rba1 || x''0000'') rba1Tst' ,
', timestamp(rba2 || x''0000'') rba2Tst' ,
'from' m.tb.table 'left join sysibm.sysTablespace tsX',
'on' al'.dbName = tsx.dbName and' al'.tsName = tsX.name',
'where' m.tb.cond wh ,
'order by' if(ord == '', m.tb.order, ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, creator , '%-8C', 'creator'
call sqlFTabAdd ft, NAME , '%-24C', 'table'
call sqlFTabAdd ft, type
call sqlFTabAdd ft, dbNAME , '%-8C', 'db'
call sqlFTabAdd ft, tsNAME , '%-8C', 'ts'
call sqlFTabAdd ft, tsType
call sqlFTabAdd ft, partitions, , 'parts'
call sqlFTabAdd ft, pgSize
call sqlFTabAdd ft, dsSize
call sqlFTabOthers ft, 'RBA1 RBA1TST RBA2 RBA2TST'
call sqlFTabAdd ft, rba1 , '%-12H'
call sqlFTabAdd ft, rba1Tst , , 'rba1Timestamp:GMT'
call sqlFTabAdd ft, rba2 , '%-12H'
call sqlFTabAdd ft, rba2Tst , , 'rba2Timestamp:GMT'
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTables
sqlCatTSStats: procedure expose m.
parse arg ft, tb, wh, ord
sq = 'select' m.tb.alias'.*' ,
tkrTable( , tb, 'f') wh ,
'order by' if(ord == '', m.tb.order , ord)
call sqlQuery m.ft.sqlX, sq
call sqlFTabAdd ft, DBNAME, '%-8C', 'db'
call sqlFTabAdd ft, NAME , '%-8C', 'ts'
call sqlFTabAdd ft, INSTANCE , '%1i' , 'i'
call sqlFTabAdd ft, PARTITION , , 'part'
call sqlFTabAdd ft, NACTIVE , , 'nActive'
call sqlFTabAdd ft, NPAGES , , 'nPages'
call sqlFTabAdd ft, SPACE , , 'spaceKB'
call sqlFTabAdd ft, TOTALROWS , , 'totRows'
call sqlFTabAdd ft, DATASIZE , , 'dataSz'
call sqlFTabAdd ft, LOADRLASTTIME , , 'loadRLasttime'
call sqlFTabAdd ft, REORGLASTTIME , , 'reorgLasttime'
call sqlFTabAdd ft, REORGINSERTS , , 'inserts'
call sqlFTabAdd ft, REORGDELETES , , 'deletes'
call sqlFTabAdd ft, REORGUPDATES , , 'updates'
call sqlFTabAdd ft, REORGUNCLUSTINS , , 'unClIns'
call sqlFTabAdd ft, REORGDISORGLOB , , 'disorgL'
call sqlFTabAdd ft, REORGMASSDELETE , , 'massDel'
call sqlFTabAdd ft, REORGNEARINDREF , , 'nearInd'
call sqlFTabAdd ft, REORGFARINDREF , , 'farInd'
call sqlFTabAdd ft, REORGCLUSTERSENS , , 'cluSens'
call sqlFTabAdd ft, REORGSCANACCESS , , 'scanAcc'
call sqlFTabAdd ft, REORGHASHACCESS , , 'hashAcc'
call sqlFTabAdd ft, STATSLASTTIME , , 'statsLasttime'
call sqlFTabAdd ft, STATSINSERTS , , 'inserts'
call sqlFTabAdd ft, STATSDELETES , , 'deletes'
call sqlFTabAdd ft, STATSUPDATES , , 'updates'
call sqlFTabAdd ft, STATSMASSDELETE , , 'massDel'
call sqlFTabAdd ft, COPYLASTTIME , , 'copyLasttime'
call sqlFTabAdd ft, COPYUPDATETIME , , 'copyUpdatetime'
call sqlFTabAdd ft, COPYUPDATELRSN , '%-12H', 'updateLRSN'
call sqlFTabAdd ft, COPYUPDATEDPAGES , , 'updaPgs'
call sqlFTabAdd ft, COPYCHANGES , , 'changes'
call sqlFTabOthers ft
call sqlCatTbVl ft, tb
return sq
endProcedure sqlCatTSStats
sql4obj: procedure expose m.
parse arg m, tb
call out 'insert into' tb '--' className(objClass(m))
line = ''
ff = oFlds(m)
pr = ' ('
do fx=1 to m.ff.0
call sql4ObjOut m.ff.fx
end
call sql4ObjOut , 1
call out ' ) values '
pr = ' ('
do fx=1 to m.ff.0
f1 = m || left('.', m.ff.fx \== '')m.ff.fx
v = m.f1 /* no strip T, gives errors in RCM profile | */
if dataType(v, n) then
call sql4ObjOut v
else do qx=1 until v == ''
vx = verify(v, m.ut_alfPrint)
if vx = 0 then do
l1 = min(60, length(v))
w = quote(left(v, l1), "'")
end
else if vx > 29 then do
l1 = min(60, vx-1)
w = quote(left(v, l1), "'")
end
else do
l1 = min(29, length(v))
w = 'x'quote(c2x(left(v, l1)), "'")
end
if qx == 1 then
call sql4ObjOut w
else do
if qx = 2 then
call sql4ObjOut , 1
call out ' ||' w
end
v = substr(v, l1+1)
end
end
call sql4ObjOut , 1
call out ' ) ; '
return
endProcedure
sql4objOut:
parse arg t1, force
if (force == 1 & line \== '') | length(line t1) > 65 then do
call out pr substr(line, 3)
pr = ' ,'
line = ''
end
if force \== 1 then
line = line',' t1
return
endProcedure sql4objOut
/*--- -dis db interface ---------------------------------------------*/
/*--- do one -dis db... and insert it into stem --------------------*/
sqlDisDb: procedure expose m.
parse upper arg o, cc
do cx=1
mid = strip(left(m.cc.cx, 10))
if words(mid) > 1 then
call err 'bad msgId' mid 'line:' m.cc.cx
if mid == '' | wordPos(mid, 'DSNT360I DSNT361I DSNT365I') ,
> 0 then
iterate
if mid == 'DSN9022I' then
if cx = m.cc.0 then
return m.o.0
else
call err 'not at end' cx':' m.cc.cx
if mid \== 'DSNT362I' then
call err 'DSNT362I expected not line:' m.cc.cx
dx = pos('DATABASE =', m.cc.cx)
sx = pos('STATUS =' , m.cc.cx)
if dx < 1 | sx <= dx then
call err 'bad DSNT362I line' cx':' m.cc.cx
db = word(substr(m.cc.cx, dx+10), 1)
sta = strip(substr(m.cc.cx, sx+8))
call sqlDisDbAdd o, db, ,0, 0, 'DB', sta
do cx=cx+1 while abbrev(m.cc.cx, ' ')
end
if abbrev(m.cc.cx, 'DSNT397I ') then do
cx = cx + 1
if \ abbrev(space(m.cc.cx, 1),
, 'NAME TYPE PART STATUS ') then
call err 'NAME TYPE PART STATUS mismatch' cx m.cc.cx
txNa = pos('NAME', m.cc.cx)
txTy = pos('TYPE', m.cc.cx)
txPa = pos('PART', m.cc.cx)
txSt = pos('STAT', m.cc.cx)
txEn = verify(m.cc.cx, ' ', 'n', txSt+6)
if 0 then say 'title' txNa txTy txPa txSt txEn cx m.cc.cx
cx=cx+1
do forever
do while abbrev(m.cc.cx, '----')
cx = cx + 1
end
if abbrev(m.cc.cx, '*') then
leave
parse var m.cc.cx sp =(txTy) ty . =(txPa) paFr . ,
=(txSt) sta =(txEn)
sp = strip(sp)
if words(sp) \= 1 | wordPos(ty, 'TS IX') < 0 then
call err 'bad name or type' cx':'m.cc.cx
if paFr == '' | paFr == 'L*' then
paFr = 0
else if abbrev(paFr, 'D') | abbrev(paFr, 'L') then
paFr = substr(paFr, 2)
if \ datatype(paFr, 'n') then
call err 'part not numeric' cx':'m.cc.cx
paTo = paFr
cw = cx
cx = cx + 1
if abbrev(m.cc.cx, ' -THRU ') then do
parse var m.cc.cx =(txPa) paTo . =(txSt)
if \ datatype(paTo, 'n') then
call err '-thru part not numeric' cx':'m.cc.cx
cx = cx + 1
end
call sqlDisDbAdd o, db, sp, paFr, paTo, ty, sta
end
end
if m.cc.cx = '******** NO SPACES FOUND' then
cx = cx + 1
if abbrev(m.cc.cx, '******* DISPLAY OF DATABASE ') ,
& word(m.cc.cx,5) == db then
if word(m.cc.cx,6) == 'ENDED' then
iterate
else if word(m.cc.cx,6) == 'TERMINATED' then
call err 'db display overflow' cx':' m.cc.cx
call err 'database' db 'ENDED mismatch' cx':' m.cc.cx
end
endProcedure sqlDbDis
/*--- insert one tuple into tDbState ---------------------------------*/
sqlDisDbAdd: procedure expose m.
if arg(7) == '' | arg(7) == 'RW' then
return
parse arg o
m.o.0 = m.o.0 + 1
q = o'.'m.o.0
parse arg , m.q.db, m.q.sp, m.q.paFr, m.q.paTo, m.q.ty, m.q.sta
/* say added q m.q.db'.'m.q.sp':'m.q.paFr'-'m.q.paTo m.q.ty':'m.q.sta*/
ky = m.q.db'.'m.q.sp
if symbol('m.o.ky') \== 'VAR' then
m.o.ky = m.o.0
return
endProceedure sqlDisDbAdd
/*--- get index in o for db sp part ----------------------------------*/
sqlDisDbIndex: procedure expose m.
parse arg st, d, s, pa
if symbol('m.st.d.s') \== 'VAR' then
return 0
ix = m.st.d.s
if ix > m.st.0 | d \== m.st.ix.db | s \== m.st.ix.sp then
return 0
if pa == '' then
return ix
do ix=ix to m.st.0 while d == m.st.ix.db & s == m.st.ix.sp
if pa < m.st.ix.paFr then
return 0
else if pa <= m.st.ix.paTo then
return ix
end
return 0
endProcedure sqlDisDbIndex
/*--- dsn Command, return true if continuation needed ----------------*/
sqlDsnCont: procedure expose m.
parse arg cc, ssid, cmd
say '???dsnCont' cmd
cont = sqlDsn(cc, ssid, cmd, 12) <> 0
if cont then do
cz = m.cc.0
cy = cz - 1
if \ abbrev(m.cc.cy, DSNT311I) ,
| \ abbrev(m.cc.cz, 'DSN9023I') then
call err 'sqlDsn rc=12 for' cmd 'out='cz ,
'\n'cy'='m.cc.cy'\n'cz'='m.cc.cz
m.cc.0 = cz-2
end
return cont
endProcedure sqlDsnCont
/* copy sqlDiv end **************************************************/
/* copy db2Cat begin **************************************************/
catTbLastCol: procedure expose m.
parse upper arg cr, tb
return sql2one( ,
"select strip(char(colcount)) || ' ' || strip(c.name) one" ,
"from sysibm.sysTables t left join sysibm.sysColumns c" ,
"on c.tbCreator = t.creator and c.tbName = t.name" ,
"and c.colNo = t.colCount" ,
"where t.creator = '"cr"' and t.name = '"tb"'",,,, 'r')
endProcedure catTbLastCol
catTbCols: procedure expose m.
parse upper arg cr, tb
if sql2St("select strip(name) name " ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = m.ggst.1.name
do cx=2 to m.ggst.0
res = res m.ggst.cx.name
end
return res
endProcedure catTbCols
catTbColsTrunc: procedure expose m.
parse upper arg cr, tb, maxL
if sql2St("select strip(name) name, colType, length, length2" ,
"from sysibm.sysColumns " ,
"where tbcreator = '"cr"' and tbname='"tb"'",
"order by colNo", ggSt) < 1 then
return ''
res = ''
do cx=1 to m.ggst.0
ty = m.ggSt.cx.colType
if pos('LOB', ty) > 0 then
res = res', substr('m.ggSt.cx.name', 1,' ,
min(maxL, m.ggSt.cx.length2)') 'm.ggSt.cx.name
else if pos('CHAR', ty) > 0 & m.ggSt.cx.length > maxL then
res = res', substr('m.ggSt.cx.name', 1,' maxL')',
m.ggSt.cx.name
else
res = res',' m.ggSt.cx.name
end
return substr(res, 3)
endProcedure catTbColsTrunc
catIxKeys: procedure expose m.
parse upper arg cr, ix
sql = "select colSeq sq, colName col, ordering ord" ,
"from sysibm.sysKeys" ,
"where ixCreator = '"cr"' and ixName = '"ix"'" ,
"order by colSeq"
call sqlQuery 1, sql
res = ''
drop d
do kx=1 while sqlFetch(1, d)
if m.d.sq \= kx then
call err 'expected' kx 'but got colSeq' m.d.sq ,
'in index' cr'.'ix'.'m.d.col
res = res || strip(m.d.col) || translate(m.d.ord, '<>?', 'ADR')
end
call sqlClose 1
return res
endProcedure catIxKeys
catColCom: procedure expose m.
parse upper arg fCr, fTb, tCr, tTb
sql = "select t.name, t.colType, t.nulls, t.""DEFAULT""" ,
", coalesce(f.nulls, 'new')" ,
"from sysibm.sysColumns t" ,
"left join sysibm.sysColumns f" ,
"on f.tbCreator = '"fCr"' and f.tbName = '"fTb"'" ,
"and f.name = t.name" ,
"where t.tbCreator = '"tCr"' and t.tbName = '"tTb"'" ,
"order by t.colNo"
call sqlQuery 1, sql, 'na ty nu de nn'
pr = ' '
do kx=1 while sqlFetch(1)
/* say kx m..na m..ty m..nu m..de 'nn' m..nn */
if pos('CHAR', m..ty) > 0 then
dv = "''"
else if pos('INT' ,m..ty) > 0 ,
| wordPos(m..ty, 'REAL FLOAT') > 0 then
dv = 0
else if m..ty == 'TIMESTMP' then
dv = '0001-01-01-00.00.00'
else if pos('LOB', m..ty) > 0 then
dv = m..ty"('')"
else
dv = '???'
if m..nu = 'Y' then
dv = 'case when 1=0 then' dv 'else null end'
r = '???'
if m..ty = 'ROWID' then do
r = '--'
end
else if m..nn == 'new' then do
if m..de = 'Y' then
r = '--'
else if m..nu == 'N' then
r = dv
else
r = 'case when 1=0 then' dv 'else null end'
end
else do
if m..nu = 'Y' | (m..nu = m..nn) then
r = ''
else
r = 'coalesce('m..na',' dv')'
end
if abbrev(r, '--') then do
r = ' ' r
end
else do
r = pr r
pr = ','
end
if pos('???', r) > 0 then
call err 'no default for type' m..ty 'in' tCr'.'tTb'.'m..na
call out r m..na
end
call sqlClose 1
return
endProcedure catColCom
/* copy db2Cat end **************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlIni: procedure expose m.
if m.sql_ini == 1 then
return
m.sql_ini = 1
call sqlRxIni
call jIni
call fTabIni
call scanWinIni
m.sqlO.cursors = left('', 200)
m.sql_rdrClass = classNew('n SqlRdr u JRW', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
, "jOpen call sqlRdrOpen m, opt",
, "jClose call sqlRdrClose m",
, "jRead return sqlRdrRead(m)")
call classNew 'n SqlResRdr u JRW', 'm',
, "jReset m.m.cursor = arg; m.m.type = arg2;",
, "jOpen call sqlRdrO2 m" ,
, "jClose call sqlClose m.m.cursor" ,
, "jRead return sqlRdrRead(m)"
call classNew 'n SqlRxConnection u', 'm',
, "sqlQuery return sqlRxQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(cx, dst, retOk)",
, "sqlClose return sqlRxClose(cx, retOk)",
, "sqlUpdate return sqlRxUpdate(cx, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlRxStatement u', 'm',
, "sqlQuery return sqlRxQuery(m.cx.cursor, src, feVa, retOK)",
, "sqlFetch return sqlRxFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return sqlRxClose(m.cx.cursor, retOk)",
, "sqlUpdate return sqlRxUpdate(m.cx.cursor, src, retOk)",
, "sqlCall call err 'implement sqlRxCall"
call classNew 'n SqlCsmConnection u', 'm',
, "sqlQuery return sqlCsmQuery(cx, src, feVa, retOK)",
, "sqlFetch return sqlCsmFetch(cx, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
call classNew 'n SqlCsmStatement u', 'm',
, "sqlQuery return sqlCsmQuery(m.cx.cursor, src, feVa, retOk)",
, "sqlFetch return sqlCsmFetch(m.cx.cursor, dst, retOk)",
, "sqlClose return 0",
, "sqlUpdate call err 'implement sqlCsmUpdate'" ,
, "sqlCall call err 'implement sqlCsmCall'"
/* call classNew 'n SqlExecuteRdr u JRW', 'm',
, "jReset call sqlExecuteRdrReset(m, arg, arg2)" ,
, "jOpen call sqlExecuteRdrOpen(m)" ,
, "jClose call sqlExecuteRdrClose(m)" ,
, "jRead call sqlExecuteRdrRead(m)" ???????? */
return 0
endProcedure sqlIni
/*--- connect to DB2 dsnRexx or csm ----------------------------------*/
sqlConnect: procedure expose m.
parse upper arg sys, retOk
call sqlIni
if sys == '' then
sys = sqlDefaultSys()
if pos('/', sys) <= 0 then do
call sqlRxConnect sys
m.sql_connClass = class4Name('SqlRxConnection')
end
else do
parse var sys m.sql_csmHost '/' m.sql_dbSys
m.sql_connClass = class4Name('SqlCsmConnection')
end
return 0
endProcedure sqlConnect
/*--- disconnect from db2 --------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg retOk
if m.sql_csmHost == '' then
call sqlRxDisconnect
else
m.sql_csmHost = ''
m.sql_dbSys = ''
m.sql_connClass = 'sql not connected'
return 0
endProcedure sqlDisonnect
/*--- execute a query from sql, with one resultset -------------------*/
sqlQuery: procedure expose m.
parse arg cx, src, feVa, retOk
interpret classMet(m.sql_connClass, 'sqlQuery')
endProcedue sqlQuery
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlFetch: procedure expose m.
parse arg cx, dst, retOk
interpret classMet(m.sql_connClass, 'sqlFetch')
endProcedue sqlFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, retOk
interpret classMet(m.sql_connClass, 'sqlClose')
endProcedue sqlClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlUpdate: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlUpdate')
endProcedue sqlUpdate
/*-- execute an sql call with outParms and multiple resultSets -------*/
sqlCall: procedure expose m.
parse arg cx, src, retOk
interpret classMet(m.sql_connClass, 'sqlCall')
endProcedure sqlCall
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg rng
if rng == '' then
return sqlGetCursorRng(rng, 10, 48)
else if rng == 'h' then
return sqlGetCursorRng(rng, 60, 99)
else if rng == 'a' then
return sqlGetCursorRng(rng, 110, 199)
else
call err 'bad cursor range' rng
endProcedure sqlGetCursor
sqlGetCursorRng: procedure expose m.
parse arg rng, fr, to
cx = pos(' ', m.sqlO.cursors, fr)
if cx < fr & cx > to then
call err "no more '"rng"' cursors between" fr "and" to,
":"m.sqlO.cursors
m.sqlO.cursors = overlay('u', m.sqlO.cursors, cx)
return cx
endProcedure sqlGetCursorRNG
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if substr(m.sqlO.cursors, cx, 1) \== 'u' then
call err 'sqlFreeCursor('cx') not in use :'m.sqlO.cursors
m.sqlO.cursors = overlay(' ', m.sqlO.cursors, cx)
return
endProcedure sqlFreeCursor
/*** execute sql's in a stream (separated by ;)
opt: 'o' ==> write objects, otherwise fTabAuto
'sql72' ==> spufi formatting (window 72) else linebreaks */
sqlStmts: procedure expose m.
parse arg sqlSrc, retOk, opt
return sqlsOut(scanSqlStmtRdr(sqlSrc, opt), retOk, 'a')
endProcedure sqlStmts
/*--- execute the given sql plus a commit
until no more rows are updated -----------------------------*/
sqlUpdComLoop: procedure expose m.
parse arg src, retOk
crs = sqlGetCursor()
upds = 0
if retOk == '' then
retOk = 100
do coms=0
cd = sqlExecute(crs, src, retOk)
if m.sql.crs.updateCount < 1 then do
call sqlFreeCursor(crs)
return sqlMsgLine( , upds, src, coms 'commits')
end
upds = upds + m.sql.crs.updateCount
call sqlCommit
if coms // 20 = 19 then
say sqlMsgLine(time(), upds, src, (coms+1) 'commits')
end
endProcedure sqlUpdComLoop
/*--- sql call statement ---------------------------------------------*/
sqlStmtCall: procedure expose m.
parse arg src, retOk, opt
s = scanSqlReset(scanSrc(sqlstmtcall, src))
if \ scanSqlId(scanSkip(s)) | m.s.val \== 'CALL' then
call scanErr s, 'not a call'
if \ scanSqlQuId(scanSkip(s)) then
call scanErr s, 'qualified id missing after call'
loc = ''
if m.s.val.0 = 1 then
wh = 'name =' quote(m.s.val.1, "'")
else if m.s.val.0 = 2 then
wh = "schema = '"strip(m.s.val.1)"'" ,
"and name = '"strip(m.s.val.2)"'"
else if m.s.val.0 = 3 then do
loc = m.s.val.1
wh = "schema = '"strip(m.s.val.2)"'" ,
"and name = '"strip(m.s.val.3)"'"
end
else
call scanErr s, 'storedProcedureName' m.s.val ,
'has' m.s.val.0 'parts, should have 1, 2 or 3'
pn = m.s.val
da = sqlStmtCallDa(sqlStmtCall, loc, wh)
if \ scanLit(scanSkip(s), '(') then
call scanErr s, '( expected after call' pn
varChars = f
do ax=1
m.da.ax.varName = ''
isEmpty = 0
if scanLit(scanSkip(s), ':') then do
if \ scanVerify(scanSkip(s), m.ut_alfDot) then
call scanErr s, 'variable expected after : in call' pn
m.da.ax.varName = m.s.tok
if m.da.ax.io == 'i' | m.da.ax.io == 'b' then
m.da.ax.sqlData = envGet(m.da.ax.varName)
end
else if scanString(s) then
m.da.ax.sqlData = m.s.val
else if scanVerify(s, ',):;', 'm') then
m.da.ax.sqlData = strip(m.s.tok)
else
isEmpty = 1
if scanLit(scanSkip(s), ')') then
leave
if \ scanLit(s, ',') then
call scanErr s, if(isEmpty, 'value, var, ') ,
|| "',' or ')' expected"
end
if ax \= m.da.sqlD then
if \ (ax=1 & m.da.sqlD = 0 & isEmpty) then
call scanErr s, 'call with' ax 'parms but' ,
pn 'needs' m.da.sqld
caCo = sqlExec('call' pn 'using descriptor :M.'da, 466)
call out '--- called' pn', sqlCode' caCo
do ax=1 to m.da.sqlD
call Out ' parm' ax m.da.ax.io m.da.ax.parmName,
|| if(m.da.ax.varName \== '',' $'m.da.ax.varName),
'=' m.da.ax.sqlData
if m.da.ax.varName \== '' then
call envPut m.da.ax.varName, m.da.ax.sqlData
end
if caCo = 466 then do
drop sqlDP
call sqlExec 'describe procedure :pn into :m.sqlDp'
if m.sqldp.sqlD < 1 then
call err 'bad sqldp sqlD='m.sqldp.sqlD 'for sqlCode' caCo
do dx=1 to m.sqldp.sqlD
call out ' dynamic result set' dx m.sqldp.dx.sqlName ,
'locator='m.sqldp.dx.sqlLocator
end
do dx=1 to m.sqldp.sqlD
drs = 'dynamic result set' dx'='m.sqldp.dx.sqlName 'of' pn
call out '--- begin of' drs
rdr = sqlDRS(m.sqldp.dx.sqlLocator)
if pos('o', opt) > 0 then
call pipeWriteAll rdr
else
call fTabAuto sqlStmtFmt, rdr
call out '---' m.rdr.rowCount 'rows fetched from' drs
end
end
return 'sqlCode' caCo
endProcedure sqlStmtCall
sqlStmtCallDa: procedure expose m.
parse arg da, loc, wh
cr = if(loc=='',,loc'.')'sysIbm'
sql = "select 'SCHEMA=''' || strip(schema) || ''''",
"|| ' and name=''' || strip(name ) || ''''",
"|| ' and specificName=''' || strip(specificName) || ''''",
"|| ' and routineType =''' || strip(routineType ) || ''''",
"|| ' and VERSION =''' || strip(VERSION ) || ''''",
"from" cr".SysRoutines ",
"where" wh "and active = 'Y'"
if sqlpreAllCl(49, sql, rou, ':m.rou') <> 1 then
call err m.rou.0 'routines found for' wh
rdr = jOpen(sqlRdr('select * from' cr'.sysParms where' m.rou,
'order by ordinal'), '<')
do ix=1 while jRead(rdr)
a = m.rdr
if m.a.ordinal <> ix then
call err 'ix' ix 'mismatch ordinal' m.a.ordinal
ty = m.a.dataTypeId
m.da.ix.sqlType = ty
m.da.ix.sqlLen = m.a.length
m.da.ix.sqlLen.sqlPrecision = m.a.length
m.da.ix.sqlLen.sqlScale = m.a.scale
if wordPos(ty, 384 385) > 0 then /* date */
m.da.ix.sqlLen = 10
else if wordPos(ty, 388 389) > 0 then /* time */
m.da.ix.sqlLen = 8
else if wordPos(ty, 392 393) > 0 then /* timestamp */
m.da.ix.sqlLen = 26
m.da.ix.sqlData = ''
m.da.ix.parmName= m.a.parmName
m.da.ix.io = translate(m.a.rowType, 'iob', 'POB')
m.da.ix.sqlInd = 1
end
m.da.sqlD = ix - 1
return da
endProcedure sqlStmtCallDa
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlRdr: procedure expose m.
parse arg src, type
return oNew('SqlRdr', scanSqlIn2Stmt(src), type)
endProcedure sqlRdr
sqlRdrOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlRdrOpen('m',' opt')'
cx = sqlGetCursor()
m.m.cursor = cx
if words(m.m.type) <> 1 | abbrev(m.m.type, ' ') then do
m.sql.cx.fetchClass = ''
call sqlQuery m.m.cursor, m.m.src, m.m.type
m.m.type = sqlFetchClass(cx)
end
else do
m.m.type = class4name(m.m.type)
call sqlQuery m.m.cursor, m.m.src, mCat(classFlds(m.m.type),' ')
m.sql.cx.fetchClass = m.m.type
end
call sqlRdrO2 m
return
endProcedure sqlRdrOpen
sqlQuery2Rdr: procedure expose m.
parse arg cx
r = jReset(oMutate('SQL_RDR.'cx, 'SqlResRdr'), cx)
m.r.type = sqlFetchClass(cx)
return r
endProcedure
sqlFetchClass: procedure expose m.
parse arg cx, force
if m.sql.cx.fetchClass == '' | force == 1 then
m.sql.cx.fetchClass = classNew('n* Sql u f%v' ,
m.sql.cx.fetchFlds)
return m.sql.cx.fetchClass
endProcedure sqlFetchClass
sqlRdrO2: procedure expose m.
parse arg m
cx = m.m.cursor
if m.m.type \== m.sql.cx.fetchClass | m.m.Type == '' then
call err 'type' m.m.type '\==' m.sql.cx.fetchClass 'fetchClass'
m.m.rowCount = 0
m.sql_lastRdr = m
return
endProcedure sqlRdrO2
/*--- close sql Cursor -----------------------------------------------*/
sqlRdrClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
m.m.cursor = ''
return m
endProcedure sqlRdrClose
/*--- read next from cursor, return as object ------------------------*/
sqlRdrRead: procedure expose m.
parse arg m
v = oNew(m.m.type)
if \ sqlFetch(m.m.cursor, v) then do
call mFree v
return 0
end
m.m.rowCount = m.m.rowCount + 1
m.m = v
return 1
endProcedure sqlRdrRead
/*--- return sqlFTab for this (open) rdr -----------------------------*/
sqlRdrFtabReset: procedure expose m.
parse arg m, q, maxChar, blobMax, maxDec
if m == '' then
m = m.sql_lastRdr
if \ dataType(m.m.cursor, 'n') then
call err 'sqlRdrFTabReset('m') but cursor empty'
return sqlFTabReset(q, m.m.cursor, maxChar, blobMax, maxDec)
endProcedure sqlRdrFTabReset
/*--- output sql as table --------------------------------------------*/
sql2tab: procedure expose m.
parse arg tBef, tAft, maxChar, blobMax, maxDec
cx = sqlGetCursor()
call sqlQuery cx, in2str(,' ')
t = sqlFTabReset('SQL.'cx'.fTab', cx,
, tBef, tAft, maxChar, blobMax, maxDec)
call sqlFTab sqlFTabOthers(t)
call sqlClose cx
call sqlFreeCursor cx
return
endProcedure sql2tab
/*--- select and write all to stdOut ---------------------------------*/
sqlSel: procedure expose m.
parse arg src, type
s = sqlRdr(src, type)
call pipeWriteAll s
return m.s.rowCount
endProcedure sqlSel
/*--- result of each sql read from rdr to out
oo='a' autoTab, 't'=sqlTab, 'o'=object, 'c'=csv ----------*/
sqlsOut: procedure expose m.
parse arg rdr, retOk, oo
m.sql_errRet = 0
if oo == '' then
oo = 'a'
cx = sqlGetCursor()
r = jOpen(in2file(rdr), '<')
do while jRead(r)
sqlC = sqlExecute(cx, m.r, retOk)
if m.sql_errRet then
leave
if m.sql.cx.resultSet == '' then do
call outNl(m.sql_HaHi ,
|| sqlMsgLine(sqlC, m.sql.cx.updateCount, m.r))
end
else if oo == 'o' then do
call pipeWriteAll sqlQuery2Rdr(cx)
end
else if oo == 'a' | oo == 't' then do
sqR = sqlQuery2Rdr(cx)
ft = sqlfTabOpts(fTabReset('sqls2AutoFT', 'c 1'), cx)
if oo == 't' then do
call sqlFTabOthers(ft)
end
else do
bf = in2Buf(sqR)
if m.sql_errRet then
leave
call sqlFTabDetect ft, bf'.BUF'
call fTab ft, bf
call out sqlMsgLine(m.sqR.rowCount 'rows fetched',
, , m.r)
end
end
else
call err 'bad outputOption' oo
end
call jClose r
if m.sql_errRet then do
/* call out 'sqlsOut terminating because of sql error' */
call sqlClose cx, '*'
say 'sqlsOut terminating because of sql error'
end
call sqlFreeCursor cx
return \ m.sql_errRet
endProcedure sqlsOut
/*-- execute and put result to m -------------------------------------*/
sqlExecuteRes: procedure expose m.
parse arg m, cx, m.m.sql, retOk ?????
m.m.sqlCode = sqlExecute(cx, m.m.sql, retOk) + deimplement
m.m.sqlMsg = m.sql_HaHi || sqlMsgLine(m.m.sqlCode,
, m.sql.cx.updateCount, m.m.sql)
endProcedure sqlExecuteRes
/*--- execute stmts with options -------------------------------------*/
sqlExecuteRdrReset: procedure expose m.
parse arg rdr, wOpt, m.m.retOk
if abbrev(wOpt, '-sql') then + deimplement ??????????????????
wOpt = substr(wOpt, 5)
call scanSqlReset m'.SCAN', rdr, wOpt, ';'
return m
endProcedure sqlExecuteRdrReset
sqlExecuteRdrOpen: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
m.m.cursor = sqlGetCursor()
return m
endProcedure sqlExecuteRdrOpen
sqlExecuteRdrClose: procedure expose m.
parse arg m
call scanOpt m'.SCAN' + deimplement ??????????????????
call sqlFreeCursor m.m.cursor
drop m.m.cursor
return m
endProcedure sqlExecuteRdrClose
sqlExecuteRdrRead: procedure expose m.
parse arg m, var
src = scanSqlStmt(m'.SCAN') + deimplement ??????????????????
if src == '' then
return 0
call sqlExecuteRes m, m.m.cursor, src, m.m.retOk
m.var = m.m.cursor
return 1
endProcedure sqlExecuteRdrRead
/* copy sqlO end **************************************************/
/* copy sqlCsm begin **************************************************/
/*--- send an sql to csm and handle sqlCode --------------------------*/
sqlCsmExe:
parse arg ggSqlStmt, ggRetOk
sql_HOST = m.sql_csmhost
SQL_DB2SSID = m.sql_dbSys
sql_query = ggSqlStmt
address tso "CSMAPPC START PGM(CSMASQL)"
if \ (rc = 0 | rc = 4) then
return err('csmappc rc' rc)
if sqlCode = 0 then
return 0
else if pos('*', ggRetOk) > 0 | wordPos(sqlCode, ggRetOk) > 0 ,
then do
if sqlCode < 0 & pos('say', ggRetOk) > 0 then
call errSay ' }'sqlmsg(sqlCA2Rx(sqlCa))
return sqlCode
end
else if sqlCode < 0 then
call err sqlmsg(sqlCA2rx(sqlCa))
else if pos('w', ggRetOk) < 1 then
if sqlCode = 100 then
call errSay ' }sqlCode +100 row not found\nsql =' ggSqlStmt
else
call errSay 'w}'sqlMsg(sqlCA2rx(sqlCa))
return sqlCode
endProcedure sqlCsmExe
/*--- execute a query from sql, with one resultset -------------------*/
sqlCsmQuery: procedure expose m.
parse arg cx, sqlSrc, feVa, retOk, dst
res = sqlCsmExe(sqlSrc, 100 retOk)
if res < 0 then
return res
if dst == '' then
dst = 'SQL.'cx'.CSMDATA'
m.dst.0 = 0
m.dst.laIx = 0
st = 'SQL.'cx'.COL'
if abbrev(feVa, '?') | abbrev(feVa, ':') then do
return err('implement sqlCmsQuery fetchVars ? or :' feVa)
end
else if feVa <> '' then do
vv = feVa
end
else do
vv = ''
do kx=1 to sqlD
vv = sqlNiceVarsAdd(vv, SQLDA_REXXNAME.kx)
end
end
m.sql.cx.fetchFlds = vv
if sqlD <> words(vv) then
return err('sqlCsmQuery sqlD' sqlD '<>' words(vv) 'for' vv)
do kx=1 to sqlD
rxNa = SQLDA_REXXNAME.kx
cn = word(vv, kx)
do rx=1 to sqlRow#
if substr(sqlIndicator.rx, kx ,1) == 'ff'x then
m.dst.rx.cn = m.sqlNull
else
m.dst.rx.cn = value(rxNa'.'rx)
end
end
m.dst.0 = sqlRow#
m.sql_lastRdr = 'cms' cx
return 0
endProcedure sqlCsmQuery
sqlCsmFetch: procedure expose m.
parse arg cx, dst
src = 'SQL.'cx'.CSMDATA'
rx = m.src.laIx + 1
if rx > m.src.0 then
return 0
m.src.laIx = rx
ff = m.sql.cx.fetchFlds
do kx = 1 to words(ff)
c = word(ff, kx)
m.dst.c = m.src.rx.c
end
return 1
endProcedure sqlCsmFetch
/* copy sqlCsm end **************************************************/
/* copy sqlRx begin ***************************************************
Achtung: inc generiert sql aus sqlRx, Aenderungen nur in sqlRx|
sql interface
***********************************************************************/
/*--- initialize sqlRx -----------------------------------------------*/
sqlRxIni: procedure expose m.
if m.sqlRx_ini == 1 then
return
m.sqlRx_ini = 1
call utIni
m.sqlNull = '---'
m.sqlInd = 'sqlInd'
m.sql_defCurs= 49
m.sqlCAMsg = 0
m.sqlSuMsg = 2
m.sql_dbSys = ''
m.sql_csmhost = ''
isInProd = wordPos(sysvar(sysNode), 'RZ2') > 0
m.sql_retOk = 'dne' copies('rod', \ isInProd)
return 0
endProcedure sqlRxIni
/*--- get default db2System ------------------------------------------*/
sqlDefaultSys: procedure expose m.
parse arg
if sysvar(sysnode) == 'RZ1' then
return 'DBAF'
else if sysvar(sysnode) == 'RZ4' then
return 'DP4G'
else if sysvar(sysnode) == 'RZX' then
return 'DX0G'
else
call err 'no default subsys for' sysvar(sysnode)
endProcedure sqlDefaultSys
/*--- connect to the db2 subsystem sys -----------------------------*/
sqlRxConnect: procedure expose m.
parse upper arg sys, ggRetOk
call sqlIni
address tso "SUBCOM DSNREXX"
if rc <> 0 then do
sRc = RXSUBCOM('ADD','DSNREXX','DSNREXX') /* ADD HOST CMD ENV */
if sRc <> 0 then
call err 'rc' sRc 'from RXSUBCOM(ADD, DSNREXX, DSNREXX)'
end
if sys = '-' then
return 0
if sys == '' then
sys = sqlDefaultSys()
m.sql_dbSys = sys
return sqlExec0('connect' sys)
endProcedure sqlRxConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlRxDisconnect: procedure expose m.
parse arg retOk
if m.sql_dbSys == '' then
return 0
m.sql_dbSys = ''
m.sql_csmHost = ''
return sqlExec0('disConnect')
endProcedure sqlRxDisconnect
/*--- reset sql cursor 'c'cx fields ----------------------------------*/
sqlReset: procedure expose m.
parse arg cx
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
m.sql.cx.d.sqlD = 'noSqlDA'
m.sql.cx.i.sqlD = 'noDescInp'
m.sql.cx.fetchVars = ''
m.sql.cx.fetchFlds = ''
m.sql.cx.fetchClass = ''
m.sql.cx.type = ''
return
endProcedue sqlReset
/*--- execute a query from sql, with one resultset -------------------*/
sqlRxQuery: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if pos(left(feVa, 1), '?:') < 1 then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
res = sqlExec('open c'cx, retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlRxQuery
/*--- prepare a query from sql, with one resultset -------------------*/
sqlQueryPrepare: procedure expose m.
parse arg cx, src, feVa, retOk
call sqlReset cx
s1 = ''
if feVa == '' | feVa = 'd' then
s1 = 'into :M.SQL.'cx'.D'
res = sqlExec('prepare s'cx s1 'from :src', retOk)
if res < 0 then
return res
call sqlRxFetchVars cx, feVa
call sqlExec 'declare c'cx 'cursor for s'cx
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlQueryPrepare
sqlQueryExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('open c'cx 'using descriptor :M.SQL.'cx'.I', retOk)
if res < 0 then
return res
m.sql.cx.updateCount = sqlErrd.3
m.sql.cx.resultSet = cx
return res
endProcedure sqlQueryExecute
/*--- fetch next row to m.dst.* at end return false ------------------*/
sqlRxFetch: procedure expose m.
parse arg cx, dst, retOk
fetCode = sqlExec('fetch c'cx 'into' m.sql.cx.fetchVars, 100 retOk)
if fetCode == 100 then
return 0
if fetCode < 0 then
return fetCode
interpret m.sql.cx.fetchCode
return 1
endProcedure sqlRxFetch
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlRxClose: procedure expose m.
parse arg cx, retOk
return sqlExec('close c'cx, retOk)
endProcedure sqlRxClose
/*-- execute an sql with no resultset, but possibly outParms ---------*/
sqlRxUpdate: procedure expose m.
parse arg cx, src, retOk
m.sql.cx.updateCount = ''
m.sql.cx.resultSet = ''
bx = verify(src, '( ')
if bx > 0 then
fun = translate(word(substr(src, bx), 1))
if fun = 'SET' then do
w2 = translate(word(substr(src, bx), 2))
if \ abbrev(w2, ':') then
return sqlExec('execute immediate :src', retOk)
trace ?r
ex = pos('=', w2)
if ex = 0 then
ex = length(w2)+1
var = strip(substr(w2, 2, ex-2))
if var = '' then
call err 'bad hostVar in' src
m.sql.outVar = var
src2 = 'set :M.sql.out.'var substr(w, ex) subword(src, 3)
return sqlExec(src2, retOk)
end
if fun == 'DECLARE' then do
if 'GLOBAL' == translate(word(substr(src, bx), 2)) then
return sqlExec('execute immediate :src', retOk)
end
res = sqlExec(src, retOk)
if wordPos(fun, 'DELETE INSERT UPDATE') > 0 then
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlRxUpdate
/*-- prepare an update -----------------------------------------------*/
sqlUpdatePrepare: procedure expose m.
parse arg cx, src, retOk
res = sqlExec('prepare s'cx 'from :src', retOk)
return sqlExec('describe input s'cx 'into :M.SQL.'cx'.I')
endProcedure sqlUpdatePrepare
/*-- execute a prepared update with the given arguments --------------*/
sqlUpdateExecute: procedure expose m.
parse arg cx retOk
do ix=1 to arg()-1
call sqlDASet cx , 'I', ix, arg(ix+1)
end
res = sqlExec('execute s'cx 'using descriptor :M.SQL.'cx'.I',
, retOk)
m.sql.cx.updateCount = sqlErrd.3
return res
endProcedure sqlUpdateExecute
/*-- execute a query, update or call ---------------------------------*/
sqlExecute: procedure expose m.
parse arg cx, src, retOk
f = translate(word(src, 1))
bx = pos('(', f)
if bx > 0 then
f = left(f, max(1, bx-1))
m.sql.cx.fun = f
if f == 'SELECT' | f == 'WITH' | f == '(' then
return sqlQuery(cx, src, , retOk)
else if f == 'CALL' then
call err 'implement sql call for:' src
else
return sqlUpdate(cx, src, retOk)
endProcedure sqlExecute
/*-- fetch all rows to stem and close --------------------------------*/
sqlFetch2St: procedure expose m.
parse arg cx, dst, retOK
do sx=1 while sqlFetch(cx, dst'.'sx)
end
res = sx-1
m.dst.0 = sx-1
call sqlClose cx
return m.dst.0
endProcedure sqlFetch2St
/*-- execute a query, copy result to stem ----------------------------*/
sql2St: procedure expose m.
parse arg src, dst, feVa, retOK
cx = m.sql_defCurs
res = sqlQuery(cx, src, feVa, retOk)
return sqlFetch2St(cx, dst, retOk)
endProcedure sql2St
/*-- return first column of the only row and close -------------------*/
sqlFetch2One: procedure expose m.
parse arg cx, dst, retNone
f1 = sqlFetch(cx, dst)
if f1 then
f2 = sqlFetch(cx, dst'.2')
call sqlClose cx
if \ f1 then
if retNone \== '' then
return substr(retNone, 2)
else
call err 'sqlFetch2One: no row returned'
else if f2 then
call err 'sqlFetch2One: more than 1 row'
if m.sql.cx.fetchFlds == '' then do
c1 = substr(word(m.sql.cx.fetchVars, 1), 2)
res = value(c1)
return res
end
c1 = word(m.sql.cx.fetchFlds, 1)
return m.dst.c1
endProcedure sqlFetch2One
/*-- execute a query and return first column of the only row
if > 1 row fail, if 0 rows return arg(3) or fail ----------*/
sql2One: procedure expose m.
parse arg src, dst, feVa, retOk, retNone
cx = m.sql_defCurs
call sqlQuery cx, src, feVa, retOk
return sqlFetch2One(cx, dst, retNone)
endProcedure sql2One
/*--- describe table and return sqlDA --------------------------------*/
sqlDescribeTable: procedure expose m.
parse upper arg tb, force
if force == 1 | \ datatype(m.sql.table.tb.sqlD, 'n') then
call sqlExec 'describe table :tb into :M.SQL.TABLE.'tb
return 'SQL.TABLE.'tb
endProcedure sqlDescribeTable
/*--- return select column list for table tb
omit Blobs (blobMax < 0) or substr(blob, 1, blobMax) ----------*/
sqlColList: procedure expose m.
parse arg tb al, blobMax
sd = sqlDescribeTable(tb)
bs = ''
lst = ''
if al \== '' & right(al, 1) \== '.' then
al = al'.'
do sx=1 to m.sd.sqld
if wordPos(m.sd.sx.sqlType, '404 405 408 409 412 413') < 1 then
lst = lst',' al || m.sd.sx.sqlName
else do
bs = bs m.sd.sx.sqlName
if blobMax >= 0 then
lst = lst', length('al || m.sd.sx.sqlName')' ,
m.sd.sx.sqlName'Len' ,
|| ', substr('al || m.sd.sx.sqlName ,
|| ', 1,' blobMax')' m.sd.sx.sqlName
end
end
m.sd.colList = substr(lst, 3)
m.sd.blobs = strip(bs)
return substr(lst, 3)
endProcedure sqlColList
/*--- use describe output to generate column names,
'' use names from ca (rexxified)
nms+ use names, check ca for null values
?('?'?nm)+ use names, check for null if preceeded by ?
:... use string as is
fetchVariables and sqlNull names ---------------------*/
sqlRxFetchVars: procedure expose m.
parse arg cx, src, cd
st = 'SQL.'cx'.COL'
if abbrev(src, ':') then do
m.sql.cx.fetchVars = src
m.sql.cx.fetchCode = cd
m.sql.cx.fetchFlds = ''
return
end
m.sql.cx.fetchVars = ''
if abbrev(src, '?') then do
call err implement + rxFetchVars ?????? /*
r = substr(src, 2)
do wx=1 to words(src)
cn = word(src, wx)
if abbrev(cn, '?') then
call sqlRexxAddVar substr(cn, 2), 0, 1
else
call sqlRexxAddVar cn, 0, 0
end ????????????? */
end
else if src <> '' then do
ff = src
end
else do
ff = ''
do kx=1 to m.sql.cx.d.sqlD
ff = sqlNiceVarsAdd(ff, m.sql.cx.d.kx.sqlName)
end
end
m.sql.cx.fetchFlds = ff
if m.sql.cx.d.sqlD <> words(ff) then
call err 'sqlRxFetchVars sqlD='m.sql.cx.d.sqlD ,
'<>' words(ff) 'fields of' ff
sNu = ''
sFe = ''
do kx=1 to m.sql.cx.d.sqlD
nm = word(ff, kx)
sFe = sFe', :m.dst.'nm
if m.sql.cx.d.kx.sqlType // 2 then do
sFe = sFe' :m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
end
m.sql.cx.fetchVars = substr(sFe, 3)
m.sql.cx.fetchCode = sNu cd
return
endProcedure sqlRxFetchVars
/* ????????????
sqlRexxAddVar:
parse arg nm, nicify, hasNulls
nm = sqlAddVar(st, nm, nicify)
if \ hasNulls then
vrs = vrs', :m.dst.'nm
else do
vrs = vrs', :m.dst.'nm ':m.dst.'nm'.sqlInd'
sNu = sNu 'if m.dst.'nm'.sqlInd < 0 then' ,
'm.dst.'nm '= m.sqlNull;'
end
return
endSubroutine sqlRexxAddVar ?????? */
sqlNiceVarsAdd: procedure expose m.
parse arg old, nx rest
upper nx
cx = verifId(nx)
if cx > 0 then /* avoid bad characters for classNew| */
nx = left(nx, cx-1)
if nx <> '' & wordPos(nx, old) < 1 0 then
return old nx
else
return old 'COL' || (words(old) + 1)
endProcedure sqlNiceVarsAdd
/*--- set one value in a DA, handle nulls ----------------------------*/
sqlDASet: procedure expose m.
parse arg cx, da, ix, val
m.sql.cx.da.ix.sqlData = val
m.sql.cx.da.ix.sqlInd = - (val == m.sqlNull)
/* data types schienen einmal nicht zu funktionieren .......
if wordPos(m.da.ix.sqlType, '384 385 388 389 392 393') > 0 then
m.da.ix.sqlType = 448 + (m.da.ix.sqlType // 2) */
return
endProcedure sqlDASet
sqlCommit: procedure expose m.
parse arg src
return sqlUpdate(, 'commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface ------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggSqlRet0
m.sql_HaHi = ''
do forever
address dsnRexx 'EXECSQL' ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
return err('dsnRexx rc='rc sqlMsg())
/* if pos('-', retOK) < 1 then ?????? */
ggSqlRet = ggSqlRet0 m.sql_retOk
if pos('*', ggSqlRet) >0 | wordPos(sqlCode, ggSqlRet) >0 then do
if sqlCode < 0 & pos('say', ggSqlRet) > 0 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if sqlCode >= 0 then do
if (sqlCode > 0 | sqlWarn.0 \== ' ') ,
& pos('w', ggSqlRet) < 1 then
call outNl errMsg(' }'sqlMsg())
return sqlCode
end
if translate(word(ggSqlStmt, 1)) == 'DROP' then do
if (sqlCode == -204 | sqlCode == -458) ,
& wordPos('dne', ggSqlRet) > 0 then
return sqlCode
if sqlCode = -672 & wordPos('rod', ggSqlRet) > 0 ,
& length(m.sql_hahi) < 1000 then do
m.sql_hahi = m.sql_HaHi || sqlMsgLine(sqlCode,
, 'tb='sqlErrMc ,ggSqlStmt)'\n'
m.sql_hahi = m.sql_HaHi || sqlExecHaHi('alter table' ,
SqlErrMc 'drop restrict on drop')'\n'
iterate
end
end
ggSqlEE = ''
if wordPos('rb', ggSqlRet) > 0 then
ggSqlEE = '\n'sqlExecHaHi('rollback')
if wordPos('ret', ggSqlRet) < 1 then do
call err m.sql_hahi || sqlMsg() || ggSqlEE
return sqlCode
end
m.sql_errRet = 1
call outNl errMsg(' }'m.sql_haHi || sqlMsg() || ggSqlEE)
return sqlCode
end
endProcedure sqlExec
/*--- execute sql thru the dsnRexx interface fail if sqlcode <> 0 ---*/
sqlExec0: procedure expose m.
parse arg ggSqlStmt, ePlus
address dsnRexx ggSqlStmt
if rc == 0 & sqlCode == 0 & sqlWarn.0 == ' ' then
return 0
if \ dataType(sqlCode, 'n') | abs(rc) \== 1 then
ePlus = strip(ePlus 'dsnRexx rc='rc'\n')
return err(ePlus || sqlMsg())
endProcedure sqlExec0
/*--- execute sql fail or return msgLine ----------------------------*/
sqlExecHaHi: procedure expose m.
parse arg ggSqlStmt
return sqlMsgLine(sqlExec0('execSql' ggSqlStmt, m.sql_hahi) ,
, , ggSqlStmt)
endProcedure sqlExechaHi
sqlMsgLine: procedure expose m. sqlErrD.
parse arg res, cnt, src, plus
verb = translate(word(src, 1))
if datatype(res, 'n') then
res = 'sqlCode' res
if cnt \== '' then do
res = res',' cnt
vx = wordPos(translate(word(src,1)), 'DELETE INSERT UPDATE')
if datatype(cnt, 'n') then
if vx > 0 then
res = res 'rows' word('deleted inserted updated', vx)
else if cnt <> 0 then
res = res 'rows updated'
end
if plus \== '' then
res = res',' plus
if abbrev(res, ', ') then
res = substr(res, 3)
if src \== '' then do
ll = 75 - length(res)
aa = strip(src)
if length(aa) > ll then
aa = space(aa, 1)
if length(aa) > ll then
aa = left(aa, ll-3)'...'
res = res':' aa
end
return res
endProcedure sqlMsgLine
/*--- send a command to db2 through the TSO dsn processor ------------*/
sqlDsn: procedure expose m.
parse arg st, sys, cmd, rcOk
x = outtrap('M.'st'.')
push 'END'
push cmd
address tso 'DSN SYSTEM('sys')'
rr = rc
x = outtrap(off)
if rr = 0 | rcOk = '*' | wordPos(rr, rcOk) > 0 then
return rr
fl = max(1, m.st.0 - 10)
em = 'rc' rr 'for DSN SYSTEM('sys') cmd' cmd,
'\nOuputlines' fl '-' m.st.0':'
do lx=fl to m.st.0
em = em '\n' strip(m.st.lx, 't')
end
call err em
endProcedure sqlDsn
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
if \ dataType(sqlCode, 'n') then do
ggRes = 'sqlCode' sqlCode 'not numeric\n'sqlCaMsg()
end
else do
ggRes = sqlDsntiar(sqlRx2CA())
ggWa = sqlMsgWarn()
if ggWa \= '' then
ggRes = ggRes'\nwarnings' ggWa
if m.sqlCAMsg == 1 then
ggRes = ggRes'\n'sqlCaMsg()
end
ggSt = 'SQL_HOST'
ggVa = 'SQL_HOST.VAR'
ggBe = 'SQL_HOST.BEF'
call sqlHostVars ggSqlStmt, 12, ggSt
ggFrom = 'ggSqlStmt'
ggW1 = translate(word(ggSqlStmt, 1))
ggW2 = translate(word(ggSqlStmt, 2))
if ggW1 == 'PREPARE' then
ggFrom = sqlHostVarFind(ggSt, 'FROM')
else if ggW1 ggW2 == 'EXECUTE IMMEDIATE' then
ggFrom = sqlHostVarFind(ggSt, 1)
ggPos = 0
if datatype(sqlErrd.5, 'n') & sqlErrd.5 > 0 then do
ggPos = sqlErrd.5
ggRes = ggRes || sqlMsgSrcPos(value(ggFrom), sqlErrd.5)
end
if ggFrom == 'ggSqlStmt' then do
ggRes = ggRes'\nsql =' sqlShorten(ggSqlStmt, 2000, ggPos)
end
else do
ggRes = ggRes'\nsql =' sqlShorten(value(ggFrom), 2000, ggPos)
ggRes = ggRes'\nstmt =' sqlShorten(ggSqlStmt, 2000)
end
ggPref = '\nwith'
do ggXX=1 to m.ggSt.0
if ggFrom = m.ggVa.ggXX then
iterate
ggRes = ggRes || ggPref m.ggBe.ggXX ':'m.ggVa.ggXX ,
'=' sqlShorten(value(m.ggVa.ggXX), 210)
ggPref = '\n '
end
if m.sqlSuMsg == 1 | (m.sqlSuMsg == 2 & m.sql_csmhost \== '') then
ggRes = ggRes'\nsubsys =' m.sql_dbSys ,
|| ', host =' m.sql_csmhost
return ggRes
endSubroutine sqlMsg
sqlShorten: procedure expose m.
parse arg txt, maxL, pos
if length(txt) <= maxL then
return txt
if \ datatype(pos, 'n') | pos < 1 then
pos = 1
ex = pos + min(60, maxL%7)
if ex <= maxL - 4 then
return left(txt, maxL-4) '...'
if ex >= length(txt) then
return left(txt, 67) '...\n'substr(txt, length(txt)-maxL+72)
else
return left(txt, 67) '...\n'substr(txt, ex-maxL+76, maxL-75) ,
'...'
endProcedure sqlShorten
/*--- use dsnTiar to translate sql Info to error text ----------------*/
sqlDsnTiar: procedure expose m.
parse arg ca
if -438 = sqlCa2Rx(ca) then
return '\nSQLCODE = -438:',
'APPLICATION RAISED ERROR WITH sqlState' sqlState ,
'and DIAGNOSTIC TEXT:' sqlErrMc
liLe = 78
msLe = liLe * 10
msg = d2c(msLe,2) || left('', msLe)
len = d2c(liLe, 4)
ADDRESS LINKPGM "DSNTIAR ca msg len"
if rc = 0 then nop
else if rc = 4 then say 'warn linkPgm dsnTiar rc' rc 'sqlCa' ca
else call err 'linkPgm dsnTiar rc' rc 'sqlCa' ca
res = strip(substr(msg, 13, liLe-10))
cx = pos(', ERROR: ', res)
if cx > 0 then
res = left(res, cx-1)':' strip(substr(res, cx+9))
do c=3+liLe by liLe to msLe while substr(msg, c, 10) = ''
res = res'\n 'strip(substr(msg, c+10, liLe-10))
end
return res
endProcedure sqlDsnTiar
/*--- format all rexx sqlCa fields into a message --------------------*/
sqlCaMsg:
return 'sqlCode' sqlCode 'sqlState='sqlState ,
'\n errMC='translate(sqlErrMc, ',', 'ff'x) ,
'\n warnings='sqlWarnCat('+') 'erP='sqlErrP ,
'\n errD.1='sqlErrD.1 '2='sqlErrD.2 '3='sqlErrD.3 ,
'\n errD.4='sqlErrD.4 '5='sqlErrD.5 '6='sqlErrD.6
endProcedure sqlCaMsg
/*--- concat the sql warnings with Separator sep --------------------*/
sqlWarnCat: procedure expose m. sqlWarn.
parse arg sep
return sqlWarn.0 || sep,
|| sqlWarn.1||sqlWarn.2||sqlWarn.3||sqlWarn.4||sqlWarn.5||sep ,
|| sqlWarn.6||sqlWarn.7||sqlWarn.8||sqlWarn.9||sqlWarn.10||sep
endProcedure sqlWarnCat
/*--- format the sqlCA into the dsnTiar SQLCA ------------------------*/
sqlRx2Ca: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
if \ (datatype(sqlcode, 'n') & datatype(sqlErrD.1, 'n') ,
& datatype(sqlErrD.3, 'n')) then
return err('sqlCode etc. not numeric\nsqlCa =' sqlCaMsg())
if digits() < 10 then
numeric digits 10
sqlCa = 'SQLCA ' || d2c(136, 4) || d2c(sqlCode, 4) ,
|| d2c(min(70, length(sqlErrMc)), 2)left(sqlErrMc, 70) ,
|| left(sqlErrP, 8) ,
|| d2c(sqlErrD.1, 4)d2c(sqlErrD.2, 4)d2c(sqlErrD.3, 4) ,
|| d2c(sqlErrD.4, 4)d2c(sqlErrD.5, 4)d2c(sqlErrD.6, 4) ,
|| sqlWarnCat() || sqlState
if length(sqlCa) <> 136 then
call err 'sqlCa length' length(sqlCa) 'not 136' ,
'\n'sqlCaMsg() '==>' ca', hex='c2x(ca)
return sqlCa
endProcedure sqlRx2Ca
/*--- extract the fields from the SqlCA and put it to rexx vars ------*/
sqlCA2Rx: procedure expose m. ,
sqlCode sqlErrMc sqlErrP sqlErrD. sqlWarn. sqlState
parse arg ca
numeric digits 10
if length(ca) < 136 | c2d(substr(ca, 9, 4), 4) <> 136 then
call err 'bad sqlCa len' length(ca) 'not 136:' ca', hex='c2x(ca)
sqlCode = c2d(substr(ca, 13 ,4), 4)
sqlErrMC = substr(ca, 19, c2d(substr(ca, 17, 2), 2))
sqlErrP = substr(ca, 89, 8)
do ix=1 to 6
sqlErrD.ix = c2d(substr(ca, 93 + 4 * ix, 4), 4)
end
do ix=0 to 10
sqlWarn.ix = substr(ca, 121 + ix, 1)
end
sqlState = substr(ca, 132, 5)
return sqlCode
endProcedure sqlCA2Rx
/*--- make the text for sqlWarnings ----------------------------------*/
sqlMsgWarn: procedure expose m. sqlWarn.
r = ''
text =' 1=W var truncated, 1=S scrollable, 1=N nonScrollable,' ,
'2=W nulls in aggregate,' ,
'3=W more cols than vars,' ,
'3=Z more result sets than locators,' ,
'4=W no where, 4=D sensitive dynamic, 4=I insensitive,' ,
'4=S sensitive static,' ,
'5=W not valid sql, 5=1 readOnly, 5=2 readDelete,' ,
'5=3 readDeleteUpdate,' ,
'6=W day changed to month range,' ,
'7=W dec digits truncated,' ,
'8=W char substituted,' ,
'9=W arith excep in count, 9=Z multipe result sets,' ,
'10=W char conversion err in ca,'
do wx = 1 to 10
w = sqlWarn.wx
if w = ' ' then
iterate
t = wx'='w
cx = pos(' 'wx'='w' ', text)
ex = pos(',' , text, cx + 1)
if cx > 0 & ex > cx then
r = r substr(text, cx+1, ex-cx)
else
r = r wx'='w '?,'
end
r = strip(r, 't', ',')
if r = '' & sqlwarn.0 <> '' then
call err 'sqlWarn.0='sqlWarn.0 'but all warns empty'
return r
endProcedure sqlMsgWarn
/*--- show in the source src the point pos (where error occured)
a few lines from src around pos and arrow to pos ----------*/
sqlMsgSrcPos: procedure expose m.
parse arg src, pos
liLe = 68
liCn = 3
afLe = 25
t1 = space(left(src, pos), 1)
t2 = left(' ', substr(src, pos, 1) == ' ' ,
| substr(src, pos+1, 1) == ' ') ,
|| space(substr(src, pos+1), 1)
afLe = min(afLe, length(t2))
if length(t1) + afLe > liLe * liCn then
t1 = '...'right(t1, liLe * liCn - afLe -3)
else if length(t1)+length(t2) > liLe then
t1 = left(' ', (liCn * liLe - length(t1) -afLe) // liLe)||t1
pL = length(t1) // liLe
if length(t2) <= liLe-pL then
tx = t1 || t2
else
tx = t1 || left(t2, liLe-pL-3)'...'
res = '\nsrc' strip(substr(tx, 1, liLe), 't')
do cx=1+liLe by liLe to length(tx)
res = res || '\n +' strip(substr(tx, cx, liLe), 't')
end
loc = 'pos' pos 'of' length(src)
if length(loc)+6 < pL then
return res'\n >' right('>>>'loc'>>>', pL)
else
return res'\n >' left('', pL-1)'<<<'loc'<<<'
endProcdedure sqlMsgSrcPos
/*--- get the hostVars in the sql in src and the word before ---------*/
sqlHostVars: procedure expose m.
parse arg src, cnt, st
cx = 1
sx = 1
do cnt
cx = pos(':', src, cx) + 1
if cx < 2 then
leave
if pos(substr(src, cx, 1), m.ut_rxN1) > 0 then
iterate
ex = verify(src, m.ut_rxDot, 'n', cx)
if ex < 1 then
m.st.var.sx = substr(src, cx)
else
m.st.var.sx = substr(src, cx, ex - cx)
if m.st.var.sx == '' | length(m.st.var.sx) > 100 then
iterate
/* search word before */
do bE = cx-2 by -1 to 1 ,
while substr(src, bE, 1) == ' '
end
do bB = bE by -1 to max(1, bE-20),
while pos(substr(src, bB, 1), m.ut_alfa) > 0
end
if bB < bE & bB >= 0 then
m.st.bef.sx = substr(src, bB+1, bE-bB)
else
m.st.bef.sx = ''
sx = sx + 1
end
m.st.0 = sx-1
return sx
endProcedure sqlHostVars
/*--- find the name of hostvar, by index or by before ----------------*/
sqlHostVarFind: procedure expose m.
parse arg st, fnd
if datatype(fnd, 'n') & fnd <= m.st.0 then
return m.st.var.fnd
do ix=1 to m.st.0
if translate(m.st.bef.ix) = fnd then
return m.st.var.ix
end
return ''
endSubroutine sqlHostVarFind
/* copy sqlRx end **************************************************/
/* copy dsnList begin **************************************************
csi interface: see dfs managing catalogs chapt. 11
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & right(dsnMask, 1) \== ' ' ,
& pos('*', dsnMask) < 1 & length(dsnMask) < 42 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = utc2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/*--- mbrList with listDS -----------------------------------------*/
mbrList: procedure expose m.
parse arg m, pds
msk = strip(dsnGetMbr(pds))
if msk == '*' then
msk = ''
parse value dsnCsmSys(dsnSetMbr(pds)) with sys '/' dsn
if sys == '*' then do
call adrTso listDS "'"dsn"'" members
oy = m.tso_trap.0 + 99
mFound = 0
mx = 0
do ox=1 to m.tso_trap.0
if mFound then do
if msk \== '' then
if \ match(strip(m.tso_trap.ox), msk) then
iterate
mx = mx +1
m.m.mx = strip(m.tso_trap.ox)
end
else
mFound = m.tso_trap.ox == '--MEMBERS--'
end
end
else do
if msk <> '' then
msk = 'member('translate(msk, '%', '?')')'
mbr_name.0 = -99
call adrCsm "mbrList system("sys") dataset('"dsn"')" msk ,
"index(' ') short"
do mx=1 to mbr_name.0
m.m.mx = strip(mbr_name.mx)
end
mx = mbr_name.0
end
m.m.0 = mx
return mx
endProcedure mbrList
/* copy dsnList end ************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
/*--- execute a single csmExec command ------------------------------*/
adrCsm:
if wordPos(translate(word(arg(1), 1)), 'COPY MBRLIST') > 0 then
ggTO = ''
else if symbol('m.csm_timeOut') == 'VAR' then
ggTO = 'timeout('m.csm_timeOut')'
else
ggTO = 'timeout(30)'
ggStart = time()
if adrTso('csmExec' arg(1) ggTO, '*') == 0 then
return 0
if pos('CSMXC43E NO CONNECTION TO S', m.tso_trap) > 0 ,
| pos('CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO' ,
, m.tso_trap) > 0 then
/* CSMXC43E NO CONNECTION TO SYSPLEX:RR2 AVAILABLE
CSMXC36E TIMEOUT LIMIT EXCEEDED DURING LOGON TO SYS */
m.csm_err = 'noConn'
else if pos('IKJ56225I', m.tso_trap) > 0 ,
& ( pos('ALREADY IN USE', m.tso_trap) > 0 ,
| pos('CATED TO ANOTH', m.tso_trap) > 0) then
/* 5 IKJ56225I DATA SET A540769.TMP.TEXT ALREADY IN USE,
6 IKJ56225I DATA SET IS ALLOCATED TO ANOTHER JOB */
m.csm_err = 'inUse'
else
m.csm_err = ''
if pos('*', arg(2)) <= 0 & wordPos(m.tso_rc, arg(2)) <= 0 then
call err strip('csmExec' m.csm_err) 'rc='m.tso_rc ,
'\nstmt='subWord(m.tso_stmt, 2) m.tso_trap ,
'\nend of csmExec, time='ggStart '-' time()
return m.tso_rc
endProcedure adrCsm
csmDel: procedure expose m.
parse arg rz, dsn
if dsnGetMbr(dsn) == '' then do
call adrCsm "allocate system("rz") dataset('"dsn"')" ,
"disp(del) ddname(del1)"
call adrTso 'free dd(del1)'
end
else do
rr = adrCsm("mDelete system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)")", 8)
if rr <> 0 then
if pos('CSMEX77E Member:', m.tso_trap) < 1 ,
| pos(' not found', m.tso_trap) < 1 then
call err 'rc='rr 'csm mDelete' rz'/'dsn':'m.tso_trap
end
return
endProcedure csmDel
/*--- copy members / datasets
Vorlage: csrxUtil ----------------------------------------------*/
csmCopy: procedure expose m.
parse arg aFr, aTo, retOk
frDD = tsoDD('csmFr*', 'a')
frMbr = dsnGetMbr(aFr)
if frMbr == '*' then
fr = dsnSetMbr(aFr)
else
fr = aFr
call csmAlloc fr frDD 'shr'
toDD = tsoDD('csmTo*', 'a')
toMbr = dsnGetMbr(aTo)
if toMbr\== '=' then
to = aTo
else
to = dsnSteMbr(aTo, frMbr)
call csmAlloc to toDD 'shr ::D'frDD
if frMbr \== '' & toMbr == '' & m.tso_dsOrg.toDD == 'PO' then do
call adrTso 'free dd('toDD')'
to = dsnSetMbr(aTo, frMbr)
call csmAlloc to toDD 'shr'
end
inDD = tsoDD('csmIn*', 'a')
if frMbr == '' & m.tso_dsOrg.frDD == 'PO' then do
call tsoAlloc '-' inDD 'NEW ::F'
call adrCsm "mbrList ddName("frDD") index(' ') short"
do ix=1 to mbr_mem#
i.ix = ' S M='mbr_name.ix
end
call writeDD inDD, 'I.', mbr_mem#
call tsoCLose inDD
end
else do
call adrTso 'alloc dd('inDD') dummy'
end
outDD = word(dsnAlloc('dd(csmO*) new ::V137'), 1)
cmdu = 'CSMUTIL CSM,COPYREPLACE,DD(,,,,'inDD','outDD ,
|| ',,'frDD','toDD'),MARC(0)'
cRc = adrTso(cmdU, '*')
if cRc <> 0 then do
call readDD outDD, o.
call tsoClose outDD
say 'rc='cRc',' o.0 'outputlines for' cmdU
do ox=1 to o.0
say o.ox
end
end
call tsoFree frDD toDD inDD outDD
if cRc <> 0 then
call err 'csmCopy rc='cRc
return cRc
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
upper dd disp
m.tso_dsn.dd = dsnCsmSys(dsn)
parse var m.tso_dsn.dd sys '/' dsn
if disp = '' then
disp = 'shr'
else if words(disp) = 2 then
disp = word(disp, 2)
a1 = "SYSTEM("sys") DDNAME("dd")"
if dsn == 'INTRDR' then do
a1 = a1 'sysout(T) writer(intRdr)'
end
else do
if dsn <> '' then do
a1 = a1 "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a1 = a1 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a1 = a1 disp
else
a1 = a1 "DISP("disp")"
end
nAtts = wordPos(disp, 'NEW MOD CAT') > 0 & nn \== ''
if nAtts then
rest = dsnCreateAtts('-'dsn , nn) rest
cx = pos(' UCOUNT(', ' 'translate(rest))
if cx > 0 then do
rest = left(rest, cx) || 'nitCnt(' || substr(rest, cx+7)
end
cx = pos(' RECFM(', ' 'translate(rest))
if cx > 0 then do
cy = pos(')', rest, cx)
rest = left(rest, cx+5) || space(substr(rest,cx+6,cy-cx-6), 0) ,
|| substr(rest,cy)
end
cx = pos(' CYLINDERS ', ' 'translate(rest)' ')
if cx > 0 then do
rest = delStr(rest, cx+8, 1)
end
cx = pos(' CYL ', ' 'translate(rest)' ')
if cx > 0 then do
rest = insert('inder', rest, cx+2)
end
if retRc <> '' | nAtts | nn == '' then do
alRc = adrCsm('allocate' a1 rest, retRc)
m.tso_dsorg.dd = subsys_dsOrg
return alRc
end
alRc = adrCsm('allocate' a1 rest, '*')
m.tso_dsorg.dd = subsys_dsOrg
if alRc = 0 then
return 0
say 'csmAlloc rc' alRc 'for' a1 rest '...trying to create'
call csmAlloc m.tso_dsn.dd dd 'CAT' rest ':'nn
call adrTso 'free dd('dd')'
return adrCsm('allocate' a1 rest)
endProcedure csmAlloc
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure dsnCsmSys
csmLikeAtts: procedure expose m.
parse upper arg rz '/' dsn
lc = adrCsm('dslist system('rz') dsnMask('dsnSetMbr(dsn)')')
if stemsize <> 1 then
call err 'csmLikeAtts stemSize='stemsize 'for dsn='dsn
if abbrev(dsOrg.1, 'PO') then
r = 'dsorg(po) dsnType(library)'
else if abbrev(dsOrg.1, 'PS-') then
r = 'dsorg(PS)'
else
r = 'dsorg('dsOrg.1')'
r = r 'mgmtClas('mgmtClas.1')' ,
/* 'dataClas('dataClas.1')' */ ,
'recFM('strip(translate('1 2 3', recFm.1, '123'))')' ,
'lRecl('lRecl.1')' ,
'space('tracksused.1',' tracks.1') tracks'
/* if \ datatype(tracksused.1, 'n') then do
if \ datatype(tracks.1, 'n') then
r = r 'space('tracks.1',' tracks.1')'
if \ datatype(tracks.1, 'n') then
tracks.1 = tracksUsed.1 */
return r
endProcedure csmLikeAtts
/*--- execute a rexx (under tso) in another rz
here we use rexx TPSYSIKJ which was written for
jcl procedure RM@IKJ01
arguments
rz which rz to run rexx
proc the (remote) procedure library to use
opt options
cmd the tso command to execute
----------------------------------------------------------------------*/
/*--- execute a rexx (under tso) in another rz
directly (without TPSYSIKJ) --------------------------------*/
csmExRx: procedure expose m.
parse arg rz, proc, opt, cmd
pStem = opt
if pStem = '' then
pStem ='CSMEXRX' /* split tso cmd in linews */
do cx=1 to (length(cmd)-1) % 68
cmd.cx = substr(cmd, 68*cx-67,68)'-'
end
cmd.cx = substr(cmd, 68*cx-67)
cmd.0 = cx
if 0 then do
call adrTso 'free ed(rmtSys)' ,'*'
call tsoFree tsoDD(rmtsPrt, 'a')
call adrTso 'free dd(rmtsIn)','*'
call adrTso 'free dd(sysproc)' ,'*'
end
/* alloc necessary dd */
call dsnAlloc rz"/"proc "dd(rmSyPro) rmtDDn(sysProc)"
call dsnAlloc rz"/tmp.tsin new dd(rmTsIn) rmtDdn(sysTsIn) ::f "
call tsoOpen rmTsIn, 'w' /* write tso cmd */
call writeDD rmTsIn, cmd.
call tsoClose rmtsin
call dsnAlloc rz"/tmp.prt new dd(rmtsprt) rmtDdn(sysTsPrt)",
"::f133"
call dsnAlloc rz"/tmp.rmt new dd(rmtSys)"
/* now, run tso remote */
call adrtso "csmappc start pgm(csmexec)" ,
"parm('select tsocmd(''csmappc allocate plu(*.rmtSys)" ,
"tpname(sysikj) dealloc '')')", '*'
if rc <> 0 | appc_rc <> 0 then do /* handle csm error */
ee = 'csm tso exec rc='rc 'appc_rc='appc_rc
say ee
say ' rexx rz='rz 'proc='proc 'opt='opt
say ' cmd='cmd
call csmappcRcSay ggTsoCmd
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
say m.pStem.0 'tso output lines'
do px=1 to m.pStem.0
say ' ' strip(m.pStem.px, 't')
end
call err ee
end
if opt <> '' then do /* copy output to stem */
call readDD 'rmTsPrt', 'M.'pStem'.'
call tsoClose rmtsPrt
end
call tsoFree rmSyPro rmtsPrt rmtSys rmtsIn
return
endProcedure csmExRx
/*--- sys the re and result variables from csmAppcRc -----------------*/
csmappcRcSay: procedure expose appc_rc appc_reason appc_msg. ,
appc_state_c appc_state_f
parse arg cmd
say 'rc='appc_rc 'reason='appc_reason ,
'state_c='appc_state_c appc_state_f
say ' for' cmd
do ix=1 to appc_msg.0
say ' ' appc_msg.ix
end
return appc_rc
endProcedure csmappcRcSay
/*--- execute a single csmAppc command ------------------------------*/
csmAppc:
return adrTso('csmAppc' arg(1), arg(2))
endProcedure csmAppc
/* copy csm end *******************************************************/
/* copy timing begin *************************************************/
timing: procedure expose m.
parse arg typ, c2, txt
e1 = time('E')
c1 = strip(sysvar('syscpu'))
s1 = sysvar('syssrv')
if typ == '' then
return strip(f('%c ela=%5i cpu=%8.3i su=%9i' ,
, time(), e1, c1, s1) txt)
if symbol('m.timing_ela') \== 'VAR' then
call err 'timing('typ',' c2',' txt') ohne ini'
if symbol('m.timing.typ.ela') \== 'VAR' then do
m.timing.typ.ela = 0
m.timing.typ.cpu = 0
m.timing.typ.su = 0
m.timing.typ.cnt = 0
m.timing.typ.cn2 = 0
if symbol('m.timing_types') == 'VAR' then
m.timing_types = m.timing_types typ
else
m.timing_types = typ
if symbol('m.timing_say') \== 'VAR' then
m.timing_say = 0
end
m.timing.typ.ela = m.timing.typ.ela + e1 - m.timing_ela
m.timing.typ.cpu = m.timing.typ.cpu + c1 - m.timing_cpu
m.timing.typ.su = m.timing.typ.su + s1 - m.timing_su
m.timing.typ.cnt = m.timing.typ.cnt + 1
if c2 \== '' then
m.timing.typ.cn2 = m.timing.typ.cn2 + c2
m.timing_ela = e1
m.timing_cpu = c1
m.timing_su = s1
if m.timing_say then
say left(typ, 10)right(m.timing.typ.cn2, 10) ,
'ela='m.timing.typ.ela ,
'cpu='m.timing.typ.cpu 'su='m.timing.typ.su txt
return
endProcedure timing
timingSummary: procedure expose m.
say 'timing summary' time()
do tx = 1 to words(m.timing_types)
typ = word(m.timing_types, tx)
say left(typ, 10)right(m.timing.typ.cnt, 7) ,
|| right(m.timing.typ.cn2, 7) ,
'cpu='right(m.timing.typ.cpu, 10) ,
'su='right(m.timing.typ.su, 10)
end
return
endProcedure timingSummary
/* copy timing end *************************************************/
/* copy ii begin ********* Installation Info *************************/
iiini: procedure expose m.
if m.ii_ini == 1 then
return
m.ii_ini = 1
m.ii_ds.org = ORG.U0009.B0106.KLEM43
m.ii_ds.db2 = DSN.DB2
m.ii_rz = ''
i = 'RZ0 0 T S0 RZ1 1 A S1' ,
'RZX X X X2 RZY Y Y Y2 RZZ Z Z Z2' ,
'RQ2 Q Q Q2 RR2 R R R2 RZ2 2 B S2 RZ4 4 D S4'
do while i <> ''
parse var i rz ch pl sys i
if rz <> RZ0 & rz <> RZ1 then
m.ii_rz = strip(m.ii_rz rz)
m.ii_rz2c.rz = ch
m.ii_c2rz.ch = rz
m.ii_rz2plex.rz = pl
m.ii_plex2rz.pl = rz
m.ii_rz2Sys.rz = sys
m.ii_sys2rz.sys = rz
end
i = 'DBTF T DTF DVTB V DTB DBOC C DOC DBTC B DBT DBIA A DIA' ,
'DE0G E DE0 DEVG M DEV DPXG I DPX DX0G X DX0' ,
'DPYG Y DPY DPZG N DPZ' ,
'DBOF F DOF DVBP P DBP DP2G Q DP2 DBOL O DOL DP4G U DP4'
do while i <> ''
parse var i db ch mbr i
m.ii_db2c.db = ch
m.ii_c2db.ch = db
m.ii_mbr2db.mbr = db
m.ii_db2mbr.db = mbr
m.ii_db2Elar.db = wordPos(db, 'DVTB DVBP DEVG') > 0
end
m.ii_rz2db.rz0 = 'DBTC DBIA'
m.ii_rz2db.rz1 = 'DBTF DVTB DBOC'
m.ii_rz2db.rzx = 'DE0G DEVG DX0G DPXG'
m.ii_rz2db.rzy = 'DE0G DEVG DPYG'
m.ii_rz2db.rzz = 'DE0G DEVG DPZG'
m.ii_rz2db.rq2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rr2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz2 = 'DBOF DVBP DP2G'
m.ii_rz2db.rz4 = 'DBOL DP4G'
i = ''
do rx=1 to words(m.ii_rz)
rz = word(m.ii_rz, rx)
i = i repAll(' 'space(m.ii_rz2db.rz, 1), ' ', ' 'rz'/')
end
m.ii_rzDb = space(i, 1)
return
endProcedure iiIni
iiDS: procedure expose m.
parse arg nm
return iiGet(ds, nm)
iiMbr2DbSys: procedure expose m.
parse arg mbr
return iiGet(mbr2db, left(mbr, 3))
iiRz2C: procedure expose m.
parse arg rz
return iiGet(rz2c, rz)
iiRz2P: procedure expose m.
parse arg rz
return iiGet(rz2plex, rz)
iiRz2Dsn: procedure expose m.
parse arg rz
return overlay('Z', rz, 2)
iiDBSys2C: procedure expose m.
parse arg db
return iiGet(db2c, db)
iiSys2RZ: procedure expose m.
parse arg sys
return iiGet(sys2rz, left(sys, 2))
iiGet: procedure expose m.
parse upper arg st, key, ret
s2 = 'II_'st
if symbol('m.s2.key') == 'VAR' then
return m.s2.key
if m.ii_ini == 1 then
if abbrev(ret, '^') then
return substr(ret, 2)
else
return err('no key='key 'in II_'st, ret)
call iiIni
return iiGet(st, key, ret)
endProcedure iiGet
iiVPut:procedure expose m.
parse upper arg rz '/' db .
call vPut 'rz', rz
call vPut 'rzC', iiRz2C(rz)
call vPut 'rzP', iiRz2P(rz)
call vPut 'rzD', iiRz2Dsn(rz)
call vPut 'dbSys', db
call vPut 'dbSysC', iidbSys2C(db)
call vPut 'dbSysElar', iiGet(db2Elar, db)
return 1
endProcedure iiVPut
iiIxVPut:procedure expose m.
parse arg ix
if ix > words(m.ii_rzDb) then
return 0
else
return iiVPut(word(m.ii_rzDb, ix))
endProcedure iiIxVPut
/* copy ii end ********* Installation Info *************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call tsoOpen grp, 'R'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt, withVolume
if \ readDD(ggGrp, ggSt) then
return 0
if withVolume \== 1 then
do ggIx=1 to value(ggSt'0')
x = value(ggSt || ggIx, word(value(ggSt || ggIx), 1))
end
return 1
endSubroutin lmdNext
lmdEnd: procedure expose m.
parse arg grp
call tsoClose grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg m.tso_stmt, ggRet
call outtrap m.tso_trap.
address tso m.tso_stmt
m.tso_rc = rc
call outtrap off
if m.tso_rc == 0 then
return 0
m.tso_trap = ''
do ggXx=1 to min(7, m.tso_trap.0)
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
if m.tso_trap.0 > 7 then do
if m.tso_trap.0 > 14 then
m.tso_trap = m.tso_trap'\n............'
do ggXx=max(8, m.tso_trap.0-6) to m.tso_trap.0
m.tso_trap = m.tso_trap'\n'strip(m.tso_trap.ggXx)
end
end
if ggRet <> '*' & wordPos(m.tso_rc, ggRet) <= 0 then
call err 'adrTso rc=' m.tso_rc 'stmt='m.tso_stmt m.tso_trap
return m.tso_rc
endSubroutine adrTso
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg lib '(' . , mbr .
bx = pos('(', dsn)
if mbr = '' then
return strip(lib)
else
return strip(lib)'('mbr')'
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn '(' mbr ')'
if mbr = '' then
return arg(2)
else
return strip(mbr)
endProcedure dsnGetMbr
dsnCsmSys: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure dsnCsmSys
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: tsoOpen...'R', readDD*, tsoClose
write: tsoOpen...'W', writeDD*, tsoClose
readDD returns true if data read, false at eof
do not forget that open is mandatory to write empty file|
***********************************************************************/
/*--- open dd for read (rw='R') or write (rw='W') --------------------*/
tsoOpen: procedure expose m.
parse upper arg dd, rw
return adrTso('execio' 0 'disk'RW dd '(open)')
return /* end tsoOpen */
/*--- close dd -----------------------------------------------------*/
tsoClose: procedure expose m.
parse upper arg dd
return adrTso('execio 0 diskR' dd '(finis)')
endProcedure tsoClose
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskR' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt, ggRet
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskW' ggDD '(stem' ggSt')', ggRet
return
endSubroutine writeDD
/*--- readNx: read next line, using buffer ---------------------------*/
/*--- begin: allocate dsnSpec and ini ------------------------ -------*/
readNxBegin: procedure expose m.
parse arg m, m.m.dsn, m.m.dd, m.m.Cnt
if m.m.dd = '' then
m.m.dd = 'DDNX*'
if m.m.cnt = '' then
m.m.cnt = 1000
m.m.cx = m.m.cnt + 999
m.m.buf0x = 0
m.m.0 = 0
parse value dsnAlloc('dd('m.m.dd')' m.m.dsn) with m.m.dd m.m.free
call tsoOpen m.m.dd, 'R'
return m
endProcedure readNxBegin
/*--- return the stem of the next line, or '' at end -----------------*/
readNx: procedure expose m.
parse arg m
if m.m.cx < m.m.0 then do
m.m.cx = m.m.cx + 1
return m'.'m.m.cx
end
m.m.buf0x = m.m.buf0x + m.m.0
m.m.cx = 1
if \ readDD(m.m.dd, 'M.'m'.', m.m.cnt) then
return ''
return m'.1'
endProcedure readNx
/*--- return the stem of the curr line, '' at end --------------------*/
readNxCur: procedure expose m.
parse arg m
if m.m.cx <= m.m.0 then
return m'.'m.m.cx
else
return ''
endProcedure readNxCur
/*--- return the position (line number) of reader
plus le characters of the current line (default 50) ------*/
readNxPos: procedure expose m.
parse arg m, le
if m.m.cx > m.m.0 then
return 'line' (m.m.buf0x + m.m.cx)':after EOF'
li = m'.'m.m.cx
li = strip(m.li, 't')
if arg() < 2 then
le = 50
if le < 1 then
li = ''
else if length(li) <= le then
li = ':' li
else
li = ':' left(li, le-3)'...'
return 'line' (m.m.buf0x + m.m.cx)li
endProcedure readnxPos
/*--- close and deallocate ------------------------------------------*/
readNxEnd: procedure expose m.
parse arg m
call tsoClose m.m.dd
call tsoFree m.m.free
return
endProcedure readNxEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w == 'CATALOG' | w == 'CAT' then
di = di 'CAT'
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if pos('(', w) > 0 then
leave
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.tso_trap.1 = ''
m.tso_trap.2 = ''
m.tso_trap.3 = ''
res = dsnAlloc(spec, pDi, pDD, '*')
if \ datatype(res, 'n') then
return res
msg = m.tso_trap.1'\n'm.tso_trap.2'\n'm.tso_trap.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then
dd = 'DD*'
dd = tsoDD(dd, 'a')
m.tso_dsn.dd = ''
if na == '-' & di == '-' & rest = '' then
return dd
if di = '-' then
if pDi == '' then
di = 'SHR'
else
di = pDi
if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if lastPos('/', na, 6) > 0 then
rx = csmAlloc(na dd di rest, retRc)
else
rx = tsoAlloc(na dd di rest, retRc)
if rx = 0 then
return dd dd
else
return rx
endProcedure dsnAlloc
/*--- find a free dd with prefix dd ----------------------------------*/
tsoDD: procedure expose m.
parse upper arg dd, f, noErr
if symbol('m.tso_ddAll') \== 'VAR' then do
call errIni
m.tso_ddAll = ''
end
if f == '-' then do
ax = wordPos(dd, m.tso_ddAll)
if ax > 0 then
m.tso_ddAll = delWord(m.tso_ddAll, ax, 1)
else if noErr \== 1 then
call err 'tsoDD dd' dd 'not used' m.tso_ddAll
end
else if f <> 'A' then
call err 'tsoDD bad fun' f
else do
if right(dd, 1) = '*' then do
d0 = left(dd, length(dd)-1) || m.err.screen
dd = d0
do dx=1 while wordPos(dd, m.tso_ddAll) > 0
dd = d0 || dx
end
end
else if pos('?', dd) > 0 then
dd = repAll(dd, '?', m.err.screen)
if wordPos(dd, m.tso_ddAll) < 1 then
m.tso_ddAll = strip(m.tso_ddAll dd)
m.tso_dsn.dd = ''
m.tso_dsOrg.dd = ''
end
return dd
endProcedure tsoDD
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
dd = translate(dd)
c = 'alloc dd('dd')' disp
if na == '-' then
m.tso_dsn.dd = ''
else if na \== 'INTRDR' then do
c = c "DSN('"na"')"
m.tso_dsn.dd = na
end
else do
c = c "sysout(*) writer(intRdr)"
m.tso_dsn.dd = '*intRdr'
end
if wordPos(disp, 'NEW MOD') > 0 & nn \== '' then
c = c dsnCreateAtts(,nn)
if adrTso(c rest, '*') = 0 then
return 0
if pos('IKJ56246I', m.tso_trap) > 0 then
if pos('TED, FILE IN USE', m.tso_trap) > 0 then do
/* IKJ56246I DATA SET A540769.WK.REXX NOT ALLOCATED, FILE IN USE */
say 'tsoAlloc dd' dd 'already in use:' substr(m.tso_trap, 3)
say '.... trying to free'
call tsoFree dd, 1
say '.... retrying to allocate' c rest
if adrTso(c rest, '*') = 0 then
return 0
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& pos('IKJ56228I', m.tso_trap) > 0 ,
& pos(' NOT IN CATALOG ', m.tso_trap) > 0 then do
/* IKJ56228I DATA SET A540769.XY.REXX NOT IN CATALOG OR CATAL*/
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
if pos('*', retRc) < 1 & wordPos(m.tso_rc, retRc) < 1 then
call err 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
call sayNl 'tsoAlloc rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
return m.tso_rc
endProcedure tsoAlloc
dsnExists: procedure expose m.
parse upper arg aDsn
parse value dsnCsmSys(aDsn) with rz '/' dsn
if rz == '*' then
return sysDsn("'"dsn"'") == 'OK'
else if dsnGetMbr(dsn) == '' then do
lc = adrCsm('dslist system('rz') dsnMask('dsn') short', 4)
if stemsize = 0 | stemSize = 1 then
return stemSize
call err 'csmExists stemSize='stemsize 'for dsn='aDsn
end
else do
cc = adrCsm("mbrList system("rz") dataset('"dsnSetMbr(dsn)"')",
"member("dsnGetMbr(dsn)") index(' ') short", 8)
if cc <> 0 then do
if pos(' NOT IN CATALOG\', m.tso_trap) > 0 ,
& pos('CSMSV29E DATA SET ', m.tso_trap) > 0 then
return 0
return err('error in csm mbrList' aDsn m.tso_trap)
end
if mbr_name.0 == 0 | mbr_name.0 == 1 then
return mbr_name.0
call err 'csmExists mbr_mem#='mbr_name.0 'for dsn='aDsn
end
endProcedure dsnExists
dsnLikeAtts: procedure expose m.
parse upper arg dsn, isFile
if isFile then do
ddDsn = m.tso_dsn.dsn
if lastPos('/', m.tso_dsn.dsn, 4) < 1 then
return tsoLikeAtts(dsn, 1)
dsn = m.tso_dsn.dsn
end
sx = lastPos('/', dsn, 4)
if sx < 1 then
return tsoLikeAtts(dsn, 0)
else if abbrev(dsn, '*/') | abbrev(dsn, sysVar('SYSNODE')'/') then
return tsoLikeAtts(substr(dsn, sx+1), 0)
else
return csmLikeAtts(dsn)
endProcedure dsnLikeAtts
tsoLikeAtts: procedure expose m.
parse arg dsn, isFile
rc = listDsi("'"dsn"'" copies('FILE', isFile) "SMSINFO")
if rc = 0 then
r = ''
else if rc = 4 & sysReason = 19 then do
r = 'UCOUNT(30)' /* 7.8.13 corrected attribute */
say 'creating' dsn 'with multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
if right(sysDsSms, 7) == 'LIBRARY' | abbrev(sysDsSms, 'PDS') ,
| sysDsOrg = 'PO' then
r = 'dsOrg(PO) DSNTYPE(LIBRARY)' r
else
r = "dsOrg("sysDSorg")" r
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
return r "MGMTCLAS("sysMgmtClass")",
"DATACLAS("sysDataClass")" ,
"RECFM("strip(translate('1 2 3', ' 'sysREcFM, '123'))")",
"LRECL("SYSLRECL")",
"SPACE("sysPrimary"," sysSeconds")" ,
sysUnits || left('S', sysUnits == 'TRACK')
/* "blksize("sysBLkSIZE")" removed 3.4.13: let sms do the magic */
endProcedure tsoLikeAtts
tsoFree: procedure expose m.
parse arg ddList, tryClose
do dx=1 to words(ddList)
dd = word(ddList, dx)
if adrTso('free dd('dd')', '*') <> 0 then do
if pos('IKJ56861I', m.tso_trap) > 0 & tryClose == 1 then
if pos('NOT FREED, DATA SET IS OPEN', m.tso_trap),
> 0 then do
/* IKJ56861I FILE A1 NOT FREED, DATA SET IS OPEN */
say 'dataset open:' substr(m.tso_trap, 3)
say '.... trying to close'
if adrTso('execio 0 diskR' dd '(finis)', '*') = 0 then
call adrTso 'free dd('dd')', '*'
end
if m.tso_rc \== 0 then
call sayNl 'rc='m.tso_rc 'tsoStmt='m.tso_stmt m.tso_trap
end
call tsoDD dd, '-', 1
end
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts
res = ''
if dsn \== '' & \ abbrev(dsn, '-') then
res = "dataset('"dsnSetMbr(dsn)"')"
if abbrev(atts, ':') then do
parse var atts a1 atts
rl = substr(a1, 3)
if abbrev(a1, ':F') then do
if rl = '' then
rl = 80
res = res "recfm("space(f b)") lrecl("rl")"
end
else if abbrev(a1, ':V') then do
if rl = '' then
rl = 32756
res = res "recfm("space(v b)") lrecl("rl")"
end
else if abbrev(a1, ':L') then
res = res dsnLikeAtts(rl, 0)
else if abbrev(a1, ':D') then
res = res dsnLikeAtts(rl, 1)
else
call err 'csnCreateAtt 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
/*--- check if a dataset is archive ------------------------------------
returns 'ok' if dataset on disk
'not' if dataset is not catalogued
'arc' if dataset archived
listDsi errorMsg otherwise ------------------*/
dsnArc: procedure expose m.
parse upper arg dsn
lc = listDsi("'"strip(dsn)"' noRecall")
if lc = 0 then
return 'ok'
else if lc=4 & sysReason = 19 then /* multiple volumes */
return 'ok'
else if lc=16 & sysReason = 5 then
return 'notCat'
else if lc=16 & sysReason = 9 then
return 'arc'
else
return 'listDsi cc='lc', sysReason='sysReason ,
'm2='sysMsgLvl2', m1='sysMsgLvl1
endProcedure dsnArc
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
call tsoFree word(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
call tsoFree word(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
parse value dsnAlloc(frSpec, 'SHR', 'FRDD') with frDD frFr
parse value dsnAlloc(toSpec, 'OLD', 'TODD') with toDD toFr
call tsoOpen frDD, 'R'
call tsoOpen toDD, 'W'
cnt = 0
do while readDD(frDD, r.)
call writeDD toDD, r.
cnt = cnt + r.0
end
call tsoClose frDD
call tsoClose toDD
call tsoFree frFr toFr
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
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 csv begin *****************************************************/
csvIni: procedure expose m.
if m.csv.ini == 1 then
return
m.csv.ini = 1
call jIni
call classNew "n CsvRdr u JRW, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvRdrOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvRdr'"
call classNew "n CsvRdrR u CsvRdr", "m",
, "jRead return csvRdrRead(m)"
call classNew "n CsvWrt u JRW, f RDR r", "m",
, "jReset m.m.rdr = arg",
, "jOpen call csvWrtOpen m, opt",
, "jClose call jClose m.m.rdr; call oMutatName m, 'CsvWrt'"
call classNew "n CsvWrtR u CsvWrt", "m",
, "jRead return csvWrtRead(m)"
return
endProcedure csvIni
/*--- create a new csvRdr --------------------------------------------*/
csvRdr: procedure expose m.
parse arg rdr
return jReset(oNew('CsvRdr'), rdr)
endProcedure csvRdr
/*--- open csvRdr: read first line and create dataClass --------------*/
csvRdrOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
mr = m.m.rdr
/* do until m.mr <> '' ?????????
if \ jRead(mr) then
return 0
else if abbrev(m.mr, '**') then do
say '???' m.mr
m.mr = ''
end
end */
if jRead(mr) then do
ff = 'f' repAll(m.mr, ',', ' v, f ') 'v'
m.m.class = classNew("n* CsvF u" ff)
end
call oMutatName m, 'CsvRdrR'
return
endProcedure csvRdrOpen
/*--- read next line and return derived object -----------------------*/
csvRdrRead: procedure expose m.
parse arg m
mr = m.m.rdr
do until m.mr <> ''
if \ jRead(mr) then
return 0
/* else if abbrev(m.mr, '**') then do
say '???' m.mr
m.mr = ''
end */
end
var = oNew(m.m.class)
ff = classMet(m.m.class, 'oFlds')
s = m'.SCAN'
call scanSrc s, m.mr
do fx=1
f1 = m.ff.fx
if scanString(s, '"') then
m.var.f1 = m.s.val
else do
call scanUntil s, ','
m.var.f1 = m.s.tok
end
if scanEnd(s) then
leave
if \ scanLit(s, ',') then
call scanErr s, ',' expected
end
if fx <> m.ff.0 then
call scanerr s, 'csv cla' m.ff.0 'fields but' cx 'in line'
m.m = var
return 1
endProcedure csvRdrRead
/*--- create a new csvRdr --------------------------------------------*/
csvWrt: procedure expose m.
parse arg rdr
return jReset(oNew('CsvWrt'), rdr)
endProcedure csvWrt
/*--- open csvRdr: read first line and create dataClass --------------*/
csvWrtOpen: procedure expose m.
parse arg m
call jOpen m.m.rdr, '<'
m.m.class = ''
m.m.o1 = ''
call oMutatName m, 'CsvWrtR'
return
endProcedure csvWrtOpen
/*--- read next line and return derived object -----------------------*/
csvWrtRead: procedure expose m.
parse arg m
mr = m.m.rdr
if m.m.o1 \== '' then do
i1 = m.m.o1
m.m.o1 = ''
end
else if jRead(mr) then
i1 = m.mr
else
return 0
if m.m.class == '' then do
m.m.class = objClass(i1)
m.m.o1 = i1
t = ''
ff = oFlds(i1)
do fx=1 to m.ff.0
t = t','m.ff.fx
end
m.m = substr(t, 2)
return 1
end
else do
m.m = csv4Obj(i1, oFlds(i1), 0)
return 1
end
endProcedure csvWrtRead
csv4obj: procedure expose m.
parse arg o, ff, hasNull, oNull
res = ''
do fx=1 to m.ff.0
of1 = o || left('.', m.ff.fx \== '') || m.ff.fx
v1 = m.of1
if hasNull & v1 = oNull then
res = res','
else if v1 = '' then
res = res',""'
else if pos(',', v1) > 0 | pos('"', v1) > 0 then
res = res','quote(v1, '"')
else
res = res','v1
end
return substr(res, 2)
endProcedure csv4obj
/* copy csv end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m
if arg() > 1 then
return err('??? old interface') / 0
if m.m.jReading \== 1 then
return err('jRead('m') but not opened r')
ix = m.m.readIx + 1
if ix > m.m.buf.0 then do
m.m.bufI0 = m.m.bufI0 + m.m.buf.0
m.m.readIx = 0
interpret objMet(m, 'jRead')
ix = 1
if m.m.buf.0 < ix then
return err('jRead but no lines') / 0
end
m.m.readIx = ix
m.m = m.m.buf.ix
return 1
endProcedure jRead
jReadVar: procedure expose m.
parse arg m, var
if arg() > 2 then call err '??? old interface' / 0
if \ jRead(m) then
return 0
m.var = m.m
return 1
endProcedure jReadVar
jReadObRe: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' / 0
if jRead(m) then
return m.m
else
return ''
endProcedure jReadObRe
jReadO: procedure expose m.
parse arg m
if arg() > 1 then call err '??? old interface' /0
return jRead(m)
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
ix = m.m.buf.0 + 1
m.m.buf.0 = ix
m.m.buf.ix = line
if ix > m.m.bufMax then
interpret objMet(m, 'jWrite')
return
endProcedure jWrite
jPosBefore: procedure expose m.
parse arg m, lx
interpret objMet(m, 'jPosBefore')
return m
endProcedure jPosBefore
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
met = objMet(m, 'jWriteAll')
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret met
return
endProcedure jWriteAll
jWriteNow: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
interpret objMet(m, 'jWriteNow')
return
endProcedure jWriteNow
jCat: procedure expose m.
parse arg opt m
if m = '' then do
m = opt
opt = m.j.cWri
end
call jOpen m, opt
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
call jOpen rdr, m.j.cRead
do while jRead(rdr)
call jWrite m, m.rdr
end
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset0: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')')
m.m.jReading = 0
m.m.jWriting = 0
m.m.jUsers = 0
m.m.buf.0 = 0
m.m.bufMax = 0
return m
endProcedure jReset
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
call jReset0 m, arg, arg2, arg3
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpen: procedure expose m.
parse arg m, opt
met = objMet(m, 'jOpen')
oUsers = m.m.jUsers
if opt = m.j.cRead then do
if m.m.jReading then
nop
else if m.m.jWriting then
return err('already opened for writing jOpen('m',' opt')')
else do
m.m.readIx = 0
m.m.bufI0 = 0
interpret met
m.m.jReading = 1
end
end
else if \ abbrev('>>', opt, 1) then do
return err('bad option' opt 'in jOpen('m',' opt')')
end
else do
if m.m.jWriting then
nop
else if m.m.jReading then
return err('already opened for reading jOpen('m',' opt')')
else do
m.m.bufI0 = 0
interpret met
m.m.jWriting = 1
end
end
m.m.jUsers = oUsers + 1
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
met = objMet(m, 'jClose')
oUsers = m.m.jUsers
if oUsers = 1 then do
interpret met
m.m.jReading = 0
m.m.jWriting = 0
end
else if oUsers < 1 then
call err 'jClose' m 'but already closed' / ???????
m.m.jUsers = oUsers - 1
return m
endProcedure jClose
/*--- cat the lines of the file together, with mid between lines,
fail if not all lines are strings -------------------*/
jCatLines: procedure expose m.
parse arg m, fmt
if abbrev(fmt, '-sql') then do
call err '-sql in jCatLines'
end
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
call jOpen m, m.j.cRead
if \ jRead(m) then do
call jClose m
return f(f2'%##e')
end
res = f(f2'%##a', m.m)
do while jRead(m)
res = res || f(f2, m.m)
end
call jClose m
return res
endProcedure jCatLines
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 oIni
am = "call err 'call of abstract method"
c1 = classNew('n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new ?r m = jReset0(?new2); ?jReset; return m" ,
, "jReset" ,
, "jRead" am "jRead('m')'" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, fmt)",
, "o2File return m")
c2 = classNew('n JRWDeleg u JRW', 'm',
, "new ?r return jReset(?new1, arg)",
, "jRead md = m.m.deleg; if \ jRead(md) then return 0;" ,
"m.m = m.md; return 1",
, "jWrite call jWrite(m.m.deleg, line)" ,
, "jWriteAll call jWriteAll m.m.deleg, rdr",
, "jWriteNow call jWriteNow m.m.deleg, rdr",
, "jReset if arg \== '' then m.m.deleg = arg;",
"else call jReset m.m.deleg;",
, "jOpen call jOpen m.m.deleg,' opt; return m" ,
, "jClose call jClose m.m.deleg; return m" )
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JSay u JRW', 'm',
, jWrite1Met(" say o2Text(m.var, 157)"),
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JSay#jOpen('m',' opt')';"
call classNew 'n JRWEof u JRW', 'm',
, "jRead return 0",
, "jOpen if opt \== '<' then call err 'JRWEof#open('m',' opt')'"
m.j.in = jOpen(oNew('JRWEof'), m.j.cRead)
m.j.out = jOpen(oNew('JSay'), '>')
m.j.errRead = "return err('jRead('m') but not opened r')"
m.j.errWrite = "return err('jWrite('m',' line') but not opened w')"
call classNew "n JBuf u JRW, f BUF s r", "m",
, "jOpen call jBufOpen m, opt",
, "jClose" ,
, "jRead return 0",
, "jWrite call err 'buf overflow",
, "jPosBefore m.m.readIx = m.m.readIx+0;m.m.readIx = lx-1"
call classNew "n JbufText u JBuf, f MAXL v ", "m",
, "jReset call jBufReset m, arg; m.m.maxl = word(arg 80, 1)",
, "jWrite call jBufWrite m, o2Text(line, m.m.maxl)"
return
endProcedure jIni
/*--- return a JRW from rdr or in ------------------------------------*/
in2File: procedure expose m.
parse arg m
interpret objMet(m, 'in2File')
return err('in2File did not return')
endProcedure in2File
/* jstr is part of out interface --> in2Str */
in2Str: procedure expose m.
parse arg m, fmt
interpret objMet(m, 'in2Str')
return err('in2Str did not return')
endProcedure in2Str
in2Buf: procedure expose m.
parse arg m
interpret objMet(m, 'in2Buf')
return err('in2Buf did not return')
endProcedure in2Buf
in: procedure expose m.
if arg() > 0 then call err '??? old interface'
r = m.j.in
m.in_ret = jRead(r)
m.in = m.r
return m.in_ret
endProcedure in
inVar: procedure expose m.
parse arg var
return jReadVar(m.j.in, var)
endProcedure inVar
inObRe: procedure expose m.
if arg() > 0 then call err '??? old interface'
return jReadObRe(m.j.in)
endProcedure inObRe
inO: procedure expose m.
if arg() > 0 then call err '??? old interface'
return in()
endProcedure inO
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
/*--- out (part of) the lines of a stem ----------------------------*/
outSt: procedure expose m.
parse arg st, fx, tx
do lx=word(fx 1, 1) to word(tx m.st.0, 1)
call out m.st.lx
end
return st
endProcedure outSt
outX: procedure expose m.
parse arg line
if symbol('m.tst_m') \== 'VAR' then
call jWrite m.j.out, line
else
call tstOut m.tst_m, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call out arg
return
endProcedure outO
JRWDeleg: procedure expose m.
parse arg arg
return oNew('JRWDeleg', arg)
endProcedure JRWDeleg
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
/*--- jBufText: write text descriptions -----------------------------*/
jbufText: procedure expose m.
m = oNew('JbufText') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = o2text(arg(ax))
end
m.m.buf.0 = ax-1
return m
endProcedure jbufText
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
return m
end
m.m.bufMax = 1e30
if opt == m.j.cWri then do
m.m.buf.0 = 0
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
return m
endProcedure jBufOpen
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
m.m.buf.0 = ax
return m
endProcedure jBufWriteStem
jBufCopy:
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, rdr
return jClose(b)
endProcedure jBufCopy
jSingle: procedure expose m.
parse arg m
call jOpen m, '<'
one = jRead(m)
two = jRead(m)
call jClose m
if \ one then
if arg() < 2 then
call err 'empty file in jSingle('m')'
else
return arg(2)
if two then
call err '2 or more recs in jSingle('m')'
return m.m
endProcedure jSingle
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object is register for a class in o2c
a class has a list of parents in cParent
a class has a methodTable cMet with lazy initialization
a method generator
otherwise an existing method is simply copied
***********************************************************************/
oIni: procedure expose m.
if m.o_ini == 1 then
return
m.o_ini = 1
call classIni
call classNew 'n= root u', 'm',
, "new ?l" ,
, "new1 ?l" ,
, "new2 ?l" ,
, "oClear ?l" ,
, "oCopy ?l"
return
endProcedure oIni
oMetLazy: procedure expose m.
parse arg cl, met, trg rest
if met == 'new' then
return 'return' classMet(cl, 'new2')
if met == 'new1' then do
call mNewArea cl, 'O.'substr(cl,7)
return "oMutate(mNew('"cl"'), '"cl"')"
end
if met == 'new2' then do
call classMet cl, 'oClear'
return "classClear('"cl"'," classMet(cl, 'new1')")"
end
if met == 'oFlds' then do
m.cl.flds.0 = 0
m.cl.flds_self = 0
m.cl.stms.0 = 0
m.cl.stms_self = 0
call classFldAdd cl, cl
return cl'.FLDS'
end
call classMet cl, 'oFlds'
if wordPos(met, 'f2c f2x stms s2c') > 0 then do
if met == 'f2x' then
call mInverse cl'.FLDS', cl'.F2X'
return cl'.'translate(met)
end
if met == 'oClear' then do
do fx=1 to m.cl.flds.0
f1 = m.cl.flds.fx
m.cl.flds_null.fx = if(m.cl.f2c.f1==m.class_W,
, m.o_escW, '')
end
m.cl.flds_null.0 = m.cl.flds.0
return "return classClear('"cl"', m)"
end
if met == 'oCopy' then do
if cl == m.class_N | cl == m.class_S | cl == m.class_W then
return 'return m'
do sx=1 to m.cl.stms.0
s1 = m.cl.stms.sx
call classMet m.cl.s2c.s1, 'oCopy'
end
call classMet cl, 'new'
return "if t=='' then t = mNew('"cl"');" ,
"call oMutate t, '"cl"';" ,
"return classCopy('"cl"', m, t)"
end
call err 'bad method in oMetLazy('cl',' met')'
endProcedure oMetLazy
classInheritsOf: procedure expose m.
parse arg cl, sup
cl = class4name(cl)
sup = class4name(sup)
if m.cl.inheritsOf \== 1 then do
m.cl.inheritsOf = 1
call classInheritsOfAdd cl, cl'.INHERITSOF'
end
return m.cl.inheritsOf.sup == 1
endProcedure classInheritsOf
classInheritsOfAdd: procedure expose m.
parse arg cl, trg, pa
pa = classCycle(cl, pa)
m.trg.cl = 1
call assert "m.cl == 'u'"
do cx=1 to m.cl.0
c1 = m.cl.cx
if m.c1 == 'u' then
call classInheritsOfAdd c1, trg, pa
end
return
endProcedure classInheritsOf
classClear: procedure expose m.
parse arg cl, m
if m.cl.flds_self then
m.m = m.cl.flds_null.1
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.m.f1 = m.cl.flds_null.fx
end
if m.cl.stms_self then
m.m.0 = 0
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
m.m.s1.0 = 0
end
return m
endProcedure classClear
classCopy: procedure expose m.
parse arg cl, m, t
if m.cl.flds_self then
m.t = m.m
do fx=1+m.cl.flds_self to m.cl.flds.0
f1 = m.cl.flds.fx
m.t.f1 = m.m.f1
end
if m.cl.stms_self then
call classCopyStem m.cl.s2c., m, t
do sx=1+m.cl.stms_self to m.cl.stms.0
s1 = m.cl.stms.sx
call classCopyStem m.cl.s2c.s1, m'.'s1, t'.'s1
end
return t
endProcedure classCopy
classCopyStem: procedure expose m.
parse arg cl, m, t
m.t.0 = m.m.0
do sx=1 to m.t.0
call classCopy cl, m'.'sx, t'.'sx
end
return 0
endProcedure classCopyStem
/*--- return true if src is a rexxVariable a, m.a.c etc. -------------*/
rxIsVar: procedure expose m.
parse arg src
if pos(left(src, 1), m.ut_rxN1) > 0 then
return 0
else
return verify(src, m.ut_rxId) = 0
endProcedure rxIsVar
/*--- return true if src is a rexxConstant rerpresenting its value ---*/
rxIsConst: procedure expose m.
parse arg src, vars c
if \ rxIsVar(src) then
return 0
srU = translate(src)
if srU \== src then
return 0
srU = '.'srU'.'
if pos('.GG', srU) > 0 then
return 0
if vars == '' then
return 1
upper vars
do vx=1 to words(vars)
if pos('.'word(vars, vx)'.', vars) > 0 then
return 0
end
return 1
endProcedure rxIsConst
/*--- return rexx code m.cc or mGet('cc') ----------------------------*/
rxMGet: procedure expose m.
parse arg v1, cc, vars
if cc == '' then
return 'm.'v1
else if rxIsConst(cc, vars) then
return 'm.'v1'.'cc
else
return 'mGet('v1 || quote('.'cc, "'")')'
endProcedure rxMGet
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse m, pr, p1
return classOutDone(m.class_O, m, pr, p1)
/*--- recursively output (with outX:) object a with class t ---------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class_O, t), a, pr, p1)
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return outX(p1'done :'className(t) '@'a)
done.t.a = 1
if t = m.class_O then do
if a == '' then
return outX(p1'obj null')
t = objClass(a)
if t = m.class_N | t = m.class_S then
return outX(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if t == m.class_V then
return outX(p1'=' m.a)
if t == m.class_W == 'w' then
return outX(p1'}' substr(a, 2))
if m.t == 'f' then
return classOutDone(m.t.1, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
return outX(p1'refTo :'className(m.t.1) '@null@')
else
return classOutDone(m.t.1, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t.1 == m.class_V
call outX p1 || if(m.t.name == '', 'union', ':'m.t.name),
|| copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call outX p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.1, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.1, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg cl, arg, arg2, arg3
interpret classMet(class4name(cl), 'new')
endProcedure oNew
/*--- return the class of object obj ---------------------------------*/
objClass: procedure expose m.
parse arg m
if arg() > 1 then
return err('old objClass') / 0
if symbol('m.o.o2c.m') == 'VAR' then
return m.o.o2c.m
else if abbrev(m, m.o_escW) then
return m.class_w
else if m \== '' then
return m.class_S
else
return m.class_N
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj)
return classInheritsOf(cl, sup)
endProcedure oKindOf
/*--- return the code of method met of object m -----------------------*/
objMet: procedure expose m.
parse arg m, met
if symbol('m.o.o2c.m') == 'VAR' then
cl = m.o.o2c.m
else if abbrev(m, m.o_escW) then
cl = m.class_w
else if m \== '' then
cl = m.class_S
else
cl = m.class_N
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
else
return classMet(cl, met) /* will do lazy initialisation */
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objMet(m, 'oFlds')
endProcedure oFlds
oClear: procedure expose m.
parse arg m
interpret objMet(m, 'oClear')
return m
endProcedure oClear
/*--- copy object m of class cl to t --------------------------------*/
oClaCopy: procedure expose m.
parse arg cl, m, t
interpret "drop cl;" classMet(cl, 'oCopy')
endProcedure oClaCopy
/*--- copy object m to t / create a new object if t=='' -------------*/
oCopy: procedure expose m.
parse arg m, t
interpret objMet(m, 'oCopy')
endProcedure oCopy
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
return oNew(classNew('n* ORun u ORun, m oRun' code))
endProcedure oRunner
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- run method oRun of object m No Procedure:
??? optimize: class only run ???
use from caller unprotected---------------------------------*/
oRunNP: procedure expose m.
interpret objMet(arg(1), 'oRun')
return
endProcedure oRunNP
/*--- run method oRun and return output in new JBuf ------------------*/
oRun2File: procedure expose m.
parse arg rn
b = jBuf()
call pipe '+F' , b
call oRun rn
call pipe '-'
return b
endProcedure oRun2File
/*--- cast the object to a file -------------------------------------*/
o2File: procedure expose m.
parse arg m
interpret objMet(m, 'o2File')
call err 'o2file did not return'
endProcedure o2File
/*--- cast the object to a String -----------------------------------*/
o2String: procedure expose m.
parse arg m, fmt
if arg() = 1 then
fmt = ' '
interpret objMet(m, 'o2String')
return err('o2String did not return')
endProcedure o2String
/*--- return a short string representation of an object -------------*/
o2Text: procedure expose m.
parse arg m, maxL, fmt
if maxL == '' then
maxL = 75
interpret objMet(m, 'o2Text')
endProcedure o2Text
o2TextFlds: procedure expose m.
parse arg m, cl, maxL
r = m'=['
do fx=1 to m.cl.flds.0 while length(r) <= maxL
f1 = m.cl.flds.fx
c1 = m.cl.f2c.f1
if c1 = m.class_V then
op = '='
else if m.c1 == 'r' then
op = '=>'
else
op = '=?'c1'?'
r = r || left(' ', fx > 1) || m.cl.flds.fx || op
if m.cl.flds.fx == '' then
r = r || strip(m.m)
else
r = r || strip(mGet(m'.'m.cl.flds.fx))
end
if length(r) < maxL then
return r']'
else
return left(r, maxL-3)'...'
endProcedure o2TextFlds
o2TextMet: procedure expose m.
parse arg cl, met
m1 = classMet(cl, 'o2String', '-')
if m1 \== '-' then do
if translate(word(m1, 1)) \== 'RETURN' then
call err 'o2TextMet' className(cl)'#o2String return?:' m1
return '__r = strip('subword(m1, 2)', "t");',
'if length(__r) <= maxL then return __r;' ,
'else return left(__r, maxL-3)"..."'
end
call classMet cl, 'oFlds'
return 'return o2TextFlds(m, '''cl''', maxL)'
endProcedure o2TextMet
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.o_escW || str
endProcedure s2o
oIfStr: procedure expose m.
parse arg m
if length(m) > 200 then
return m
cl = objClass(m)
if cl == m.class_N | cl == m.class_S then
return m
else if cl = m.class_V then
return = m.m
else if cl == m.class_W then
return = substr(m, 2)
else if arg() >= 2 then
return arg(2)
else
call err m 'of class' className(cl) 'not kind of string'
endProcedure oIfStr
/* copy o end *******************************************************/
/* copy class begin **************************************************
a class has fields and methods,
the class module handles only the metadata,
object handling (instanciation, methodcalls etc.) is in O
classes are represented by a metadata tree,
its nodes of class class have diffenrent types:
class subTypes (implemented as choices)
'u' = union: NAME -> name of class if <> '',
stem -> references component classes
'f' = field: NAME -> fieldName (x.name),
CLASSS -> reference to class of fieldValue
's' = stem: class -> ref to class at each stem element
'c' = choice: NAME -> selection value,
CLASS -> ref to class of choice
'm' = method: NAME -> methodName,
MET -> rexxCode
'r' = reference CLASS -> ref to type at reference
special classes
'v' = Value String Value
'w' = ValueAsA StringValue packed into an address (prefix escW)
'o' = AnyClass any class with dynamic classLookup on object
formal definition, see classIni
class expression (ce) allow the following syntax
ce = className | classAdr | 'n'('?','*','|')? name union | union
| 'f' name ce | 's' ce | 'c' name ce | 'm' name code | r ce?
union = 'u' (cu (',' cu)*)?
cu = ce | c1* '%' c1* '%'? name+ (same type for each name)
the modifiers of 'n' means
none: create new class, fail if name already defined
'?': create new class or return old of that name
'*': use an exisiting class of that definition
or create new class with a unique name
'|': create a new class with a unique name
'm' extends to then end of the ce (line)
'u' allows several components, in classNew also multiple args
Achtung, aber NICHT rekursiv|
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
m.o_escW = ']'
call mapIni
call timeIni
m.class.0 = 0
call mapReset class_n2c /* name to class */
m.class_V = classNew('n v u', 'm',
, "o2String return m.m",
, "o2File return file(m.m)")
m.class_W = classNew('n w u', 'm' ,
, "o2String return substr(m, 2)" ,
, "o2File return file(substr(m,2))")
m.class_O = classNew('n o u')
m.class_R = classNew('r')
m.class_C = classNew('n class u')
call classNew 'n= class u v' ,
, 'c u u f NAME v', /* union or class */
, 'c f u f NAME v', /* field */
, 'c s u' , /* stem */
, 'c c u f NAME v', /* choice */
, 'c r u' , /* reference */
, 'c m u f NAME v, f MET v' /* method */
call mAdd m.class_C, classNew('s r class')
m.class_root = classNew('n root u', 'm',
, "f2c ?l" ,
, "f2x ?l" ,
, "oFlds ?l" ,
, "o2Text ?o2textMet",
, "s2c ?l" ,
, "stms ?l" ,
, "in2Str ?r return ?o2String" ,
, "in2File ?r return ?o2File" ,
, "in2Buf ?r return jBufCopy(?o2File)" ,
, "scanSqlIn2Scan ?r" ,
"return scanSqlReset(s, ?in2File, wOpt, sOpt)")
m.class_S = classNew('n String u', 'm',
, 'in2Str return m' ,
, 'in2File return jBuf(m)',
, 'in2Buf return jBuf(m)',
, 'o2String return m',
, "scanSqlIn2Scan ?r if wOpt == '' then wOpt = 0;" ,
"return scanSqlReset(s, ?in2File, wOpt, sOpt)")
m.class_N = classNew('n Null u', 'm',
, 'in2Str return o2String(m.j.in, fmt)',
, 'in2File return m.j.in',
, 'in2Buf return jBufCopy(m.j.in)')
call classNew 'n ORun u', 'm',
, 'oRun call err "call of abstract method oRun"',
, 'o2File return oRun2File(m)',
, 'o2String return jCatLines(oRun2File(m), fmt)',
, 'o2Text ?r return m"=[?:]"'
return
endProcedure classIni
classNe1: procedure expose m.
parse arg n, ty, nm, refs, io
ky = ty','nm','space(refs, 1)','strip(io)
if ty == 'f' & abbrev('=', nm) then do
if words(refs) = 1 & io == '' then
return strip(refs)
else
call err 'bad field name:' ky
end
if n then
if symbol('m.class_k2c.ky') == 'VAR' then
return m.class_k2c.ky
m.class.0 = m.class.0 + 1
n = 'CLASS.'m.class.0
call mapAdd class_n2c, n, n
m.n = ty
m.n.name = nm
m.n.met = strip(io)
m.n.0 = words(refs)
do rx=1 to m.n.0
m.n.rx = mapGet(class_n2c, word(refs, rx))
end
if right(nm, 1) == '*' then
nm = left(nm, length(nm)-1)substr(n, 7)
if length(ty) \== 1 | pos(ty, 'ufscrm') < 1 then
call err 'bad type' ty': classNe1('ky')' /0
else if nm == '' & pos(ty, 'm') > 0 then
call err 'empty name: classNe1('ky')'
else if nm \== '' & ty \== 'c' & verifId(nm) > 0 then
call err 'bad name' nm': classNe1('ky')'
else if nm \= '' & pos(ty, 'rs') > 0 then
call err 'name for type' ty': classNe1('ky')'
else if (pos(ty, 'fcsr') > 0 & m.n.0 \== 1) ,
| ( ty == 'm' & m.n.0 \== 0) then
call err m.n.0 'bad ref count in classNe1('ky')'
return n
endProcedure classNe1
classNew: procedure expose m.
parse arg clEx 1 ty rest
n = ''
nm = ''
io = ''
refs = ''
if wordPos(ty, 'n n? n* n=') > 0 then do
nmTy = right(ty, 1)
parse var rest nm ty rest
if nmTy = '=' then do
if \ mapHasKey(class_n2c, nm) then
call err 'class' nm 'not defined: classNew('clEx')'
n = mapGet(class_n2c, nm)
end
if ty \== 'u' then
call err 'class name' nm 'without u: classNew('clEx')'
if nmTy == '?' then do
if mapHasKey(class_n2c, nm) then
return mapGet(class_n2c, nm)
end
else if nmTy == '*' & arg() == 1 then do
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
end
end
else do
nmTy = ''
if arg() == 1 then
if mapHasKey(class_n2c, clEx) then
return mapGet(class_n2c, clEx)
if length(ty) <> 1 | pos(ty, 'ufscmr') < 1 then
return err('bad type' ty': classNew('clEx')')
if pos(ty, 'fcm') > 0 then
parse var rest nm rest
if ty == 'm' then
io = rest
else if pos(ty, 'fsc') > 0 | (ty == 'r' & rest \== '') then
refs = classNew(strip(rest))
else if ty == 'r' then
refs = m.class_O
end
if ty == 'u' then do
lx = 0
do while lx < length(rest)
t1 = word(substr(rest, lx+1), 1)
cx = pos(',', rest, lx+1)
if cx <= lx | t1 == 'm' then
cx = length(rest)+1
one = strip(substr(rest, lx+1, cx-lx-1))
lx=cx
if pos('%', word(one, 1)) < 1 then
refs = refs classNew(one)
else do
parse value translate(word(one, 1), ' ', '-') ,
with wBe '%' wAf '%' ww
do wx=2 to words(one)
refs = refs classNew(wBe word(one, wx) wAf)
end
end
end
pref = ''
do ax=2 to arg()
if length(arg(ax)) == 1 & arg(ax) \== ' ' then
pref = arg(ax)' '
else
refs = refs classNew(pref || arg(ax))
end
end
if nmTy == '=' then do
if m.n \== ty | ty \== 'u' then
call err 'n= mismatch'
do ux=1 to words(refs)
call mAdd n, word(refs, ux)
end
end
else if nmTy == '*' then
n = classNe1(0, ty, nm'*', refs, io)
else
n = classNe1(nmTy == '', ty, nm, refs, io)
if arg() == 1 then
call mapAdd class_n2c, clEx, n
if nmTy == '*' & m.n.name == nm'*' then
m.n.name = nm || substr(n, 6)
if nmTy \== '' & nmTy \== '=' then
call mapAdd class_n2c, m.n.name, n
return n
endProcedure classNew
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if \ mapHasKey(class_n2c, cl) then
return 'notAClass:' cl
c2 = mapGet(class_n2c, cl)
if m.c2 = 'u' & m.c2.name \= '' then
return m.c2.name
else
return cl
endProcedure className
/*--- return class of given name or class ---------------------------*/
class4Name: procedure expose m.
parse arg nm
if symbol('m.class_n2c.nm') == 'VAR' then
return m.class_n2c.nm
if arg() > 1 then
return arg(2)
call err 'no class' nm
endProcedure class4Name
/*--- mutate object m to the class cl -------------------------------*/
oMutate: procedure expose m.
parse arg m, cl
m.o.o2c.m = cl
return m
endProcedure oMutate
/*--- mutate object m to the class named name -----------------------*/
oMutatName: procedure expose m.
parse arg m, nm
m.o.o2c.m = class4Name(nm)
return m
endProcedure oMutatName
/*--- find the code for a met in a class ---------------------------*/
classMet: procedure expose m.
parse arg cl, met
if symbol('m.cl.method.met') == 'VAR' then
return m.cl.method.met
if symbol('m.cl.metLazy.met') == 'VAR' then do
/* build lazy method */
m.cl.method.met = "call err 'building lazy method" cl"#"me"'"
parse var m.cl.metLazy.met m1 mR
if m1 == '?r' then
m.cl.method.met = classMetRec(cl, met, mR)
else if m1 == '?l' then
m.cl.method.met = oMetLazy(cl, met, mR)
else
interpret 'm.cl.method.met =' substr(m1,2)'(cl,met,mR)'
return m.cl.method.met
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.methods \== 1 then do /* already generated? */
m.cl.methods = 1 /* generate methods from class */
if m.cl == 'u' then
call classMetGen cl, cl'.'method, cl'.'metLazy
call classMetGen m.class_root, cl'.'method, cl'.'metLazy
return classMet(cl, met, arg(3))
end
if arg(3) == '' then
return err('no method' met 'in class' className(cl))
else
return arg(3)
endProcedure classMet
/*--- generate all methods for a class recursively (if not already done)
lazy methods are only put to metLazy -----------------------*/
classMetGen: procedure expose m.
parse arg aC, trg, lazy, pa
pa = classCycle(aC, pa)
if m.aC \== 'u' then
call err 'cl not u:' m.aC aC
do cx=1 to m.aC.0
cl = m.aC.cx
if pos(m.cl, 'ufscr') > 0 then
iterate
if m.cl \== 'm' then
call err 'bad cla' cl m.cl
m1 = m.cl.name
if symbol('m.trg.m1')=='VAR' | symbol('m.lazy.m1')=='VAR' then
nop
else if \ abbrev(m.cl.met, '?') then
m.trg.m1 = m.cl.met
else
m.lazy.m1 = m.cl.met
end
do cx=1 to m.aC.0
cl = m.aC.cx
if m.cl \== 'u' then
iterate
call classmetGen cl, trg, lazy, pa
end
return
endProcedure classmetGen
classMetRec: procedure expose m.
parse arg cl, met, rest
gen = ''
rx = 1
do forever
ry = pos('?', rest, rx)
if ry == 0 then
return gen || substr(rest, rx)
gen = gen || substr(rest, rx, ry-rx)
if substr(rest, ry+1, 1) == ':' then do
gen = gen || className(cl)
rx = ry+2
end
else if substr(rest, ry+1, 1) == '#' then do
gen = gen || met
rx = ry+2
end
else do
rx = verify(rest, m.ut_alfid, 'n', ry+1)
if rx = 0 then
rx = length(rest)+1
else if rx <= ry+1 then
call err 'classMetRec bad ?clause' substr(rest, x)
rr = classMet(cl, substr(rest, ry+1, rx-ry-1))
if word(rr, 1) = 'return' then
rr = subword(rr,2)
gen = gen || rr
end
end
endProcedure classMetRec
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
classMetLazy: procedure expose m.
parse arg cl, meNm, trg, m1 mRest
m.trg.meNm = "call err 'building lazy method" cl"#"meNm"'"
if m1 == '?r' then
m.trg.meNm = classMetRec(cl, meNm, mRest)
else if l1 == '?l' then
call oMetLazy(cl, meNm, trg, mest)
else
interpret 'm.cl.method.met =' + substr(l1,2)'(cl,met,lRest)'
return m.cl.method.met
classFlds: procedure expose m.
parse arg cl
return classMet(cl, 'oFlds')
endProcedure classFlds
/*--- add the the fields of class cl to stem f ----------------------*/
classFldAdd: procedure expose m.
parse arg f, cl, nm, pa
pa = classCycle(cl, pa)
if cl == m.class_V | cl == m.class_W | cl == m.class_O ,
| m.cl == 'r' then
return classFldAdd1(f'.FLDS', f'.F2C', cl, nm,
, if(cl=m.class_W, m.o_escW, ''))
if m.cl = 's' then do
if m.cl.1 == '' then
call err 'stem null class'
return classFldAdd1(f'.STMS', f'.S2C', m.cl.1, nm, 0)
end
if m.cl = 'f' then
return classFldAdd(f, m.cl.1, nm ,
|| left('.', m.cl.name \== '' & nm \== '') || m.cl.name, pa)
do tx=1 to m.cl.0
call classFldAdd f, m.cl.tx, nm, pa
end
return 0
endProcedure classFldAdd
classFldAdd1: procedure expose m.
parse arg fa, f2, cl, nm, null
if symbol('m.f2.nm') == 'VAR' then
if m.f2.nm == cl then
return 0
else
return err('f2 mismatch f2='f2 Nm 'cl='cl 'old='m.f2.nm)
m.f2.nm = cl
if nm == '' then do
call mMove fa, 1, 2
m.fa.1 = ''
call mPut fa'_SELF', 1
end
else do
call mAdd fa, nm
end
return 0
endProcedure classFldAdd1
/* copy class end ***************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('|', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('|', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') \== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') \== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.ut_alfDot, 'n', cx+1)
if ex < 1 then
return res || mapVia(a, substr(src, cx+1))
if ex = cx+1 then do
m.map.ExpAt = cx
return res
end
res = res || mapVia(a, substr(src, cx+1, ex-cx-1))
end
cx = pos('$', src, ex)
if cx < 1 then
return res || substr(src, ex)
res = res || substr(src, ex, cx-ex)
end
endProcedure mapExpAt
mapExp: procedure expose m.
parse arg a, src
res = mapExpAt(a, src, 1)
if m.map.ExpAt \== 0 then
call err 'mapExp stopped at' substr(src, map.ExpAt) 'in' src
return res
endProcedure mapExp
mapExpAllAt: procedure expose m.
parse arg a, dst, src, sx, cx
do while sx <= m.src.0
li = mapExpAt(a, m.src.sx, cx)
dx = m.map.ExpAt
if (cx=1 & dx = 0) | li \= '' then
call mAdd dst, li
if dx = 0 then do
cx = 1
sx = sx+1
end
else do
return sx dx
end
end
return ''
endProcedure mapExpAllAt
mapExpAll: procedure expose m.
parse arg a, dst, src
sto = mapExpAllAt(a, dst, src, 1, 1)
if sto == '' then
return
lx = word(sto, 1)
call err 'mapExpAll stopped at' sto':' m.src.lx
endProcedure mapExpAll
/* copy mapExp end ****************************************************/
/* copy 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
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 fTab begin *****************************************************
output Modes: t = tableMode 1 line per object
c = colMode 1 line per column/field of object
lifeCycle fTab sql
fTabReset sqlFTabReset
fTabAdd * sqlFTabAdd *
sqlFTabOthers ?
fTabGenerate
fTabBegin header lines
fTab1 * / tTabCol *
fTabEnd trailer lines
***********************************************************************/
fTabIni: procedure expose m.
if m.fTab_ini == 1 then
return
m.fTab_ini = 1
call classIni
m.fTab_class = classNew("n FTab u ORun, m oRun call fTab m")
return
endProcedure fTabIni
fTabReset: procedure expose m.
parse arg m, m.m.titBef, m.m.titAft, m.m.opt
call fTabIni
if m.m.titBef == '' & m.m.titaft == '' then do
m.m.titBef = 'c 1'
m.m.titAft = '1 c'
end
if m.m.titBef == '-' then
m.m.titBef = ''
if m.m.titAft == '-' then
m.m.titAft = ''
m.m.generated = ''
m.m.0 = 0
m.m.len = 0
m.m.cols = ''
m.m.sqlOthers = 1
m.m.set.0 = 0
return oMutate(m, m.fTab_class)
endProcedure fTabReset
/* add a piece to title tx at current pos */
fTabAddTit: procedure expose m.
parse arg m, cx, tx, t1
m.m.generated = ''
if ty < m.m.cx.tit.0 then do
do xx=m.m.cx.tit.0+1 to tx-1
m.m.cx.tit.xx = ''
end
m.m.cx.tit.0 = tx
end
m.m.cx.tit.tx = t1
return m
endProcedure fTabAddTit
/*--- set the infos for one column -----------------------------------*/
fTabSet: procedure expose m.
parse arg m, c1 aDone, f1, l1
sx = m.m.set.0 + 1
m.m.set.0 = sx
m.m.set.sx = c1 aDone
m.m.set.sx.fmt = f1
m.m.set.sx.labelCy = l1
m.m.set.sx.labelTi = c1
m.m.set.c1 = sx
return
endProcedure fTabSet
fTabAdd: procedure expose m. /* old interface, new is ...RCT */
parse arg m, c1Done, f1, l1
call fTabAddRCT m, c1Done, f1, , l1
ox = m.m.0
m.m.ox.tit.0 = max(arg()-3, 1)
do tx=2 to m.m.ox.tit.0
m.m.ox.tit.tx = arg(tx+3)
end
return
endProcedure fTabAdd
fTabAddRCT: procedure expose m.
parse arg m, rxNm aDone, f1, cyNm, tiNm
cx = m.m.0 + 1
m.m.generated = ''
m.m.0 = cx
m.m.cx.tit.0 = max(arg()-4, 1)
m.m.cx.tit.1 = ''
do tx=2 to m.m.cx.tit.0
m.m.cx.tit.tx = arg(tx+4)
end
r1 = rxNm
if rxNm == '' then
r1 = '='
else if rxNm == '=' then
rxNm = ''
m.m.cols = m.m.cols r1
if words(m.m.cols) <> cx then
call err 'mismatch of column number' cx 'col' rxNm / 0
if length(aDone) > 1 | wordPos('<'aDone'>', '<> <0> <1>') < 1 then
call err 'bad done' length(aDone) '<'aDone'> after rxNm' rxNm
m.m.cx.col = rxNm
m.m.cx.done = aDone \== 0
if cyNm == '' then
m.m.cx.labelCy = r1
else
m.m.cx.labelCy = cyNm
if tiNm == '' then
m.m.cx.labelTi = m.m.cx.labelCy
else
m.m.cx.labelTi = tiNm
px = pos('%', f1)
ax = pos('@', f1)
if px < 1 | (ax > 0 & ax < px) then
m.m.cx.fmt = f1
else
m.m.cx.fmt = left(f1, px-1)'@.'rxNm || substr(f1, px)
return m
endProcedure fTabAddRCT
fTabGenerate: procedure expose m.
parse arg m, sep
f = ''
tLen = 0
m.m.tit.0 = words(m.m.titBef m.m.titAft) + 5
do tx=1 to m.m.tit.0
m.m.tit.tx = ''
end
do kx=1 to m.m.0
rxNm = m.m.kx.col
call mPut 'F_TEMP'left('.', rxNm\=='')rxNm, m.m.kx.labelTi
t1 = f(m.m.kx.fmt, 'F_TEMP')
m.m.kx.len = length(t1)
if pos(strip(t1), m.m.kx.labelTi) < 1 then
t1 = left(left('', max(0, verify(t1, ' ') -1)) ,
|| m.m.kx.labelTi, length(t1))
m.m.kx.tit.1 = t1
if kx = 1 then do
f = m.m.kx.fmt
end
else do
tLen = tLen + length(sep)
f = f || sep || m.m.kx.fmt
end
m.m.kx.start = tLen+1
do tx=1 to m.m.kx.tit.0
if m.m.kx.tit.tx \== '' then
if tx > 1 | pos('-', m.m.opt) < 1 then
m.m.tit.tx = left(m.m.tit.tx, tLen) ,
|| strip(m.m.kx.tit.tx, 't')
else if \ abbrev(m.m.kx.tit.tx, ' ') then
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| strip(m.m.kx.tit.tx, 't')
else
m.m.tit.tx = left(m.m.tit.tx, tLen, '-') ,
|| right(strip(m.m.kx.tit.tx),
, length(m.m.kx.tit.tx), '-')
end
tLen = tLen + m.m.kx.len
end
m.m.len = tLen
if pos('-', m.m.opt) > 0 then
m.m.tit.1 = left(m.m.tit.1, tLen +3, '-')
m.m.fmt = fCache('%.', f)
cSta = m.m.tit.0+3 /* compute cycle titles */
cycs = ''
cyEq = 1
do cEnd=cSta until kx > m.m.0
cycs = cycs cEnd
cx = cSta
firstRound = 1
do kx=1 to m.m.0
if firstRound then
m.m.tit.cx = left('', m.m.kx.start-1)m.m.kx.labelCy
else if length(m.m.tit.cx) <= m.m.kx.start - 2 then
m.m.tit.cx = left(m.m.tit.cx, m.m.kx.start - 1) ,
|| m.m.kx.labelCy
else
leave
if cyEq then
cyEq = translate(m.m.kx.labelCy) ,
= translate(m.m.kx.labelTi)
cx = cx + 1
if cx > cEnd then do
cx = cSta
firstRound = 0
end
end
end
m.m.cycles = strip(cycs)
if cyEq & words(cycs) <= 1 then
m.m.cycles = ''
m.m.generated = m.m.generated't'
return
endProcedure fTabGenerate
fTabColGen: procedure expose m.
parse arg m
do kx=1 to m.m.0
t = m.m.kx.labelTI
l = if(m.m.kx.labelCy == t, , m.m.kx.labelCy)
f = lefPad(lefPad(strip(l), 10) t, 29)
if length(f) > 29 then
if length(l || t) < 29 then
f = l || left('', 29 - length(l || t))t
else
f = lefPad(strip(l t), 29)
g = strip(m.m.kx.fmt)
o = right(g, 1)
if pos(o, 'dief') > 0 then
f = f '@'m.m.kx.col'%12e @'m.m.kx.col'%18c'
else if o = 'C' then
f = f left(g, length(g)-1)'c'
else
f = f g
m.m.kx.colFmt = f
end
m.m.generated = m.m.generated'c'
return
endProcedure fTabColGen
fTab: procedure expose m.
parse arg m, rdr
call fTabBegin m
call fAll m.m.fmt, rdr
return fTabEnd(m)
endProcedure fTab
fTabCol: procedure expose m.
parse arg m, i
do cx=1 to m.m.0
call out f(m.m.cx.colFmt, i)
end
return 0
endProcedure fTabCol
fTabBegin: procedure expose m.
parse arg m
if pos('t', m.m.generated) < 1 then
call fTabGenerate m, ' '
return fTabTitles(m, m.m.titBef)
endProcedure fTabBegin
fTabEnd: procedure expose m.
parse arg m
return fTabTitles(m, m.m.titAft)
fTabTitles: procedure expose m.
parse arg m, list
list = repAll(list, 'c', m.m.cycles)
do tx=1 to words(list)
t1 = word(list, tx)
call out m.m.tit.t1
end
return m
endProcedure fTabTitles
/*--- auto tables detect format from data ---------------------------*/
/*--- detect fmt from a rdr and write it formatted to stdOut --------*/
fTabAuto: procedure expose m.
parse arg m, rdr, wiTi
if m == '' then
m = fTabReset(f_auto, 1)
i = in2Buf(rdr)
if m.i.buf.0 <= 0 then
return m
call fTabDetect m, i'.BUF', wiTi
return fTab(m, i)
endProcedure fTabAuto
/*--- generate format for all fields of a stem of objects -----------*/
fTabDetect: procedure expose m.
parse arg m, b
ff = oFlds(m.b.1)
do fx=1 to m.ff.0
call fTabAddDetect m, m.ff.fx, b
end
return
endProcedure fTabDetect
/*--- generate format for all fields of a stem of objects -----------*/
sqlfTabDetect: procedure expose m.
parse arg m, b
cx = m.m.sqlX
ff = m.sql.cx.fetchFlds
do fx=1 to words(ff)
call fTabAddDetect m, word(ff, fx), b, m.sql.cx.d.fx.sqlName
end
return
endProcedure fTabDetect
/*--- detect format for one field in stem st ------------------------*/
fTabAddDetect: procedure expose m.
parse arg m, c1 aDone, st, cyNm, tiNm
lMa = -1
rMa = -1
bMa = -1
aDiv = 0
nMi = 9e999
nMa = -9e999
eMi = 9e999
eMa = -9e999
eDa = 2
dMa = -9e999
suf = left('.', c1 \== '')c1
do sx=1 to m.st.0
v = mGet(m.st.sx || suf)
lMa = max(lMa, length(strip(v, 't')))
rMa = max(rMa, length(strip(v, 'l')))
bMa = max(bMa, length(strip(v, 'b')))
if \ dataType(v, 'n') then do
if length(v) > 100 then
aDiv = 99
else if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
v = strip(v)
nMi = min(nMi, v)
nMa = max(nMa, v)
ex = verify(v, 'eEfF', 'm')
if ex > 0 then do
eMa = max(eMa, substr(v, ex+1))
eMi = min(eMi, substr(v, ex+1))
v = left(v, ex-1)
do while pos(left(v,1), '+-0') > 0
v = substr(v, 2)
end
eDa = max(eDa, length(v) - (pos('.', v) > 0))
end
dx = pos('.', v)
if dx > 0 then do
do while right(v, 1) == 0
v = left(v, length(v)-1)
end
dMa = max(dMa, length(v)-dx)
end
end
if nMi > nMa | aDiv > 3 then
newFo = '-'max(1, (lMa+0))'C'
else if eMi <= eMa then do
newFo = ' ' || (eDa+max(length(eMa), length(eMi))+3) ,
|| '.'||(eDa-1)'e'
end
else do
be = max(length(trunc(nMi)), length(trunc(nMa)))
if dMa <= 0 then
newFo = max(be, bMa)'I'
else
newFo = max(be+1+dMa, bMa)'.'dMa'I'
end
call fTabAddRCT m, c1 aDone, '%'newFo, cyNm, tiNm
/* say c1 '????==> %'newFo */
return newFo
endProcedure fTabAddDetect
/*--- format with units seconds ==> 3d13 oder 5.43e6 ==> 5m43 --------*/
fTime: procedure expose m.
?????????????? use f(%kd) ????????????????
fDec: procedure expose m.
?????????????? use f(%kd) ????????????????
fUnits: procedure expose m.
parse arg v, scale, aLen, aPrec, plus
if \ dataType(v, 'n') then do
f1 = fUnitsF1(v, scale, aLen, length(plus), length(plus), aPrec)
return right(v, m.f1.len)
end
if v >= 0 then
sign = plus
else
sign = '-'
v = abs(v) /* always get rid also of sign of -0 | */
f1 = fUnitsF1(v, scale, aLen, length(plus), length(sign), aPrec)
do forever
w = format(v * m.f1.fact, , m.f1.prec)
if pos('E-', w) > 0 then
w = format(0, , m.f1.prec)
if w < m.f1.lim2 then do
if m.f1.kind == 'r' then
x = sign || w || m.f1.unit
else if m.f1.kind == 'm' then
x = sign || (w % m.f1.mod) || m.f1.unit ,
|| right(w // m.f1.mod, m.f1.len2, 0)
else
call err 'bad kind' m.f1.kind 'in f1' f1
if length(x) <= m.f1.len then
return right(x, m.f1.len)
end
if m.f1.next == '' then
return left(sign, m.f1.len, '+')
f1 = m.f1.next
end
endProcedure fUnits
fUnitsF1: procedure expose m.
parse arg v, scale, len, pLen, sLen, aPrec
slp = 'F_Unit.'scale'.'len'.'pLen'.'sLen'.'aPrec
if symbol('m.slp.0') \== 'VAR' then do
sc = 'F_Unit.'scale
if symbol('m.sc.0') \== 'VAR' then do
call fUnitsF1Ini1
if symbol('m.sc.0') \== 'VAR' then
call err 'bad scale' sc
end
if scale = 'd' | scale = 'b' then do
if aPrec == '' then
aPrec = 0
if len = '' then
len = aPrec + (aPrec >= 0) + 4 + pLen
dLen = len - sLen
l2 = '1e' || (dLen - aPrec - (aPrec > 0))
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, l2, len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = aPrec
m.si.next = slp'.' || (x+1)
end
if aPrec > 0 then do
y = x-1
si = fUnitsF1I0(slp, x, m.sc.y.kind, m.sc.y.unit,
, m.sc.y.fact, ('1e' || dLen), len)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
end
end
else if scale = 't' then do
if len = '' then
len = 5 + pLen
dLen = len - sLen
call fUnitsF1I0 slp, 'nn', 'nn', , , , len
do x=m.sc.min to m.sc.0
si = fUnitsF1I0(slp, x, m.sc.x.kind, m.sc.x.unit,
, m.sc.x.fact, m.sc.x.lim2, len ,
, m.sc.x.mod, m.sc.x.len2)
if x = m.sc.0 - 1 then
m.si.lim2 = '24e' || (dLen-3)
else if x = m.sc.0 then
m.si.lim2 = '1e' || (dLen-1)
m.si.lim1 = m.si.lim2 / m.si.fact
m.si.prec = 0
m.si.next = slp'.' || (x+1)
end
end
else
call err implement
x = m.slp.0
m.slp.x.next = ''
end
if \ datatype(v, 'n') then
return slp'.nn'
do q=11 to m.slp.0-1 while v >= m.slp.q.lim1
end
if q = 11 & v <> trunc(v) then do
do q=10 by -1 to m.slp.min+1 while v < m.slp.q.lim1
end
q = q + 1
end
return slp'.'q
endProcedure fUnitsF1
fUnitsF1Ini1: procedure expose m.
/* 0 5 10 5 20 */
iso = ' afpnum kMGTPE '
sc = 'F_Unit.d'
call fUnitsF1i0 sc, 11, 'r', ' ', 1
f = 1
do x=1 to 6
f = f * 1000
call fUnitsF1i0 sc, 11+x, 'r', substr(iso, 11+x, 1), 1/f
call fUnitsF1i0 sc, 11-x, 'r', substr(iso, 11-x, 1), f
end
sc = 'F_Unit.b'
f = 1
do x=11 to 17
call fUnitsF1i0 sc, x, 'r', substr(iso, x, 1), 1/f
f = f * 1024
end
sc = 'F_Unit.t'
call fUnitsF1i0 sc, 11, 'm', 's', 100, 6000, , 100, 2
call fUnitsF1i0 sc, 12, 'm', 'm', 1, 3600, , 60, 2
call fUnitsF1i0 sc, 13, 'm', 'h', 1/60, 1440, , 60, 2
call fUnitsF1i0 sc, 14, 'm', 'd', 1/3600, , , 24, 2
call fUnitsF1i0 sc, 15, 'r', 'd', 1/3600/24
return
endProcedure fUnitsF1Ini0
fUnitsF1I0: procedure expose m.
parse arg sc, ix
si = sc'.'ix
parse arg , , m.si.kind, m.si.unit, m.si.fact,
, m.si.lim2, m.si.len,
, m.si.mod, m.si.len2
if \ datatype(ix, 'n') then
return si
if symbol('m.sc.0') \== 'VAR' then do
m.sc.0 = ix
m.sc.min = ix
end
else do
m.sc.0 = max(ix, m.sc.0)
m.sc.min = min(ix, m.sc.min)
end
return si
endProcedure fUnitsF1I0
/* copy fTab end ****************************************************/
/* copy f begin *******************************************************/
/*--- format with the given format ggA1, ggA2, etc. -----------------*/
f: procedure expose m.
parse arg ggFmt, ggA1, ggA2
if symbol('M.f_gen.ggFmt') \== 'VAR' then
call fCache ggFmt, ggFmt
interpret m.f_gen.ggFmt
endProcedure f
fImm: procedure expose m.
parse arg ggFmt, ggA1
interpret m.ggFmt
endProcedure fImm
fCacheNew: procedure expose m.
if symbol('m.f_gen0') == 'VAR' then
m.f_gen0 = m.f_gen0 + 1
else
m.f_gen0 = 1
return '%.'m.f_gen0
endProcedure fCacheNew
/*--- compile format fmt put in the cache with address a ------------*/
fCache: procedure expose m.
parse arg a, fmt
if a == '%.' then
a = fCacheNew()
else if symbol('M.f_gen.a') == 'VAR' then
return a
cy = -2
nm = ' '
gen = ' '
opt = 0
do forever /* split preprocesser clauses */
cx = cy+3
cy = pos('%#', fmt, cx)
if cy < 1 then
act = substr(fmt, cx)
else
act = substr(fmt, cx, cy-cx)
do ax=1
ay = pos('%&', act)
if ay < 1 then
leave
ct = substr(act, ay+2, 1)
if symbol('f.ct') \== 'VAR' then
call err 'undefined %&'ct 'in format' fmt
act = left(act, ay-1) || f.ct || substr(act, ay+3)
if ax > 100 then
say 'fGen' fmt nm '==>' act 'actPos' substr(fmt, cx)
end
if cy <> 1 & (\ opt | symbol('f.nm') \== 'VAR') then
f.nm = act
if cy < 1 | length(fmt) <= cy+1 then
leave
nm = substr(fmt, cy+2, 1)
opt = nm == '?'
if pos(nm, '?;#') > 0 then do
if nm == '#' then do
if length(fmt) <> cy+3 then
call err 'fCache bad %##'nm 'in' fmt
else if a == fmt then
a = left(a, cy-1)
leave
end
cy = cy+1
nm = substr(fmt, cy+2, 1)
if nm == ';' then do
gen = nm
iterate
end
end
if pos(nm, m.ut_alfa' ') < 1 then
call err 'fCache bad name %#'nm 'in' fmt
if pos(nm, gen) < 1 then
gen = gen || nm
end
if symbol('m.f_s_0') \== 'VAR' | m.f_s_0 == 0 then
m.f_s_0 = 1
else do
m.f_s_0 = m.f_s_0 + 1
f_s = 'F_S_'m.f_s_0
end
do cx=1 to length(gen)
nm = substr(gen, cx, 1)
act = f.nm
a2 = a
if nm == ' ' then
a2 = a
else
a2 = a'%##'nm
call scanSrc f_s, act
m.f_gen.a2 = fGen(f_s)
if \ scanEnd(f_s) then
call scanErr f_s, "bad specifier '"m.f_s.tok"'"
end
m.f_s_0 = m.f_s_0 - 1
return a
endProcedure fCache
/*--------------------------------------------------------------------
Format generator should be compatible with fPrint|
<<<< + extension of fPrint, - in fPrint but not implemented
%% %@ the escaped char
('@' argN? '.'? field)?'%' flags? width? ('.' precision)? specifier
specifier: is the most significant one and defines the type
- c Character rigPad or lefPad, prec ==> substr(..., prec)
- C Cut %-nC = left(v,n), %nC = right(v,n) %n.mC = substr(m, n)
- hH Characters in hex
- iI Signed decimal integer (padded or cut)
- eE Scientific notation (mantissa/exponent) using e character 3.92e+2
- S Strip (both)
- txy time date formatting from format x to format y see fTstGen
- kx units Formatting x = t=time d=decimal b=binary (k) B=binary (kB)
Flags:
- - Left-justify within the given field width; Right is default
- + print '+' before non negative numbers
-' ' print ' ' before non negative numbers
- / cut to length
preprocessor implemented in fCache
%#v before contents of variable v (1 alfa or 1 space),
stored at address%##v
%#?v define variable v if not yet defined
%#; restart of variables to generate
%&v use of previously defined variable v
----------------------------------------------------------------------*/
fGen: procedure expose m.
parse arg f_s
ax = 0
cd = ''
cp = ''
do forever
txt = fText(f_s)
if txt \== '' then
cd = cd '||' quote(txt, "'")
if scanEnd(f_s) then
leave
if \ scanLit(f_s, '@') then do
ax = ax + 1
af = ''
hasDot = 0
end
else do
if scanWhile(f_s, '0123456789') then
ax = m.f_s.tok
else if ax < 1 then
ax = 1
hasDot = scanLit(f_s, '.')
af = fText(f_s)
end
if \ scanLit(f_s, '%') then
call scanErr f_s, 'missing %'
call scanWhile f_s, '-+ /'
flags = m.f_s.tok
if scanWhile(f_s, '0123456789') then
len = m.f_s.tok
else
len = ''
if \ scanLit(f_s, '.') then
prec = ''
else do
call scanWhile f_s, '0123456789'
prec = m.f_s.tok
end
call scanChar f_s, 1
sp = m.f_s.tok
if ax < 3 | ass.ax == 1 then
aa = 'ggA'ax
else do
aa = 'arg(' || (ax+1) || ')'
if af \== '' then do
cp = cp 'ggA'ax '=' aa';'
aa = 'ggA'ax
ass.ax = 1
end
end
if af \== '' | hasDot then
aa = rxMGet(aa, af)
if sp == 'c' then do
if prec \== '' then
aa = 'substr('aa',' prec')'
if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| lefPad('aa',' len')'
else
cd = cd '|| rigPad('aa',' len')'
end
else if sp == 'C' then do
if prec \== '' then do
cd = cd '|| substr('aa',' prec
if len == '' then
cd = cd')'
else
cd = cd',' len')'
end
else if len == '' then
cd = cd '||' aa
else if pos('-', flags) > 0 then
cd = cd '|| left('aa',' len')'
else
cd = cd '|| right('aa',' len')'
end
else if sp == 'H' then
cd = cd "|| fH("aa"," len',' (pos('-', flags) > 0)')'
else if sp == 'h' then
cd = cd "|| translate(fH("aa", '"siL"'), 'abcdef','ABCDEF')"
else if sp == 'i' then
cd = cd "|| fI("aa"," len", '"flags"'," word(prec 0, 1)")"
else if sp == 'I' then
cd = cd "|| fI("aa"," len", '/"flags"'," word(prec 0, 1)")"
else if sp == 'E' | sp == 'e' then do
if len == '' then
len = 8
if prec = '' then
prec = len - 6
cd = cd "|| fE("aa"," len"," prec", '"sp"', '"flags"')"
end
else if sp = 'S' then
cd = cd '|| strip('aa')'
else if sp = 't' then do
call scanChar f_s, 2
cd = cd '||' fTstGen(m.f_s.tok, aa)
end
else if sp = 'k' then do
call scanChar f_s, 1
if pos(m.f_s.tok, 'tdbBiI') < 1 then
call scanErr f_s, "bad unit type" m.f_s.tok
if pos('+', flags) > 0 then
pl = ", '+'"
else if pos(' ', flags) > 0 then
pl = ", ' '"
else
pl = ''
cd = cd "|| fUnits("aa", '"m.f_s.tok"'," len"," prec pl")"
end
/* else if sp = '(' then do
if af == '' | flags \== '' | len \== 0 | prec \== '' then
call scanErr f_s, "bad call shoud be @sub%("
interpret "cRes = fGen"af"(f_s, ax)"
cd = cd '||' cRes
if \ scanLit(f_s, '%)') then
if \ scanEnd(f_s) then
call scanErr f_s, '%) to end call' af 'expected'
end */
else do
call scanBack f_s, '%'sp
leave
end
end
if cd \== '' then
return strip(cp 'return' substr(cd, 5))
else
return "return ''"
endProcedure fGen
fText: procedure expose m.
parse arg f_s
res = ''
do forever
if scanUntil(f_s, '@%') then
res = res || m.f_s.tok
if \ scanLit(f_s, '%%', '%@') then
return res
res = res || substr(m.f_s.tok, 2)
end
endProcedure fText
fAll: procedure expose m.
parse arg fmt, rdr
i = jOpen(in2File(rdr), '<')
do while jRead(i)
call out f(fmt, m.i)
end
call jClose i
return
endProcedure fAll
/*--- format character2hex (if not sql null) -------------------------*/
fH: procedure expose m.
parse arg v, l, leftJ
if v \== m.sqlNull then
v = c2x(v)
if length(v) > l then
return v
else if leftJ \== 1 then
return right(v, l)
else
return left(v, l)
endProcedure fH
/*--- format integer or fixPoint Decimal -----------------------------*/
fI: procedure expose m.
parse arg v, l, flags, d
if \ datatype(v, 'n') then
return fRigLeft(strip(v), l, flags)
v = format(v, , d, 0)
if pos('+', flags) > 0 then
if \ abbrev(v, '-') then
v = '+'v
if length(v) > l then
if pos('/', flags) > 0 then
return left('', l, '*')
else
return v
return fRigLefPad(v, l, flags)
endProcedure fI
/*--- format with exponent l=total output len
d=number of digits after . in mantissa
c=exponent character
flags: - to ouput text left justified
differences: exponent is always printed but without +
overflow ==> expand exponent, *****, 0e-999 ---------*/
fE: procedure expose m.
parse arg v, l, d, c, flags
if \ datatype(v, 'n') then
return fRigLeft(v, l, flags)
if pos(' ', flags) < 1 then
if v >= 0 then
if pos('+', flags) > 0 then
return '+'substr(fE(v, l, d, c, ' 'flags), 2)
else
return substr(fE(v, l+1, d+1, c, ' 'flags), 2)
x = format(v, 2, d, 7, 0)
m = 2 + d + (d>0)
call assert "length(x) == m+9", 'm x length(x)'
if substr(x, m+1) = '' then
return left(x, m)c || left('', l-m-1, 0)
call assert "substr(x, m+1, 1) == 'E'","exponenent in x not at m"
y = verify(x, '0', 'n', m+3)
call assert 'y>0'
if substr(x, m+1, 2) == 'E+' then do
if m+10-y <= l-m-1 then
return left(x,m)c || right(x, l-m-1)
z = l - 4 - (m+10-y)
end
else if substr(x, m+1, 2) == 'E-' then do
if m+10-y <= l-m-2 then
return left(x,m)c'-'right(x, l-m-2)
z = l - 5 - (m+10-y)
end
else
call err 'bad x' x
if z >= -1 & max(0, z) < d then
return fE(v, l, max(0, z), c, flags)
else if substr(x, m+1, 2) == 'E-' then
return left(x,1)'0'c'-'left('', l-4, 9)
else
return left('', l, '*')
endProcedure fE
/*--- right or left with truncation ----------------------------------*/
fRigLeft: procedure expose m
parse arg s, len, flags
if length(s) = len then
return s
else if pos('-', flags) > 0 | length(s) > len then
return left(s, len)
else
return right(s, len)
endProcedure fRigLefPad
/*--- right or left pad without truncation --------------------------*/
fRigLefPad: procedure expose m
parse arg s, len, flags
if pos('-', flags) > 0 then
if length(strip(s, 't')) >= len then
return strip(s, 't')
else
return left(s, len)
else
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
else
return right(s, len)
endProcedure fRigLefPad
/*--- generate timestamp formats: from format c to format d ----------*/
fTstGen: procedure expose m.
parse arg c 2 d, s
/* special L = LRSN in Hex
l = lrsn (6 or 10 Byte) */
if c == 'L' then
return fTstGen('S'd, 'timeLRSN2LZT('s')')
if c == 'l' then
return fTstGen('S'd, 'timeLRSN2LZT(c2x('s'))')
cd = c || d
if symbol('m.f_tstFo.c') \== 'VAR' ,
| symbol('m.f_tstFo.d') \== 'VAR' then do
if m.f_tstIni == 1 then
call err "bad timestamp from or to format '"cd"'"
m.f_tstIni = 1
a = 'F_TSTFO.'
/* Y: year A = 2010 ...
M: month B=Januar ...,
H: hour A=0 B=10 C=20 D=30 */
m.f_tst_N0 = 'yz345678 hi:mn:st'
m.f_tst_N = 'yz345678 hi:mn:st.abcdef'
m.f_tst_S0 = 'yz34-56-78-hi.mn.st'
m.f_tst_S = 'yz34-56-78-hi.mn.st.abcdef'
call mPut a'S', m.f_tst_S
call mPut a's', m.f_tst_S0
call mPut a' ', m.f_tst_S0
call mPut a'D', 'yz345678'
call mPut a'd', '345678'
call mPut a't', 'hi.mn.st'
call mPut a'T', 'hi:mn:st.abcdef'
call mPut a'E', '78.56.yz34'
call mPut a'e', '78.56.34'
call mPut a'Y', 'YM78'
call mPut a'M', 'M78himns'
call mPut a'A', 'A8himnst'
call mPut a'H', 'Himnst'
call mPut a'n', m.f_tst_N0
call mPut a'N', m.f_tst_N
call mPut a'j', 'jjjjj' /* julian date 34jjj */
call mPut a'J', 'JJJJJJ' /* day since 1.1.00: 6 digits */
call mPut a'l', copies('l', 10) /* LRSN out 10 Byte, input var*/
call mPut a'L', copies('L', 20) /* LRSN in hex */
call mPut a'u', 'uuuuuuuu' /* Unique */
return fTstGen(cd, s)
end
if c == ' ' then do
if pos(d, 'SN') > 0 then
return fTstgFi(m.f_tst_N, m.f_tstFo.d,
, "date('S') time('L')")
else if pos(d, 'sMAn ') > 0 then
return fTstgFi(m.f_tst_N0, m.f_tstFo.d,
, "date('S') time()")
else if pos(d, 'DdEeY') > 0 then
return fTstgFi(mGet('F_TSTFO.D'), m.f_tstFo.d, "date('S')")
else if pos(d, 'tH') > 0 then
return fTstgFi(mGet('F_TSTFO.t'), m.f_tstFo.d, "time()")
else if pos(d, 'T') > 0 then
return fTstgFi(mGet('F_TSTFO.T'), m.f_tstFo.d, "time('L')")
else
call err 'fTstGen implement d='d
end
return fTstgFi(m.f_tstFo.c, m.f_tstFo.d, s)
endProcedure fTstGen
fTstgFi: procedure expose m.
parse arg f, d, s
code = fTstgFF(f, d, s)
if pos('$', code) == lastPos('$', code) ,
| verify(s, '(). ', 'm') < 1 then
return repAll(code, '$', s)
a = fCacheNew()
m.f_gen.a = 'return' repAll(s, '$', 'ggA1')
return "fImm('F_GEN."a"'," s")"
endProcedure fTstFi
fTstgFF: procedure expose m.
parse arg f, t, s
if verify(f, 'lLjJu', 'm') > 0 then do
if f == 'l' then do
if t == 'l' then
return 'timeLrsn10('s')'
else if t == 'L' then
return 'c2x(timeLrsn10('s'))'
else if verify(t, 'lL', 'm') = 0 then
return fTstFi(m.fTst_fo.S, t, 'timeLrsn2LZT('s')')
end
call err 'fTstgFF implement' f 'to' t
end
if symbol('m.F_TSTSCAN') == VAR then
m.f_tstScan = m.f_tstScan + 1
else
m.f_tstScan = 1
a = f_tstScan || m.f_tstScan
call scanSrc a, t
cd = ''
toNull = 'imnstabcdef78'
if verify(f, 'hH', 'm') = 0 then
toNull = toNull'hH'
if verify(f, 'M56', 'm') = 0 then
toNull = toNull'M56'
if verify(f, 'yz34Y', 'm') = 0 then
toNull = toNull'yz34Y'
do while \ scanEnd(a)
c1 = ''
do forever
if scanVerify(a, f' .:-', 'n') then do
c1 = c1 || m.a.tok
end
else if pos(scanLook(a, 1), toNull) > 0 then do
call scanChar a, 1
c1 = c1 || translate(m.a.tok, '00000000000010A?010001?',
, 'imnstabcdef78hHM56yz34Y')
end
else do
if c1 == '' then
nop
else if c1 == f then
c1 = s
else if pos(c1, f) > 0 then
c1 = "substr("s"," pos(c1, f)"," length(c1)")"
else
c1 = "translate('"c1"'," s", '"f"')"
leave
end
end
if c1 \== '' then do
end
else if scanVerify(a, 'yz34Y', 'n') then do
t1 = m.a.tok
if pos('yz34', f) > 0 then
c1 = "substr("s "," pos('yz34', f)", 4)"
else if pos('34', f) > 0 then
c1 = "timeYear24(substr("s "," pos('34', f)", 2))"
else if pos('Y', f) > 0 then
c1 = "timeY2Year(substr("s "," pos('Y', f)", 1))"
if t1 = '34' then
c1 = "substr("c1", 3)"
else if t1 = 'Y' then
c1 = "timeYear2Y("c1")"
end
else if scanVerify(a, '56M', 'n') then do
if m.a.tok == '56' & pos('M', f) > 0 then
c1 = "timeM2Month(substr("s"," pos('M', f)", 1))"
else if m.a.tok == 'M' & pos('56', f) > 0 then
c1 = "timeMonth2M(substr("s"," pos('56', f)", 2))"
end
else if scanVerify(a, 'hiH', 'n') then do
if m.a.tok == 'hi' & pos('Hi', f) > 0 then
c1 = "timeH2Hour(substr("s"," pos('Hi', f)", 2))"
else if m.a.tok == 'Hi' & pos('hi', f) > 0 then
c1 = "timeHour2H(substr("s"," pos('hi', f)", 2))"
end
else if scanLit(a, 'jjjjj') then do
c1 = "time2jul(" fTstGFF(f, 'yz34-56-78', s)")"
end
else if scanLit(a, 'JJJJJJ') then do
c1 = "date('B'," fTstGFF(f, 'yz345678', s)", 's')"
end
else if scanLit(a, copies('l', 10), copies('L', 20),
, 'uuuuuuuu') then do
c1 = "timeLZT2LRSN("fTstGFF(f, m.f_tst_S, s)")"
if abbrev(m.a.tok, 'l') then
c1 = "x2c("c1")"
else if abbrev(m.a.tok, 'u') then
c1 = "timeLrsn2Uniq("c1")"
end
else do
call scanChar a, 1
c1 = "'implement "m.a.tok"'"
/* call err 'implement' */
end
if c1 == '' then
call scanErr a, 'fTstGFF no conversion from' f
cd = cd "||" c1
end
m.f_tstScan = m.f_tstScan - 1
if cd == '' then
return "''"
else
return substr(cd, 5)
endProcedure fTstGFF
fWords: procedure expose m.
parse arg fmt, wrds
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if wrds = '' then
return f(f2'%##e')
res = f(f2'%##a', word(wrds, 1))
do wx=2 to words(wrds)
res = res || f(f2, word(wrds, wx))
end
return res
endProcedure fWords
fCat: procedure expose m.
parse arg fmt, st
return fCatFT(fmt, st, 1, m.st.0)
fCatFT: procedure expose m.
parse arg fmt, st, fx, tx
f2 = fmt'%#?a%c%#? %#?e%# %& %&a'
if tx < fx then
return f(f2'%##e')
res = f(f2'%##a', m.st.fx)
do sx=fx+1 to tx
res = res || f(f2, m.st.sx)
end
return res
endProcedure fCatFT
/* copy f end *******************************************************/
/* copy err begin *** errorhandling, messages, help ****************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
m.err.ini = 1
m.err.handler = ''
m.err.handler.0 = 0
m.err.cleanup = ';'
m.err.opt = ''
parse source m.err.os .
m.err.ispf = 0
m.err.screen = 0
if m.err.os \== 'LINUX' then do
address tso 'profile MsgId' /* brauchen wir in tsoAlloc| */
if sysVar('sysISPF') = 'ACTIVE' then do
m.err.ispf = 1
address ispExec 'vget zScreen shared'
m.err.screen = zScreen
end
end
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
m.err.handler.0 = 0
if pos('I', translate(m.err.opt)) > 0 & m.err.ispf then
address ispExec 'control errors return'
return
endSubroutine errReset
/* push error handler ------------------------------------------------*/
errHandlerPush: procedure expose m.
parse arg aH
ex = m.err.handler.0 + 1
m.err.handler.0 = ex
m.err.handler.ex = m.err.handler
m.err.handler = aH
return
endProcedure errHandlerPush
/* push error handler return Constant value --------------------------*/
errHandlerPushRet: procedure expose m.
parse arg rv
call errHandlerPush "return '"rv"'"
return
/* pop error handler ------------------------------------------------*/
errHandlerPop: procedure expose m.
if m.err.handler.0 < 1 then
call err 'errHandlerPop but err.handler.0='m.err.handler.0
ex = m.err.handler.0
m.err.handler = m.err.handler.ex
m.err.handler.0 = ex - 1
return
endProcedure errHandlerPop
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
if abbrev(ggOpt, '^') then
return substr(ggOpt, 2)
call errIni
drop err handler cleanup opt call return stackHistory
if ggOpt == '' & m.err.handler <> '' then
interpret m.err.handler
call errSay ggTxt
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
upper ggOpt
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 & m.err_cat == 'f' then
x = show + stackHistory + by + bad + arithmetic + conversion
call errSay ' }errorhandler exiting with exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared variable zIspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if m.err.ispf then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- error routine: user message cleanup exit -----------------------*/
errAddCleanup: procedure expose m.
parse arg code
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
errCleanup = m.err.cleanup
if errCleanup <> ';' then do
m.err.cleanup = ';'
say 'err cleanup begin' errCleanup
interpret errCleanup
say 'err cleanup end' errCleanup
end
if symbol('m.tso_ddAll') == 'VAR' then
call tsoFree m.tso_ddAll, 1
return
endProcedure errCleanup
/*--- say an errorMessage msg with pref and linesplits --------------*/
errSay: procedure expose m.
parse arg msg
return sayNl(errMsg(msg))
/*--- prefix an errormessage with pref,
split it into lines at \n to stem m.err -------------------*/
errMsg: procedure expose m.
parse arg msg
m.err_cat = 'f'
do while substr(msg, 2, 1) == '}'
parse var msg m.err_cat '}' msg
end
if m.err_cat == ' ' | m.err_cat == 'o' then
return msg
pTxt = ',fatal error,error,input error,scanErr,warning,onlyMsg,'
px = pos(','m.err_cat, pTxt)
if px < 1 then do
px = 1
m.err_cat = 'f'
end
pre = substr(pTxt, px+1, pos(',', pTxt, px+2)-px-1)
if m.err_cat == 's' then
return pre msg
parse source . . s3 . /* current rexx */
return pre 'in' s3':' msg
endProcedure errMsg
splitNL: procedure expose m.
parse arg st, msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
m.st.lx = substr(msg, bx, ex-bx)
bx = ex+2
end
m.st.lx = substr(msg, bx)
m.st.0 = lx
return st
endProcedure splitNL
outNL: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
call out substr(msg, bx, ex-bx)
bx = ex+2
end
call out substr(msg, bx)
return
endProcedure outNL
/*--- say (part of) the lines of a stem ----------------------------*/
sayNl: procedure expose m.
parse arg msg
bx = 1
do lx=1 to 20
ex = pos('\n', msg, bx)
if ex < bx then
leave
say strip(substr(msg, bx, ex-bx), 't')
bx = ex+2
end
say strip(substr(msg, bx), 't')
return 0
endProcedure sayNl
/*--- say a trace message if m.trace is set --------------------------*/
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug:' msg
return
endProcedure debug
/*--- output a trace if m.trace is set -------------------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'if ('arg(1)') == 1 then return 1'
interpret 'call err' quote('assert failed' arg(1) ':' arg(2) '==>'),
arg(2)
endProcedure assert
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg
call errSay 'i}'msg
call help 0
call err 'i}'msg
endProcedure errHelp
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse arg doClear
if doClear \== 0 then
address tso 'clear'
parse source . . s3 .
say right(' help for rexx' s3, 72, '*')
do lx=1 while pos('/*', sourceLine(lx)) < 1
if lx > 10 then
return err('initial commentblock not found for help')
end
doInc = 1
ho = m.err.helpOpt
do lx=lx+1 to sourceline() while pos('*/', sourceline(lx)) = 0
li = strip(sourceLine(lx), 't')
cx = lastPos('{', li)
if cx > 0 then do
if length(ho) = 1 then
doInc = cx = length(li) | pos(ho, li, cx+1) > 0
li = left(li, cx-1)
end
if doInc then
say li
end
say right(' end help for rexx' s3, 72, '*')
return 4
endProcedure help
/* copy err end *****************************************************/
/* copy ut begin *****************************************************/
utIni: procedure expose m.
if m.ut_ini == 1 then
return
m.ut_ini = 1
m.ut_digits = '0123456789'
/* 012345678901234567890123456789 */
m.ut_lc = 'abcdefghijklmnopqrstuvwxyz'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_uc = translate(m.ut_lc)
m.ut_Alfa = m.ut_lc || m.ut_uc
m.ut_alfNum = m.ut_alfa || m.ut_digits
m.ut_alfDot = m.ut_alfNum || '.'
m.ut_alfId = m.ut_alfNum'_' /* avoid rexx allowed @ # $ ¬ . | ? */
m.ut_alfIdN1 = m.ut_digits /* not as first character */
m.ut_rxId = m.ut_AlfNum'@#$?' /* charset puff mit ¬*/
m.ut_rxDot = '.'m.ut_rxId
m.ut_rxN1 = '.0123456789'
m.ut_alfPrint = m.ut_alfNum'+-*/=()[]{}<> .:,;?|''"%&#@$£\_'
m.ut_ucNum = m.ut_uc || m.ut_digits
m.ut_base64 = m.ut_uc || m.ut_lc || m.ut_digits'+-'
m.ut_alfLC = m.ut_lc /* backward compatibility */
m.ut_alfUC = m.ut_uc /* backward compatibility */
return
endProcedure utIni
/*--- if function warning all3 arguments get evaluated|
e.g if(x=0, 'infinity', 1/0) will fail| -----------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/*--- embedded ASSignement:
assign the second argument to the variable with name in first arg
and return the value assigned ----------------------------------*/
ass:
call value arg(1), arg(2)
return arg(2)
/*--- embedded ASSignement return NotNull:
assign the second argument to the variable with name in first arg
and return 1 if value not null, 0 if null ----------------------*/
assNN:
call value arg(1), arg(2)
return arg(2) \== ''
/*--- return current time and cpu usage ------------------------------*/
utTime: procedure expose m.
return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
/*--- sleep several seconds ------------------------------------------*/
sleep: procedure expose m.
parse arg secs, sayIt
if sayit <> 0 then
say 'sleeping' secs 'secs' time()
CALL SYSCALLS 'ON'
ADDRESS SYSCALL "sleep" secs
CALL SYSCALLS 'OFF'
if sayit <> 0 then
say 'slept' secs 'secs' time()
return
endProcedure sleep
/*--- left without truncation ----------------------------------------*/
lefPad: procedure expose m
parse arg s, len
if length(strip(s, 't')) >= len then
return strip(s, 't')
return left(s, len)
endProcedure lefPad
/*--- right without truncation ---------------------------------------*/
rigPad: procedure expose m
parse arg s, len
if length(strip(s, 'l')) >= len then
return strip(s, 'l')
return right(s, len)
endProcedure rigPad
/*--- quote string txt using quoteChar qu ("" ==> ") -----------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- translate to lowercase -----------------------------------------*/
ut2lc: procedure expose m.
parse arg s
return translate(s, m.ut_lc, m.ut_uc)
/*--- verify an id ---------------------------------------------------*/
verifId: procedure expose m.
parse arg src, extra
if pos(left(src, 1), m.ut_alfIdN1) > 0 then
return 1
else
return verify(src, m.ut_alfId || extra, 'n')
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure expose m.
parse arg needle, hayStack, start, fin
if start = '' then
start = 1
if fin = '' then
fin = length(hayStack) + 1 - length(needle)
do cnt = 0 by 1
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
start = start + length(needle)
end
endProcedure posCount
repAll: procedure expose m.
parse arg src
do ax = 2 by 2 to arg()
src = repAl2(src, src, arg(ax), arg(ax+1))
end
return src
endProcedure repAll
repAl2: procedure expose m.
parse arg src, sPos, old, new
res = ''
cx = 1
do forever
nx = pos(old, sPos, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(old)
end
endProcedure repAl2
repAllWords: procedure expose m.
parse arg src, w, new
res = ''
wx = 0
cx = 1
do forever
wx = wordPos(w, src, wx+1)
if wx < 1 then
return res || substr(src, cx)
nx = wordindex(src, wx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAllWords
utc2d: procedure expose m.
parse arg ch
cx = length(ch) // 3
if cx = 0 then
cx = 3
res = c2d(left(ch, cx))
do cx=cx+1 by 3 to length(ch)
res = res * 16777216 + c2d(substr(ch, cx, 3))
end
return res
utInter: procedure expose m.
interpret arg(1)
return
endProcedure utInter
/* copy ut end ********************************************************/