zOs/REXX/QUERYDEL
/* rexx ****************************************************************
delete old rows from dsn_query_table
with commits for each queryNo
--- history ------------------------------------------------------------
6. 4.10 w.keller neud
***********************************************************************/
call jIni
call errReset 'hI'
call sqlConnect DBTF
tb = 'CMNBATCH.DSN_QUERY_TABLE_REORG'
qFirst = -999000
qNo = qFirst
del = 0
do forever
c = sqlPreAllCl(1, 'select queryno from' tb ,
'where queryNo >' qNo ,
'order by queryNo fetch first row only',
, st, ':qNo')
if c \== 1 then
leave
call sqlExec 'delete from' tb ,
'where queryNo =' qNo,
'and explain_time < current timestamp - 1 month',
, 100
call sqlCommit
del = del + sqlErrd.3
say 'qNo' qNo 'deleted' sqlErrd.3 'total' del
end
call sqlDisconnect
say 'qNo' qFirst '-' qNo 'deleted' del
exit
/*--- main code wsh --------------------------------------------------*/
call errReset 'hI'
parse arg spec
os = errOS()
if spec = '' & os == 'TSO' then do /* z/OS edit macro */
parse value wshEditMacro() with done spec
if done then
return
end
spec = wshFun(spec)
if spec == '$' then
return
call wshIni
inp = ''
out = ''
if os == 'TSO' then do
if sysvar('sysEnv') = 'FORE' then do
end
else do
inp = '-wsh'
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
end
end
else if os == 'LINUX' then do
inp = '&in'
out = '&out'
end
else
call err 'implemnt wsh for os' os
call compRun spec, inp, out
exit 0
wshFun: procedure expose m.
parse arg fun rest
call scanIni
f1 = translate(fun)
sx = verify(f1, m.scan.alfNum)
if sx = 2 | sx = 1 then do
f1 = left(f1, 1)
rest = substr(fun, 2) rest
end
if f1 = 'T' then
call wshTst rest
else if f1 = 'I' then
call wshInter rest
else if f1 = '?' then
return 'call pipePreSuf' rest '$<$#='
else
return arg(1)
return '$'
endProcedure wshFun
tstSqlO1: procedure expose m.
call sqlOIni
call sqlConnect dbaf
sq = sqlSel("select strip(name) from sysibm.sysTables",
"where creator='SYSIBM' and name like 'SYSTABL%'",
"order by 1")
do 2
call jOpen sq, m.j.cRead
do while jRead(sq, abc)
call outO abc
end
call jClose sq
end
call sqlDisconnect
return 0
endProcedure tstSqlO1
/*--- actual test case ----------------------------------------------*/
wshIni: procedure expose m.
call compIni
call sqlOIni
return
endProcedure wshIni
wshTst: procedure expose m.
parse arg rest
if rest = '' then do /* default */
call tstSqlO1
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
return 0
endProcedure wshTst
/*--- compRun: compile shell or data from inp and
run it to output out -----------------------------------*/
compRun: procedure expose m.
parse arg spec, inp, out
return compRunO(spec, s2oNull(inp), s2oNull(out))
endProcedure compRun
compRunO: procedure expose m.
parse arg spec, inO, ouO
cmp = comp(o2File(inO))
r = compile(cmp, spec)
if ouO \== '' then
call pipeBeLa '>' ouO
call oRun r
if ouO \== '' then
call pipeEnd
return 0
endProcedure compRun
/*--- interpret user input: rexx, expr, data or shell ---------------*/
wshInter: procedure expose m.
parse arg inp
call wshIni
inp = strip(inp)
mode = '*'
do forever
if pos(left(inp, 1), '|:*@.-=') > 0 then
parse var inp mode 2 inp
if mode == '|' then
return
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)),
, translate(mode, 'ds', 'DS'))
call errReset 'h'
end
end
say 'enter' mode 'expression, | for end, : or * for Rexx' ,
'@ . - = for wsh'
parse pull inp
end
endProcedure wshInter
/*--- batch under tso: input dd(WSH), output dd(OUT) if allocated ---*/
wshBatchTSO: procedure expose m.
parse upper arg ty
useOut = listDsi('OUT FILE')
if \ (useOut = 16 & sysReason = 2) then
out = '-out'
else
out = ''
call wshBatch ty, '-wsh', out
return 0
endProcedure wshBatchTso
/*--- if we are called
not as editmacro return 0
as an editmacro with arguments: return 0 arguments
without arguments: run editMacro interface ------------------*/
wshEditMacro: procedure expose m.
if sysvar('sysISPF') \= 'ACTIVE' then
return 0
if adrEdit('macro (mArgs) NOPROCESS', '*') \== 0 then
return 0
spec = wshFun(mArgs)
if spec == '$' then
return 1
if spec == '' & dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then do
call tstAct
return 0
end
call wshIni
o = jOpen(jBuf(), '>')
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
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
end
else do
dst = ''
say 'no dest'
if adrEdit("find first '$#out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
call jWrite o, left(li, 50) date('s') time()
end
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 */
i = jOpen(jBuf(), m.j.cWri)
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(jClose(i))
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, spec)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call pipeBegin
call oRun r
call pipeLast '>' o
do while inO(obj)
call objOut(obj)
end
call pipeEnd
lab = wshEditInsLinSt(dst, 0, , o'.BUF')
if dst \= '' then
call wshEditLocate max(1, dst-7)
return 1
endProcedure wshEditMacro
wshEditLocate: procedure
parse arg ln
call adrEdit '(la) = linenum .zl'
if la < 40 then
return
if ln < 7 then
ln = 1
else
ln = min(ln, la - 40)
call adrEdit 'locate ' ln
return
endProcedure wshEditLocate
wshEditCompErrH: procedure expose m.
parse arg ggTxt, rFi, rLa
call errReset 'h'
call outPush mCut(ggStem, 0)
call errSay 'compErr' ggTxt
call outPop
do sx=1 to m.ggStem.0
call out m.ggStem.sx
end
parse var m.ggStem.3 "pos " pos . " in line " lin":"
if pos = '' then do
parse var m.ggStem.3 " line " lin":"
pos = 0
end
lab = rFi + lin
if pos \= '' then
lab = wshEditInsLin(lab, 'msgline', right('*',pos))
lab = wshEditInsLinSt((rFi+lin),0, 'msgline', ggStem)
call wshEditLocate rFi+lin-25
exit 0
endSubroutine wshEditCompErrH
wshEditRunErrH: procedure expose m.
parse arg ggTxt, so, dst
call errReset 'h'
call errSay ggTxt, '*** run error'
lab = wshEditInsLinSt(dst, 1, , so'.BUF')
call outPush mCut(ggStem, 0)
call errSay ggTxt, '*** run error'
call wshEditInsLinSt dst, 1, msgline, ggStem
exit 0
endSubroutine wshEditRunErrH
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
iterate
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 ****************************************/
/* copy tstAll begin *************************************************/
tstAll: procedure expose m.
call tstBase
call tstComp
call tstDiv
call tstZos
return 0
endProcedure tstAll
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql /* wkTst??? noch einbauen|||
call tstSqlO
call tstSqlEnv */
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
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, 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
/* copx tstZos end **************************************************/
/* copx tstZos begin **************************************************/
tstZOs:
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
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
call outtrap x., '*'
call adrTso "listcat volume entry('"dsn"')", 4
rt = rc
call outtrap off
/* say 'listct rc =' rt 'lines' x.0 */
cl = ''
vo = ''
if word(x.1, 3) \== dsn then
call out 'err ??? for dsn' dsn 'bad first line' x.1
else if pos('NOT FOUND', x.1) > 0 then
return 'notFound'
else if word(x.1, 1)\== 'NONVSAM' then
call out 'err ??? for dsn' dsn 'bad first line' x.1
do x=2 to x.0 while vo = '' & left(x.x, 1) = ' '
/* say x.x */
p = pos('MANAGEMENTCLASS-', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+16), 1), 'l', '-')
p = pos('VOLSER--', x.x)
if p > 0 then
vo = strip(word(substr(x.x, p+6), 1), 'l', '-')
p = pos('DEVCLASS--', x.x)
dt = strip(word(substr(x.x, 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
/* copx tstZos end **************************************************/
/* copx tstDiv begin **************************************************/
tstDiv:
call tstSorQ
call tstSort
call tstMatch
call tstTotal
return
endProcedure tstDiv
tstSorQ: procedure expose m. /* wkTst??? remove once upon a time */
/*<<tstSorQ
### start tst tstSorQ #############################################
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
tstSorQ */
/*<<tstSorQAscii
### start tst tstSorQAscii ########################################
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
tstSorQAscii */
if errOS() == 'LINUX' then
call tst t, "tstSorQAscii"
else
call tst t, "tstSorQ"
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
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
call tstEnd t
return
endProcedure tstSorQ
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
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 errOS() == '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
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
match(einss, e?n *) 0 0 -9
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
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
tstMatch */
call tst t, "tstMatch"
call tstOut t, matchTest1('eins', 'e?n*' )
call tstOut t, matchTest1('eins', 'eins' )
call tstOut t, matchTest1('e1nss', 'e?n*', '?*' )
call tstOut t, matchTest1('eiinss', 'e?n*' )
call tstOut t, matchTest1('einss', 'e?n *' )
call tstOut t, matchTest1('ein s', 'e?n *' )
call tstOut t, matchTest1('ein abss ', '?i*b*' )
call tstOut t, matchTest1('ein abss wie gehtsssxdirx und auch ' )
call tstOut t, matchTest1('ies000', '*000' )
call tstOut t, matchTest1('xx0x0000', '*000' )
call tstOut t, matchTest1('000x00000xx', '000*' )
call tstOut t, matchTest1('000xx', '*0*', 'ab*cd*ef' )
call tstEnd t
return
matchTest1:
parse arg w, m, m2
r = 'match('w',' m')' match(w, m) match(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)
if m.vv.0 >= 0 then
r = r 'trans('m2')' matchTrans(m2, vv)
return r
endProcedure matchTest1
/* copx tstDiv end **************************************************/
/* copx tstSql begin **************************************************/
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 49, '*', cc, 'select max(pri) MX from' tb
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 sqlExImm 'commit'
say timing()
call sqlDisconnect
return
endProcedure tstSqlTriggerTiming
tstSql: procedure expose m.
cx = 2
call sqlIni
call jIni
/*<<tstSql
### start tst tstSql ##############################################
*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAME .
. e 1: warnings
. e 2: state 42704
. e 3: stmt = execSql prepare s7 from :src
. e 4: with src = select * from sysdummy
fetchA 1 ab= m.abcdef.123.AB abc ef= efg
fetchA 0 ab= m.abcdef.123.AB abc ef= efg
sqlVars :M.STST.A :M.STST.A.SQLIND, :M.STST.B :M.STST.B.SQLIND, :M.+
STST.C :M.STST.C.SQLIND
1 all from dummy1
a=a b=2 c=0
sqlVarsNull 1
a=a b=2 c=---
fetchBT 1 SYSTABLES
fetchBT 0 SYSTABLES
fetchBI 1 SYSINDEXES
fetchBI 0 SYSINDEXES
opAllCl 3
fetchC 1 SYSTABLES
fetchC 2 SYSTABLESPACE
fetchC 3 SYSTABLESPACESTATS
PreAllCl 3
fetchD 1 SYSIBM.SYSTABLES
fetchD 2 SYSIBM.SYSTABLESPACE
fetchD 3 SYSIBM.SYSTABLESPACESTATS
tstSql */
call tst t, "tstSql"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sqlPrepare cx, "select 'abc' , 'efg'",
'from sysibm.sysDummy1'
call sqlExec 'declare c'cx 'cursor for s'cx
call sqlOpen cx
a = 'abcdef'
b = 123
do i=1 to 2
call out 'fetchA' sqlFetchInto(cx, ':m.a.b.ab, :m.a.b.ef') ,
'ab= m.'a'.' || b'.'ab m.a.b.ab 'ef=' m.a.b.ef
end
call sqlClose cx
drop stst a b c m.stst.a m.stst.b m.stst.c
sv = sqlVars('M.STST', A B C , 1)
call out 'sqlVars' sv
call out sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call out 'sqlVarsNull' sqlVarsNull(stst, A B C)
call out 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call sqlPreDeclare cx, "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name = ?"
call sqlOpen cx, 'SYSTABLES'
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call out 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call out 'fetchBI' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
src = "select name" ,
"from sysibm.sysTables" ,
"where creator = 'SYSIBM' and name like 'SYSTABLES%'",
"fetch first 3 rows only"
call sqlPreDeclare cx, src
st = 'wie geht'' s'
call out 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call out 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call out 'fetchD' x m.st.x.name
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSql
tstSqlO: procedure expose m.
call tst t, "tstSqlO",
, "*** err: sqlCode -204 A540769.SYSDUMMY IS AN UNDEFINED NAM",
|| "E ",
, " e 1: warnings",
, " e 2: state 42704",
, " e 3: stmt = execSql prepare s7 from :src",
, " e 4: with src = select * from sysdummy",
, "REQD=Y col=123 case=--- col5=anonym",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
src = 'select * from sysdummy'
call sqlExec 'prepare s7 from :src'
call sql2Cursor 13,
, 'select d.*, 123, current timestamp "jetzt und heute",',
'case when 1=0 then 1 else null end caseNull,',
"'anonym'" ,
'from sysibm.sysdummy1 d'
call sqlOpen 13
do while sqlFetch(13, abc)
call out 'REQD='m.ABC.IBMREQD 'col='m.ABC.col2,
'case='m.ABC.CASENULL,
'col5='m.ABC.col5
je = 'jetzt'
jetzt = m.ABC.je
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
say 'jetzt='jetzt 'date time' dd
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call sqlClose 13
call sql2Cursor 13 ,
, 'select name, class, dbName, tsName' ,
/* ,alteredTS, obid, cardf'*/ ,
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 5 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
call sqlGenFmt m.sql.13.fmt, 13, 'sst'
call sqlOpen 13
do ix=1 while sqlFetch(13, fe.ix)
end
m.fe.0 = ix-1
call fmtFldSquash sqFmt, sqlClass(13), fe
call out fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call out oFldCat(sqlClass(13), fe.ix, sqFmt)
end
call sqlClose 13
if 0 then do
call sql2Cursor 13 ,
, 'select *',
'from sysibm.systables' ,
"where creator = 'SYSIBM' and name like 'SYSTA%'" ,
"fetch first 1 rows only",
, , 'sl<15'
call sqlOpen 13
call out fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call out m.li
end
call sqlClose 13
end
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlO
tstSqlEnv: procedure expose m.
call tst t, "tstSqlEnv",
, "REQD=Y COL2=123 case=--- COL5=anonym",
, "sql fmtFldRw sl<15",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE ",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE ",
, "SYSTABLEPART_HI T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE ",
, "sql fmtFldSquashRW",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn sl=",
, "COL1 T DBNAME COL4 ",
, "SYSTABAUTH T DSNDB06 SYSDBASE"
call mAdd t.cmp,
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_ T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE",
, "sqlLn ---",
, "NAME T DBNAME TSNAME ",
, "SYSTABAUTH T DSNDB06 SYSDBASE",
, "SYSTABCONST T DSNDB06 SYSOBJ ",
, "SYSTABLEPART T DSNDB06 SYSDBASE",
, "SYSTABLEPART_HIST T DSNDB06 SYSHIST ",
, "SYSTABLES T DSNDB06 SYSDBASE"
call sqlConnect 'DBAF'
call pipeBegin
call out 'select d.*, 123, current timestamp "jetzt und heute",'
call out 'case when 1=0 then 1 else null end caseNull,'
call out "'anonym'"
call out 'from sysibm.sysdummy1 d'
call pipe
call sql 13
call pipeLast
do while envRead(abc)
call out 'REQD='envGet('ABC.IBMREQD'),
'COL2='envGet('ABC.COL2'),
'case='envGet('ABC.CASENULL'),
'COL5='envGet('ABC.COL5')
jetzt = envGet('ABC.jetzt')
say 'jetzt='jetzt
dd = date('s')
dd = left(dd, 4)'-'substr(dd, 5, 2)'-'right(dd, 2)'-' ,
|| left(time(), 2)'.'
if \ abbrev(jetzt, dd) then
call err 'date mismatch abbrev' dd
end
call pipeEnd
call out 'sql fmtFldRw sl<15'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call pipeEnd
call out 'sql fmtFldSquashRW'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipe
call sql 13
call pipeLast
call fmtFldSquashRW
call pipeEnd
call out 'sqlLn sl='
call pipeBegin
call out 'select char(name, 13), class, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13, , ,'sl='
call pipeEnd
call out 'sqlLn ---'
call pipeBegin
call out 'select name, class, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call out 'from sysibm.systables'
call out "where creator = 'SYSIBM' and name like 'SYSTA%'"
call out "fetch first 5 rows only"
call pipeLast
call sqlLn 13
call pipeEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
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 tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstCompSyntax
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)), '+')
cmp = comp(src)
call out 'compile' spec',' (m.src.buf.0) 'lines:' m.src.buf.1
r = compile(cmp, spec)
noSyn = m.t.errHand = 0
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.
/*<<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 envRemove '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
tstCompExprCon */
/* wkTst sinnvolle Erweiterung ???
call tstComp1 '# tstCompExprCon',
, '$=vv=vvCon' ,
, 'call out "vv="$vv',
, 'call out $"o2string($.$vv)="o2string($.$vv)'
*/
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 envPutO 'oRun', oRunner('call out "oRun ouput" (1*1)')
call envRemove '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""' /* String am schluss -> $$ "" statment||||| */
/*<<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'
/*<<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/'
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 pipe or $; expected: compile shell stopped before+
. end of input
. e 1: last token scanPosition $ =
. e 2: pos 3 in line 1: a $ =
tstCompSynPri1 */
call tstComp1 '@ tstCompSynPri1 +', 'a $ ='
/*<<tstCompSynPri2
### start tst tstCompSynPri2 ######################################
compile @, 1 lines: a $. {
*** err: scanErr objRef expected after $. expected
. e 1: last token scanPosition {
. e 2: pos 5 in line 1: a $. {
tstCompSynPri2 */
call tstComp1 '@ tstCompSynPri2 +', 'a $. {'
/*<<tstCompSynPri3
### start tst tstCompSynPri3 ######################################
compile @, 1 lines: b $- [ .
*** err: scanErr objRef expected after $- expected
. e 1: last token scanPosition [
. e 2: pos 5 in line 1: b $- [
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 block or expr expected for file expected
. e 1: last token scanPosition $$abc
. e 2: pos 18 in line 1: $@$.<$*( co1 $*) $$abc
tstCompSynFile */
call tstComp1 '@ tstCompSynFile +', '$@$.<$*( co1 $*) $$abc'
return
endProcedure tstCompSynPrimary
tstCompSynAss: procedure expose m.
/*<<tstCompSynAss1
### start tst tstCompSynAss1 ######################################
compile @, 1 lines: $=
*** err: scanErr variable name after $= expected
. 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 variable name after $= expected
. 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 variable name after $= expected
. e 1: last token scanPosition $$
. e 2: pos 6 in line 1: $= $$
tstCompSynAss3 */
call tstComp1 '@ tstCompSynAss3 +', '$= $$', 'eins'
/*<<tstCompSynAss4
### start tst tstCompSynAss4 ######################################
compile @, 1 lines: $= eins
*** err: scanErr = expected after $= "eins"
. e 1: last token scanPosition .
. e 2: pos 10 in line 1: $= eins
tstCompSynAss4 */
call tstComp1 '@ tstCompSynAss4 +', '$= eins'
/*<<tstCompSynAss5
### start tst tstCompSynAss5 ######################################
compile @, 1 lines: $= abc eins $$ = x
*** err: scanErr = expected after $= "abc eins"
. e 1: last token scanPosition $$ = x
. e 2: pos 14 in line 1: $= abc eins $$ = x
tstCompSynAss5 */
call tstComp1 '@ tstCompSynAss5 +', '$= abc eins $$ = x'
/*<<tstCompSynAss6
### start tst tstCompSynAss6 ######################################
compile @, 1 lines: $= abc =
*** err: scanErr block or expression after $= "abc" = expected
. 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 after $= "abc" = expected
. 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 objRef expected after $@ expected
. e 1: last token scanPosition .
. e 2: pos 3 in line 1: $@
tstCompSynRun1 */
call tstComp1 '@ tstCompSynRun1 +', '$@'
/*<<tstCompSynRun2
### start tst tstCompSynRun2 ######################################
compile @, 1 lines: $@=
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@=
tstCompSynRun2 */
call tstComp1 '@ tstCompSynRun2 +', '$@='
/*<<tstCompSynRun3
### start tst tstCompSynRun3 ######################################
compile @, 1 lines: $@ =
*** err: scanErr objRef expected after $@ expected
. e 1: last token scanPosition =
. e 2: pos 3 in line 1: $@ =
tstCompSynRun3 */
call tstComp1 '@ tstCompSynRun3 +', '$@ ='
/*<<tstCompSynFor4
### start tst tstCompSynFor4 ######################################
compile @, 1 lines: $@for
*** err: scanErr variable name 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 variable name 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 name after $@for expected
. e 1: last token scanPosition $$q
. e 2: pos 12 in line 2: b $@for $$q
tstCompSynFor6 */
call tstComp1 '@ tstCompSynFor6 +', 'a', ' b $@for $$q'
/*<<tstCompSynFor7
### start tst tstCompSynFor7 ######################################
compile @, 3 lines: a
*** err: scanErr statement after $@for "a" 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 proc name expected
. e 1: last token scanPosition $$q
. e 2: pos 12 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: $@call (roc p1)
*** err: scanErr procCall, for, do, ct, proc or objRef expected aft+
er $@
. e 1: last token scanPosition (roc p1)
. e 2: pos 7 in line 1: $@call (roc p1)
tstCompSynCallB */
call tstComp1 '@ tstCompSynCallB +', '$@call (roc p1)'
/*<<tstCompSynCallC
### start tst tstCompSynCallC #####################################
compile @, 1 lines: $@call( roc p1 )
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition roc p1 )
. e 2: pos 9 in line 1: $@call( roc p1 )
tstCompSynCallC */
call tstComp1 '@ tstCompSynCallC +', '$@call( roc p1 )'
/*<<tstCompSynCallD
### start tst tstCompSynCallD #####################################
compile @, 2 lines: $@call( $** roc
*** err: scanErr closing ) expected after $@call(
. e 1: last token scanPosition .
. e 2: pos 16 in line 1: $@call( $** roc
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 union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei2
out .[ o3 $]
tstR: @<o3> isA :tstCompCla union = o3
tstR: .FEINS = o3.fEins
tstR: .FZWEI = o3.2
out .[ o4 $]
tstR: @<o4> isA :tstCompCla union = o4
tstR: .FEINS = o4.1
tstR: .FZWEI = o4.fZwei4
out ./-/ o5 $/-/
tstR: @<o5> isA :tstCompCla union = o5
tstR: .FEINS = o5.fEins
tstR: .FZWEI = o5.2
tstCompObjRef */
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 union = 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 union = 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 union = 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 outO 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: @LINE isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstWriteO kindOf JRW jWriteNow end >>>
out .<$.-{o2}
tstWriteO kindOf JRW jWriteNow begin <<<
tstR: @LINE isA :tstCompCla union = 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: @LINE isA :tstCompCla union = 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 outO m.tstComp.4 }',
, '$$ out .$"$<@[$$abc $$efg$]" $$.$.<@[ $$abc ', ' ', ' $$efg $]'
/*<<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 union = 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
return
/*<<tstCompObj
### start tst tstCompObj ##########################################
compile @, 8 lines: o1=m.tstComp.1
run without input
out . o1
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
out .{ o2 }
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
out .[ o1, o2]
tstR: @<o1> isA :tstCompCla union = o1
tstR: .FEINS = o1.fEins
tstR: .FZWEI = o1.2
tstR: @<o2> isA :tstCompCla union = o2
tstR: .FEINS = o2.1
tstR: .FZWEI = o2.fZwei
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
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 = 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 envPut 'dsn', dsn
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
$@<{ $*+.
}
{{{ 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 =, 70 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: @LINE isA :TstClassVF union = v-Eins
tstR: .FLD1 = 1-Eins
...file from 2 line . block
tstR: @LINE isA :TstClassVF union = v-Elf
tstR: .FLD1 = 1-Elf
tstR: @LINE isA :TstClassVF union = val=zwoelf
tstR: .FLD1 = FLD1=zwoelf
...file from 3 line . block
tstR: @LINE isA :TstClassVF union = val=einUndDreissig
tstR: .FLD1 = FLD1=einUndDreissig
zweiUndDreissig value-of-vv
tstR: @LINE isA :TstClassVF union = 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: @LINE isA :TstClassVF union = w-Eins
tstR: .FLD1 = w1-Eins
@@@file from 2 line @ block
tstR: @LINE isA :TstClassVF union = w-Elf
tstR: .FLD1 = w1-Elf
zwoelf
@@@file from 3 line @ block
tstR: @LINE isA :TstClassVF union = 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: @LINE isA :TstClassVF union = val=f2 line2
tstR: .FLD1 = FLD1=f2 line2
---file with 2 lines $@<$f2
f2 line 1 value-vv-2
tstR: @LINE isA :TstClassVF union = 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
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 2+
4 ... 29|>
output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?>yz ab<zw+
anzig 21 22 23 24 ... 29|>yz
tstCompRedir */
call pipeIni
call envRemove 'eins' /* alte Variable loswerden */
dsn = word(tstPdsMbr(tstFilename('libvb', 'r'), 'redir1'), 1)
call envPut '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$] '
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
$#. 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, 6 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 envPut '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 $"$@$#-"
$@$#-
$'zeile drei nach $@$#- v1='v1
vierte und letzte Zeile
tstCompDirPiSrc */
/*<<tstCompDirPi
### start tst tstCompDirPi ########################################
compile call pipePreSuf '<','>' $=v1=eiPi $<.$.$#=, 5 lines: zeile +
1 v1=$v1
run without input
<zeile 1 v1=eins>
<zweite Zeile vor $@$#->
<zeile drei nach $@$#- v1=V1>
<VIERTE UND LETZTE ZEILE>
tstCompDirPi */
call tstComp2 'tstCompDirPi',
, "call pipePreSuf '<','>' $=v1=eiPi $<.$.$#="
return
endProcedure tstCompDir
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstTstSay
call oIni
call tstM
call tstMap
call tstMapVia
call tstClass
call tstClass2
call tstO
call jIni
call tstJSay
call tstJ
call tstJ2
call catIni
call tstCat
call pipeIni
CALL TstEnv
CALL TstEnvCat
call tstPipe
call tstEnvVars
call tstTotal
call tstPipeLazy
call tstEnvClass
call tstFile /* reimplent zOs ||| */
call tstFileList
call tstFmt
call tstTotal
call scanIni
call tstScan
call ScanReadIni
call tstScanRead
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 */
call tst x, 'tstTstSayEins'
call tstOut x, "test eins einzige testZeile"
call tstEnd x, 'err 0'
/*<<tstTstSayZwei
### start tst tstTstSayZwei #######################################
zwei 1. testZeile
zwei 2. und letzte testZeile
tstTstSayZwei */
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'
/*<<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 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
tstM: procedure expose m.
/*<<tstM
### start tst tstM ################################################
symbol m.b LIT
mInc b 2 m.b 2
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
tstMSubj1 tstMSubj1 added listener 1
tstMSubj1 notified list1 1 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 11
tstMSubj1 tstMSubj1 added listener 2
tstMSubj1 notified list2 2 arg tstMSubj1 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 12
tstMSubj1 notified list2 2 arg tstMSubj1 notify 12
tstMSubj2 tstMSubj2 added listener 1
tstMSubj2 notified list1 1 arg tstMSubj2 registered list
tstMSubj2 tstMSubj2 added listener 2
tstMSubj2 notified list2 2 arg tstMSubj2 registered list
tstMSubj1 notified list1 1 arg tstMSubj1 notify 13
tstMSubj1 notified list2 2 arg tstMSubj1 notify 13
tstMSubj2 notified list1 1 arg tstMSubj2 notify 24
tstMSubj2 notified list2 2 arg tstMSubj2 notify 24
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, 'mInc b' mInc(b) 'm.b' m.b
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
s1 = 'tstMSubj1'
s2 = 'tstMSubj2'
/* we must unregister for the second test */
drop m.m.subLis.s1 m.m.subLis.s1.0 m.m.subLis.s2 m.m.subLis.s2.0
call mRegisterSubject s1,
, 'call tstOut t, "'s1'" subject "added listener" listener;',
'call mNotify1 "'s1'", listener, "'s1' registered list"'
call mRegister s1,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mNotify s1, s1 'notify 11'
call mRegister s1,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list1" listener "arg" arg'
call mRegister s2,
, 'call tstOut t, subject "notified list2" listener "arg" arg'
call mNotify s1, s1 'notify 12'
call mRegisterSubject s2,
, 'call tstOut t, "'s2'" subject "added listener" listener;',
'call mNotify1 "'s2'", listener, "'s2' registered list"'
call mNotify s1, s1 'notify 13'
call mNotify s2, s2 'notify 24'
call tstEnd t
return
endProcedure tstM
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 key eins in map m
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 key zwei in map m
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 nicht gefunden
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',
, 'nicht gefunden')
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.
/*<<tstClass2old
### start tst tstClass2 ###########################################
@CLASS.8 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.7 :class union
. choice u stem 9
. .1 refTo @CLASS.15 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.16 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.11 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.10 :class union
. choice r .CLASS refTo @CLASS.8 done :class @CLASS.8
. .3 refTo @CLASS.17 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.11 done :class @CLASS.11
. .4 refTo @CLASS.19 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.18 :class union
. choice s .CLASS refTo @CLASS.10 done :class @CLASS.10
. .5 refTo @CLASS.20 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.12 :class union
. choice u stem 2
. .1 refTo @CLASS.9 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.11 done :class @CLASS.11
. .6 refTo @CLASS.21 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .7 refTo @CLASS.22 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.12 done :class @CLASS.12
. .8 refTo @CLASS.23 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.14 :class union
. choice u stem 2
. .1 refTo @CLASS.9 done :class @CLASS.9
. .2 refTo @CLASS.13 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .9 refTo @CLASS.26 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.25 :class union
. choice n union
. .NAME = w
. .CLASS refTo @CLASS.24 :class union
. choice r .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2old */
/*<<tstClass2
### start tst tstClass2 ###########################################
@CLASS.13 isA :class union
. choice n union
. .NAME = class
. .CLASS refTo @CLASS.12 :class union
. choice u stem 10
. .1 refTo @CLASS.20 :class union
. choice c union
. .NAME = v
. .CLASS refTo @CLASS.3 :class union
. choice v = v
. .2 refTo @CLASS.22 :class union
. choice c union
. .NAME = w
. .CLASS refTo @CLASS.21 :class union
. choice w } LASS.21
. .3 refTo @CLASS.23 :class union
. choice c union
. .NAME = o
. .CLASS refTo @CLASS.10 :class union
. choice o obj has no class @o
. .4 refTo @CLASS.24 :class union
. choice c union
. .NAME = r
. .CLASS refTo @CLASS.16 :class union
. choice f union
. .NAME = CLASS
. .CLASS refTo @CLASS.15 :class union
. choice r .CLASS refTo @CLASS.13 done :class @CLASS.13
. .5 refTo @CLASS.25 :class union
. choice c union
. .NAME = s
. .CLASS refTo @CLASS.16 done :class @CLASS.16
. .6 refTo @CLASS.27 :class union
. choice c union
. .NAME = u
. .CLASS refTo @CLASS.26 :class union
. choice s .CLASS refTo @CLASS.15 done :class @CLASS.15
. .7 refTo @CLASS.28 :class union
. choice c union
. .NAME = f
. .CLASS refTo @CLASS.17 :class union
. choice u stem 2
. .1 refTo @CLASS.14 :class union
. choice f union
. .NAME = NAME
. .CLASS refTo @CLASS.3 done :class @CLASS.3
. .2 refTo @CLASS.16 done :class @CLASS.16
. .8 refTo @CLASS.29 :class union
. choice c union
. .NAME = n
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .9 refTo @CLASS.30 :class union
. choice c union
. .NAME = c
. .CLASS refTo @CLASS.17 done :class @CLASS.17
. .10 refTo @CLASS.31 :class union
. choice c union
. .NAME = m
. .CLASS refTo @CLASS.19 :class union
. choice u stem 2
. .1 refTo @CLASS.14 done :class @CLASS.14
. .2 refTo @CLASS.18 :class union
. choice f union
. .NAME = MET
. .CLASS refTo @CLASS.3 done :class @CLASS.3
tstClass2 */
call oIni
call tst t, 'tstClass2'
call classOut , m.class.class
call tstEnd t
return
endProcedure tstClass2
tstClass: procedure expose m.
/*<<tstClass
### start tst tstClass ############################################
Q n =className= tstClassTf12
Q.eins.zwei v ==> M.Q.eins.zwei
*** err: basicClass v end of Exp expected: v tstClassTf12 .
R n =className= uststClassTf12
R n =className= uststClassTf12in
R n =className= tstClassTf12
R.eins.zwei v ==> M.R.eins.zwei
R s =stem.0= 2
R.1 r ==> M.R.1
R.1 n =className= tstClassTf12
R.1.eins.zwei v ==> M.R.1.eins.zwei
R.2 r ==> M.R.2
R.2 n =className= tstClassTf12
R.2.eins.zwei v ==> M.R.2.eins.zwei
S s =stem.0= 2
S.1.eins v ==> M.S.1.eins
S.1 m =met-metA--> say "metA"
S.1 m =met-metB--> say "metB"
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 f eins f zwei v')
call tstClassOut t, t1, q
z = m.class.0
errDef = 'n tstClassB n tstClassC u tstClassTf12,' ,
's u v tstClassTf12'
if class4name(errDef, ' ') == ' ' then
t2 = classNew(errDef)
else /* the second time we do not get the error anymore,
because the err did not abend | */
call tstOut t,'*** err: basicClass v' ,
'end of Exp expected: v tstClassTf12 '
t2 = classNew('n uststClassTf12 n uststClassTf12in u tstClassTf12',
, classNew('s u r, tstClassTf12'))
m.r.0 = 2
call tstClassOut t, t2, r
t3 = classNew('s 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 oMutate qq, 'tstClassTf12'
tt = objClass(qq)
call tstOut t, 'class of mutate qq' m.tt.name
call tstEnd t
return
endProcedure tstClass
tstClassOut: procedure expose m.
parse arg o, t, a
if pos(m.t, 'vr') > 0 then
return tstOut(o, a m.t '==>' m.a)
if m.t == 'n' then do
call tstOut o, a m.t '=className=' m.t.name
return tstClassOut(o, m.t.class, a)
end
if m.t == 'f' then
return tstClassOut(o, m.t.class, 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.class, a'.'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call tstClassOut o, m.t.class, 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
tstO: procedure expose m.
/*<<tstO
### start tst tstO ################################################
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 of object <obj e+
. of TstOEins>
*** err: no class found for object noObj
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>
methodcalls of object f cast To TstOEins
. met Eins.eins <obj f of TstOElf>
. met Eins.zwei <obj f of TstOElf>
FLDS of <cast(f, TstOEins)> .FEINS, .FZWEI
oCopy c1 of class TstOEins, c2
C1 n =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 n =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 n =className= TstOElf
C4 n =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
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
tstO */
call tst t, 'tstO'
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>'
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>'
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 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 tstOut t, 'methodcalls of object f cast To TstOEins'
call tstOmet oCast(f, 'TstOEins'), 'eins'
call tstOmet oCast(f, 'TstOEins'), 'zwei'
call tstOut t, 'FLDS of <cast(f, TstOEins)>',
mCat(oFlds(oCast(f, 'TstOEins')), ', ')
call oMutate 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 oMutate 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')
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 tstO
tstOmet: procedure expose m.
parse arg m, met
interpret objMet(m, met)
return
endProcedure tstOmet
tstJSay: procedure expose m.
/*<<tstJSay
### start tst tstJSay #############################################
*** err: call of abstract method jOpen(<obj j of JRW>, openArg)
*** err: jWrite(<obj j of JRW>, writeArg) but not opened w
*** err: can only write JRWOut.jOpen(<obj s of JRWOut>, open<Arg)
*** err: jWrite(<obj s of JRWOut>, write s vor open) but not opened+
. w
*** err: can only read JRWEof.jOpen(<obj e of JRWEof>, open>Arg)
*** err: jRead(<obj e of JRWEof>, XX) but not opened r
read e vor open 0 m.xx valueBefore
read e nach open 0 m.xx M.XX
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'
j = oNew('JRW')
call mAdd t'.TRANS', j '<obj j of JRW>'
call jOpen j, 'openArg'
call jWrite j, 'writeArg'
s = oNew('JRWOut')
call mAdd t'.TRANS', s '<obj s of JRWOut>'
call jOpen s, 'open<Arg'
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, 'open>Arg'
m.xx = 'valueBefore'
call tstOut t, 'read e vor open' jRead(e, xx) 'm.xx' m.xx
call jOpen e
call tstOut t, 'read e nach open' jRead(e, xx) 'm.xx' m.xx
call out 'out eins'
vv = 'readAdrVV'
m.vv = 'readAdrVVValueBefore'
call out 'out zwei in' in(vv) 'vv='vv
m.vv = 'readAdrVVValueBefore'
call out 'out drei in' in(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
*** err: already opened jOpen(<buf b>, <)
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(var)
call out lx 'in()' m.var
end
call out 'in()' (lx-1) 'reads vv' vv
call jWrite b, 'buf line one'
call mAdd m.b.stem, 'buf line two', 'buf line three'
call jWrite b, 'buf line four'
call jOpen b, '<'
call jClose b
call jOpen b, '<'
do while (jRead(b, line))
call out 'line' m.line
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: @CCC isA :<Tst?1 name> union
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: @CCC isA :<Tst?1 name> union
tstR: .EINS = feld eins
tstR: .ZWEI = feld zwei 2
tstR: .DREI = drei cat 2
tstJ2 */
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, m.ty.name
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call jOpen b, '>'
call jWriteO b, qq
m.qq.zwei = 'feld zwei 2'
call jWriteO b, qq
call jOpen jClose(b), '<'
c = jOpen(jBuf(), '>')
do xx=1 while jReadO(b, res)
call out 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWriteO c, res
end
call jOpen jClose(c), '<'
do while jReadO(c, ccc)
call out 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
call outO 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, v)
call tstOut t, 'catRead' lx m.v
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, v)
call tstOut t, 'appRead' lx m.v
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 pipeBeLa '<' b, '>' c
call out 'before writeNow 1 b --> c'
call pipeWriteNow
call out 'nach writeNow 1 b --> c'
call pipeEnd
call out 'after pipeEnd'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call pipeBeLa '>>' c
call out 'after push c only'
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c
call out 'before writeNow 2 c --> std'
call pipeWriteNow
call out 'nach writeNow 2 c --> std'
call pipeEnd
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 pipeBeLa '<' b0, '<' b1, '<' b2, '<' c2,'>>' c1
call out 'before writeNow 1 b* --> c*'
call pipeWriteNow
call out 'after writeNow 1 b* --> c*'
call pipeEnd
call out 'c1 contents'
call pipeBeLa '<' c1
call pipeWriteNow
call pipeEnd
call pipeBeLa '<' c2
call out 'c2 contents'
call pipeWriteNow
call pipeEnd
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 pipeBegin
call out '+1 nach pipeBegin'
call pipeWriteNow
call out '+1 nach writeNow vor pipe'
call pipe
call out '+2 nach pipe'
call pipeBegin
call out '+3 nach nested pipeBegin'
call pipePreSuf '(3 ', ' 3)'
call out '+3 nach preSuf vor nested pipeLast'
call pipeLast
call out '+4 nach nested pipeLast'
call pipePreSuf '(4 ', ' 4)'
call out '+4 nach preSuf vor nested pipeEnd'
call pipeEnd
call out '+5 nach nested pipeEnd vor pipe'
call pipe
call out '+6 nach pipe'
call pipeWriteNow
say 'out +6 nach writeNow vor pipeLast'
call out '+6 nach writeNow vor pipeLast'
call pipeLast
call out '+7 nach pipeLast'
call pipePreSuf '[7 ', ' 7]'
call out '+7 nach writeNow vor pipeEnd'
call pipeEnd
call out '+8 nach pipeEnd'
say 'xx' m.pipe.0
call tstEnd t
return
endProcedure tstPipe
tstEnvVars: procedure expose m.
call pipeIni
/*<<tstEnvVars
### start tst tstEnvVars ##########################################
put v1 value eins
v1 hasKey 1 get value eins
v2 hasKey 0
via v1.fld via value
one to theBur
two to theBuf
tstEnvVars */
call tst t, "tstEnvVars"
call envRemove 'v2'
m.tst.adr1 = 'value eins'
put1 = envPutO('v1', oMutate(tst'.'adr1, m.class.classV))
call tstOut t, 'put v1' m.put1
call tstOut t, 'v1 hasKey' envHasKey('v1') 'get' envGet('v1')
call tstOut t, 'v2 hasKey' envHasKey('v2')
if 0 then
call tstOut t, 'v2 get' envGet('v2')
m.put1.fld = 'via value'
call tstOut t, 'via v1.fld' envVia('v1|FLD')
call pipeBeLa '>' s2o('}theBuf')
call out 'one to theBur'
call out 'two to theBuf'
call pipeEnd
call pipeBeLa '<' s2o('}theBuf')
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstEnvVars
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 writeAllFramed *** +
.<class TstPipeLazyBuf>
a5 vor 2 writeAllFramed in inIx 0
a2 vor writeAllFramed jBuf
bufOpen <
jBuf line 1
jBuf line 2
bufClose
a3 vor writeAllFramed 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 writeAllFramed ***
b1 vor barBegin lazy 1 writeAllFramed *** <class TstPipeLazyRdr>
b4 vor writeAllFramed
b2 vor writeAllFramed rdr inIx 1
RdrOpen <
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 2# tst in line 2 zwei ; .
tst in line 2 zwei ; .
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn 3# tst in line 3 drei .schluss..
tst in line 3 drei .schluss..
*** err: jWrite(PIPE.framedNoOut, jRead lazyRdr) but not opened w
#jIn eof 4#
rdrClose
b3 vor barLast inIx 1
b5 vor barEnd inIx 4
b6 nach barEnd lazy 1 writeAllFramed ***
tstPipeLazy */
call tst t, "tstPipeLazy"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
ty = classNew('n TstPipeLazyBuf u JBuf', 'm',
, 'jOpen call tstOut "T", "bufOpen" opt;',
'return jOpen(oCast(m, "JBuf"), opt)',
, 'jClose call tstOut "T", "bufClose";',
'return jClose(oCast(m, "JBuf"), opt)')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyBuf>'
call out 'a1 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
call out 'a2 vor' w 'jBuf'
b = oMutate(jBuf('jBuf line 1','jBuf line 2'),
,'TstPipeLazyBuf')
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 pipeLast
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 pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
ty = classNew('n TstPipeLazyRdr u JRW', 'm',
, 'jOpen call tstOut "T", "RdrOpen" opt;m.m.jReading=1',
, 'jRead call out "jRead lazyRdr"; return in(var);',
, 'jClose call tstOut "T", "rdrClose";')
if \ lz then
call mAdd t'.TRANS', ty '<class TstPipeLazyRdr>'
r = oNew('TstPipeLazyRdr')
if lz then
call mAdd t'.TRANS', r '<lazyRdr>'
m.t.inIx = 2-lz
call out 'b1 vor barBegin lazy' lz w '***' ty
call pipeBegin
if lz then
call mAdd t'.TRANS', m.j.out '<barBegin out>'
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 pipeLast
call out 'b4 vor' w
interpret 'call pipe'w
call out 'b5 vor barEnd inIx' m.t.inIx
call pipeEnd
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: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o20 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o20 of TstEnvClass10>
tstR: .f13 = M.<o20 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy0
tstR: .f24 = M.<o20 of TstEnvClass20>.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 writeAllFramed *** TY
a5 vor writeAllFramed
a1 vor jBuf()
a2 vor writeAllFramed b
tstR: @LINE isA :TstEnvClass10 union
tstR: .f11 = M.<o21 of TstEnvClass10>.f11
tstR: .F12 = value F12 of o1 <o21 of TstEnvClass10>
tstR: .f13 = M.<o21 of TstEnvClass10>.f13
WriteO o2
tstR: @LINE isA :TstEnvClass20 union = valueO2Lazy1
tstR: .f24 = M.<o21 of TstEnvClass20>.f24
tstR: .F25 = value F25 of o21 <o21 of TstEnvClass20>
a3 vor writeAllFramed
#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 writeAllFramed ***
tstEnvClass */
call tst t, "tstEnvClass"
do lz=0 to 1
if lz then
w = 'writeAllFramed'
else
w = 'writeNow'
m.t.inIx = 1-lz
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')
call out 'a0 vor pipeBegin loop lazy' lz w '***' ty
call pipeBegin
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 jWriteO b, o1
call jWrite b, 'WriteO o2'
o2 = oNew('TstEnvClass20')
m.o2 = 'valueO2Lazy'lz
m.o2.F25 = 'value F25 of o2'lz o2
oc = oCopyNew(oCopyNew(o2))
call mAdd t'.TRANS', o2 '<o2'lz 'of TstEnvClass20>'
call mAdd t'.TRANS', oc '<oc'lz 'of TstEnvClass20>'
call jWriteO 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 pipeLast
call out 'a5 vor' w
interpret 'call pipe'w
call out 'a6 vor barEnd'
call pipeEnd
call out 'a7 nach barEnd lazy' lz w '***'
end
call tstEnd t
m.t.trans.0 = 0
return
endProcedure tstEnvClass
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 pipeBeLa '>' s2o(tstPdsMbr(pd2, 'eins'))
call out tstFB('out > eins 1') /* simulate fixBlock on linux */
call out tstFB('out > eins 2 schluss.')
call pipeEnd
call pipeBeLa '>' s2o(tstPdsMbr(pd2, 'zwei'))
call out tstFB('out > zwei mit einer einzigen Zeile')
call pipeEnd
b = jBuf("buf eins", "buf zwei", "buf drei")
call pipeBeLa '<' s2o(tstPdsMbr(pd2, 'eins')), '<' b,
,'<' jBuf(),
,'<' s2o(tstPdsMbr(pd2, 'zwei')),
,'<' s2o(tstPdsMbr(pds, 'wr0')),
,'<' s2o(tstPdsMbr(pds, 'wr1'))
call pipeWriteNow
call pipeEnd
call tstEnd t
return
endProcedure tstFile
/*--- simulate fixBlock 80 on linux ---------------------------------*/
tstFB: procedure expose m.
parse arg line, recL
if errOS() \== '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
os = errOS()
if os = 'TSO' then
return pds'('mbr') ::F'
if os = 'LINUX' then
return pds'.'mbr
call err 'tstPdsMbr implement os' 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.vv = 'vor anfang'
do x = 1 to num
if \ jRead(io, vv) then
call err x 'not jRead'
else if m.vv <> le x ri then
call err x 'read mismatch' m.vv
end
if jRead(io, vv) then
call err x 'jRead but should be eof 1'
if jRead(io, vv) then
call err x'+1 jjRead but should be eof 2'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstFileRW
tstFileList: procedure expose m.
call catIni
/*<<tstFileList
### start tst tstFileList #########################################
empty dir
filled dir
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
filled dir recursive
<<pref 2 List>>drei
<<pref 2 List>>eins
<<pref 2 List>>zwei
<<pref 2 List>>vier
<<pref 1 vier>>drei
<<pref 1 vier>>eins
<<pref 1 vier>>zwei
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 errOS() = '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
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 pipeBeLa m.j.cWri b
call tstDataClassOut '. c3 a2i i b3b c5 d4 c13 fl5 f8n2 ex6 e9n3',
, -11, + 23
call pipeEnd
call fmtFWriteAll fmtFreset(abc), b
call fmtFAddFlds fmtFReset(abc), oFlds(st'.'1)
m.abc.1.tit = 'c3L'
m.abc.2.fmt = 'e'
m.abc.3.tit = 'drei'
m.abc.4.fmt = 'l7'
call fmtFWriteAll abc, b
call tstEnd t
return
endProcedure tstFmt
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 0: key val .
scan n tok 10: hr123sdfER key val .
scan " tok 5: "st1" key val st1
scan b tok 0: key val st1
scan ' tok 19: 'str2''mit''apo''s' key val str2'mit'apo's
scan b tok 0: 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 6 in string a034,'wie 789abc
scan ' tok 1: ' key val .
scan n tok 3: wie key val .
scan s tok 0: key val .
*** err: scanErr illegal number end after 789
. e 1: last token 789 scanPosition abc
. e 2: pos 14 in string a034,'wie 789abc
scan d tok 3: 789 key val .
scan n tok 3: abc key val .
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 0: key val .
scan d tok 2: 23 key val .
scan b tok 0: 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 0: 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 0: 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;+-=f ab=cdEf eF='strIng' .
scan b tok 0: key val .
scan k tok 4: no= key aha val def
scan ; tok 1: ; key aha val def
scan + tok 1: + key aha val def
scan - tok 1: - key aha val def
scan = tok 1: = key aha val def
scan k tok 4: no= key f val def
scan k tok 4: cdEf key ab val cdEf
scan b tok 4: cdEf key ab val cdEf
scan k tok 8: 'strIng' key eF val strIng
scan b tok 8: 'strIng' key eF val strIng
tstScan.5 */
call tst t, 'tstScan.5'
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
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 tst t, 'tstScanRead'
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = jOpen(scanRead(b))
do while \scanAtEnd(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 \scanAtEnd(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 = jOpen(scanRead(b))
do forever
if scanName(s) then call out 'name' m.s.tok
else if scanSpaceNL(s) then call out 'spaceLn'
else if \scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jClose 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: Scan 18: Scan
tstScanJRead */
call tst t, 'tstScanJRead'
call jWrite jOpen(b,'>>'), '1 + 2. +. +.3-45e-3 "a""b"' "'c''d'"
s = jOpen(scanRead(jClose(b)))
do x=1 while jRead(s, v.x)
call out x 'jRead' m.v.x.type 'tok' m.v.x.tok 'val' m.v.x.val
end
call jClose s
call out 'className 1:' className(objClass(v.1)),
'18:' className(objClass(v.18))
call tstEnd t
return
endProcedure tstScanRead
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 undZehnueberElfundNochWeiterZwoel+
fundim1\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(scanWin(b, , , 2, 15))
call tstOut t, 'info 0:' scanInfo(s)
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(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 comAc+
ht com\npos 15 in line 5: fuenf c
name com
spaceNL
tstScanWinRead */
call tst t, 'tstScanWinRead'
call mAdd t.cmp,
, "name Sechs",
, "spaceNL",
, "name com",
, "info 15: last token com scanPosition sieben comAcht c",
|| "om com com\npos 2 in line 7: m sieben com" ,
, "spaceNL",
, "name sieben",
, "spaceNL",
, "name Acht",
, "spaceNL",
, "info 20: last token scanPosition ueberElfundNochWeit com ",
|| "elfundim13\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"
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 = scanWin(b, , , 2, 15)
call scanOpts s, , , 'com'
call tstOut t, 'info 0:' scanInfo(jOpen(s))
do sx=1 while \scanAtEnd(s)
if scanName(s) then call tstOut t, 'name' m.s.tok
else if scanSpaceNL(s) then call tstOut t, 'spaceNL'
else if \scanAtEnd(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
return
endProcedure tstScanWin
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 = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlID(s) then call tstOut t, 'sqlId' m.s.val
else if scanSpaceNL(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 = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlDeID(s) then call tstOut t, 'sqlDeId' m.s.val
else if scanSpaceNL(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 = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlQuID(s) then
call tstOut t, 'sqlQuId' m.s.val m.s.val.0 m.s.val.1
else if scanSpaceNL(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 = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNum(s) then
call tstOut t, 'sqlNum' m.s.val
else if scanSpaceNL(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 scanSqlNumUnit after +9. bad unit TB
. 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 = jOpen(scanSql(b))
do sx=1 while \scanAtEnd(s)
if scanSqlNumUnit(s, 0, 'B KB MB') then
call tstOut t, 'sqlNumUnit' m.s.val
else if scanSpaceNL(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
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, classs, ln
if sc == '' then do
call tstOut t, 'scan src' ln
call scanSrc scanReset(s), ln
end
else do
call tstOut t, 'scan scanner' sc
s = sc
end
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 = scanSpaceNl(s)
else if f == 'c' then
res = scanChar(s, a2)
else if f == 'd' then
res = scanNat(s, a2)
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
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- migrate all compares to new ones:
tstCI input compare
tstCO ouput migrated compares
tstCIO input and output -------------------------------------*/
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.m.errHand = 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
call err implement outDest 'i', 'call tstOut' quote(m)', msg'
end
else do
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
if m.tst.ini.e \== 1 then do
m.m.oldJin = m.j.in
m.m.oldOut = m.j.out
m.j.in = m
m.j.out = m
end
else do
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
call pipeBeLa '<' m, '>' m
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
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 | m.j.out \== m then
call tstErr m, m.j.in '\==' m '|' m.j.out '\==' m
call pipeEnd
if m.pipe.0 <> 1 then
call tstErr m, 'm.pipe.0' m.pipe.0 '<> 1'
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 = 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 ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'out:' arg
return
endProcedure tstWrite
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
tstWriteO: procedure expose m.
parse arg m, var
if abbrev(var, m.class.escW) then do
call tstOut t, o2String(var)
end
else if m.class.o2c.var == m.class.classV then do
call tstOut t, m.var
end
else if oKindOf(var, 'JRW') then do
call tstOut t, 'tstWriteO kindOf JRW jWriteNow begin <<<'
call jWriteNow m, var
call tstOut t, 'tstWriteO kindOf JRW jWriteNow end >>>'
end
else if oKindOf(var, 'ORun') then do
call tstOut t, 'tstWriteO kindOf ORun oRun begin <<<'
call oRun var
call tstOut t, 'tstWriteO kindOf ORun oRun end >>>'
end
else do
call classOut , var, 'tstR: '
end
return
endProcedure tstWriteO
tstReadO: procedure expose m.
parse arg m, arg
ix = m.m.inIx + 1
m.m.inIx = ix
if ix <= m.m.in.0 then do
m.arg = m.m.in.ix
m.class.o2c.arg = m.class.classV
call tstOut m, '#jIn' ix'#' m.arg
return 1
end
call tstOut m, '#jIn eof' ix'#'
return 0
endProcedure tstReadO
tstFilename: procedure
parse arg suf, opt
os = errOS()
if 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 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' os
endProcedure tstFilename
/*--- say total errors and fail if not zero --------------------------*/
tstTotal: procedure expose m.
say '######'
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.m.errHand = m.m.errHand + 1
m.tstErrHandler.0 = 0
call outPush tstErrHandler
call errSay ggTxt
call outPop
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m, ' e' (x-1)':' m.tstErrHandler.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 JRWO', 'm',
, "jReadO return tstReadO(m, var)",
, "jWrite call tstOut m, line",
, "jWriteO call tstWriteO m, var"
end
if m.tst.ini.e \== 1 & m.pipe.ini == 1 then do
m.tst.ini.e = 1
end
return
endProcedure tstIni
/* copx tst end **************************************************/
/* copx 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)
fs = oFlds(fo)
do fx=1 to m.fs.0
f = fo || m.fs.fx
m.f = word(flds, 2*fx)
end
return fo
endProcedure tstDataClassFo
tstDataClassOut: procedure expose m.
parse arg flds, f, t
fo = tstDataClassFo(flds)
fs = oFlds(fo)
do x=f to t
o = oCopyNew(fo)
do fx=1 to m.fs.0
na = substr(m.fs.fx, 2)
f = o || m.fs.fx
m.f = tstData(m.f, na, '+'na'+', x)
end
call outO o
end
return
endProcedure tstDataClassOut
/* copx tstData end ***************************************************/
/* copy tstAll end **************************************************/
/* copy fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 l
/* say 'fmt' v',' f l */
if abbrev('-', f) then
return v
else if f == 'l' then
return left(v, l)
else if f == 'r' then
return right(v, l)
else if f == 'f' then do
parse value l'.0.0.' with b '.' a '.' e '.'
return format(v, b, a, e, 0)
end
else if f == 'e' then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
res = format(v, b, a, e, 0)
y = length(res)-e-1
if substr(res, y) = '' then
return left(res, y-1)left('E', e+1, 0)
else if substr(res, y+1, 1) == '+' then
return left(res, y)substr(res, y+2)
else if substr(res, y+2, 1) == '0' then
return left(res, y+1)substr(res, y+3)
else
call err 'formatoverflow' f || l 'for' v '-->' res
end
else if f = 's' then
if l == '' then
return strip(v, 't')
else
return strip(v, l)
else if f == 'w' then do
parse var l st ',' le
return substr(v, st, le)
end
else
call err 'bad format' f l 'for' v
endProcedure fmt
/*--- format special (title, null Value also for numbers) ------------*/
fmtS: procedure expose m.
parse arg v, ty 2 l
if ty == 'f' then do
if \ dataType(v, 'n') then do
parse value l'.0.0.' with b '.' a '.' e '.'
return right(v, b + a + (a \== 0) + e + 2 * (e > 0))
end
end
else if ty == 'e' then do
if \ dataType(v, 'n') then do
parse var l b '.' a '.' e '.'
if b == '' then b = 2
if a == '' then a = 2
if e == '' then e = 2
return right(v, b + a + (a \== 0) + e + (e > 0))
end
end
return fmt(v, ty || l)
endProcedure fmtS
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
fmtFCsvAll: procedure expose m.
parse arg fSep
if fSep = '' then
fSep = ','
if \ inO(i) then
return
f = oFlds(i)
li = ''
do fx=1 to m.f.0
li = li',' substr(m.f.fx, 2)
end
call out substr(li, 3)
do until \ inO(i)
li = ''
do fx=1 to m.f.0
if m.f.fx = '' then do
li = li',' m.i
end
else do
fld = substr(m.f.fx, 2)
li = li',' m.i.fld
end
end
call out substr(li, 3)
end
return
endProcedure fmtFCsvAll
fmtFAdd: procedure expose m.
parse arg m
fx = m.m.0
do ax=2 to arg()
fx = fx + 1
parse value arg(ax) with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAdd
fmtFAddFlds: procedure expose m.
parse arg m, st
fx = m.m.0
do sx=1 to m.st.0
fx = fx + 1
parse value m.st.sx with m.m.fx.fld m.m.fx.fmt m.m.fx.tit
end
m.m.0 = fx
return m
endProcedure fmtFAddFlds
fmtF: procedure expose m.
parse arg m, st
if arg() >= 3 then
mid = arg(3)
else
mid = ' '
li = ''
do fx=1 to m.m.0
f = st || m.m.fx.fld
li = li || mid || fmtS(m.f, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
endProcedure fmtF
fmtFReset: procedure expose m.
parse arg m
m.m.0 = 0
return m
endProcedure fmtFReset
fmtFWriteAll: procedure expose m.
parse arg m, rdr, wiTi
b = env2buf(rdr)
st = b'.BUF'
if m.st.0 < 1 then
return
if m.m.0 < 1 then
call fmtFAddFlds m, oFlds(st'.1')
call fmtFDetect m, st
if wiTi \== 0 then
call out fmtFTitle(m)
do sx=1 to m.st.0
call out fmtF(m, st'.'sx)
end
return
fmtFWriteAll
fmtFTitle: procedure expose m.
parse arg m
if arg() >= 2 then
mid = arg(2)
else
mid = ' '
li = ''
do fx=1 to m.m.0
if m.m.fx.tit \= '' then
t = m.m.fx.tit
else if m.m.fx.fld = '' then
t = '='
else
t = substr(m.m.fx.fld, 1+abbrev(m.m.fx.fld, '.'))
li = li || mid || fmtS(t, m.m.fx.fmt)
end
return substr(li, 1 + length(mid))
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFldTitle: procedure expose m.
parse arg form
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
res = res fmtS(m.fs.ix, m.form.ix)
end
return substr(res, 2)
endProcedure fmtFldTitle
fmtFld: procedure expose m.
parse arg form, st
res = ''
fs = m.form.FLDS
do ix=1 to m.fs.0
f = m.fs.ix
res = res fmt(m.st.f, m.form.ix)
end
return substr(res, 2)
endProcedure fmtData
fmtFldSquash: procedure expose m.
parse arg newFo, class, src
fs = oFlds(class)
do fx = 1 to m.fs.0
fd = m.fs.fx
lMi = 9e9
lMa = 0
rMi = 9e9
rMa = 0
len = 0
do sx = 1 to m.src.0
x = verify(m.src.sx.fd, ' ', 'n')
if x < 1 then
iterate
lMi = min(lMi, x)
lMa = max(lMa, x)
x = length(strip(m.src.sx.fd, 't'))
rMi = min(rMi, x)
rMa = max(rMa, x)
end
if rMa = 0 then
m.newFo.fx = 'w1,1'len
else
m.newFo.fx = 'w'lMi',' || (rMa+1-lMi)
end
m.newFo.0 = m.fs.0
m.newFo.flds = fs
return newFo
endProcedure fmtFldSquash
fmtFDetect: procedure expose m.
parse arg m, st
do fx=1 to m.m.0
if m.m.fx.fmt = '' then
m.m.fx.fmt = fmtFDetect1(st, m.m.fx.fld)
end
return m
endProcedure fmtDetect
fmtFDetect1: procedure expose m.
parse arg st, suf
aMa = -1
aCnt = 0
aDiv = 0
nCnt = 0
nMi = ''
nMa = ''
nDi = -1
nBe = -1
nAf = -1
eMi = ''
eMa = ''
do sx=1 to m.st.0
f = st'.'sx || suf
v = m.f
aMa = max(aMa, length(v))
if \ dataType(v, 'n') then do
aCnt = aCnt + 1
if aDiv <=3 then
if aDiv.v \== 1 then do
aDiv.v = 1
aDiv = aDiv + 1
end
iterate
end
nCnt = nCnt + 1
if nMi == '' then
nMi = v
else
nMi = min(nMi, v)
if nMa == '' then
nMa = v
else
nMa = max(nMa, v)
parse upper var v man 'E' exp
if exp \== '' then do
en = substr(format(v, 2, 2, 9, 0), 7)
if en = '' then
en = exp
if eMi == '' then
eMi = en
else
eMi = min(eMi, en)
if eMa == '' then
eMa = en
else
eMa = max(eMa, en)
end
parse upper var man be '.' af
nBe = max(nBe, length(be))
nAf = max(nAf, length(af))
nDi = max(nDi, length(be || af))
end
say 'suf' suf aCnt 'a len' aMa 'div' aDiv
say ' ' nCnt 'n' nMi'-'nMa 'be' nBe 'af' nAf,
'di' nDi 'ex' eMi'-'eMa
if nCnt = 0 | aDiv > 3 then
newFo = 'l'max(0, aMa)
else if eMi \== '' then do
eMa = max(eMa, substr(format(nMa, 2, 2, 9, 0), 7))
newFo = 'e' || (1+(eMi < 0)) || '.' || (max(0, nDi-1))'.' ,
|| max(length(eMa+0), length(eMi+0))
end
else if nAf > 0 then
newFo ='f'nBe'.'nAf
else
newFo ='f'nBe'.0'
say ' ' newFo
return newFo
endProcedure fmtFDetect1
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetClassPara(m.j.in)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than class'
call out fmtFldTitle(fo)
do while in(ii)
call out fmtFld(fo, ii)
end
return
endProcedure fmtClassRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.in
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetClassPara(in)
flds = oFlds(ty)
st = 'FMT.CLASSAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call out fmtFldTitle(fo)
do ix = 1 to m.st.0
call out fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o, cmp
if cmp == '' then
m.sort.comparator = "cmp = m.l.l0 <<= m.r.r0"
else if length(cmp) < 6 then
m.sort.comparator = "cmp = m.l.l0" cmp "m.r.r0"
else if pos(';', cmp) < 1 then
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0; cmp =" cmp
else
m.sort.comparator = "aLe = l'.'l0; aRi = r'.'r0;" cmp
call sort1 i, 1, m.i.0, o, 1, sort.work, 1
m.o.0 = m.i.0
return
endProcedure sort
sort1: procedure expose m.
parse arg i, i0, le, o, o0, w, w0
if le <= 3 then do
if le = 3 then do
call sortMerge i, i0, i0+1, i, i0+1, i0+2, w, w0
call sortMerge i, i0+2, i0+3, w, w0, w0+2, o, o0
end
else if le = 2 then
call sortMerge i, i0, i0+1, i, i0+1, i0+2, o, o0
else if le = 1 then
m.o.o0 = m.i.i0
return
end
h = (le + 1) % 2
call sort1 i, i0, h, o, o0+le-h, w, w0
call sort1 i, i0+h, le-h, w, w0, o, o0
call sortMerge o, o0+le-h, o0+le, w, w0, w0+le-h, o, o0
return
endProcedure sort1
sortMerge: procedure expose m.
parse arg l, l0, le, r, r0, re, o, o0
do while l0 < le & r0 < re
interpret m.sort.comparator
if cmp then do
m.o.o0 = m.l.l0
l0 = l0 + 1
end
else do
m.o.o0 = m.r.r0
r0 = r0 + 1
end
o0 = o0 + 1
end
do while l0 < le
m.o.o0 = m.l.l0
l0 = l0 + 1
o0 = o0 + 1
end
do while r0 < re
m.o.o0 = m.r.r0
r0 = r0 + 1
o0 = o0 + 1
end
return
endProcedure sortMerge
/* copy sort end ****************************************************/
/* copy match begin ***************************************************/
/************************************* begin copy match ******/
/*--- wildCard matching with the following wildchars:
* 0-n chars
? 1 char
fill matched expressions instem st if st is non empty
return 1 if mask matches wert ----------------------------------*/
match: procedure expose m.
parse arg wert, mask, st
if st == '' then
return matchRO(wert, mask)
m.st.0 = -9
return matchSt(wert, mask, st, 0)
endProcedure match
/*--- return the fixed prefix of maskt -------------------------------*/
matchPref: procedure
arg mask, suff
ix = verify(mask, '*?', 'm')
if ix = 0 then
return mask
else
return left(mask, ix-1)suff
endProcedure matchPref
/*--- return true if mask matches wert -------------------------------*/
matchRO: procedure
arg wert, mask
ix = verify(mask, '*?', 'm')
if ix < 1 then return (mask == wert)
if length(wert) < ix-1 then return 0
if left(mask, ix-1) \== left(wert, ix-1) then return 0
if substr(mask, ix, 1) == '?' then do
if length(wert) < ix then return 0
return matchRO(substr(wert, ix+1), substr(mask, ix+1))
end
mask = substr(mask, ix+1) /* * 0 - n Chars */
do ex = 1+length(wert) to ix by -1
if matchRO(substr(wert, ex), mask) then return 1
end
return 0
endProcedure matchRO
/*--- wildCard matching: fill matched expressions instem st
return 1 if mask matches wert ----------------------------------*/
matchSt: procedure expose m.
parse arg wert, mask, st, sx
ix = verify(mask, '*?', 'm')
if ix < 1 then do
if mask \== wert then
return 0
m.st.0 = sx
return 1
end
if \ abbrev(wert, left(mask, ix-1)) then
return 0
reMa = substr(mask, ix+1)
sx = sx + 1
if substr(mask, ix, 1) == '?' then do /* ? 1 Character */
if length(wert) < ix then
return 0
m.st.sx = substr(wert, ix, 1)
return matchSt(substr(wert, ix+1), reMa, st, sx)
end
do lx = 1+length(wert) to ix by -1 /* greedy: from all to empty */
if matchSt(substr(wert, lx), reMa, st, sx) then do
m.st.sx = substr(wert, ix, lx-ix)
return 1
end
end
return 0
endProcedure matchSt
matchTrans: procedure expose m.
parse arg mask, st
r = ''
ox = 1
sx = 0
ix = verify(mask, '*?', 'm')
do sx=1 to m.st.0 while ix > 0
if sx > m.st.0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
r = r || substr(mask, ox, ix-ox)m.st.sx
ox = ix+1
ix = verify(mask, '*?', 'm', ox)
end
if ix > 0 then
call err 'matchTrans('mask',' st') has only' ,
m.st.0 'variables'
return r || substr(mask, ox)
endProcedure matchTrans
/* copy match end *****************************************************/
/* copy comp begin *****************************************************
the shell compiler
syntax and semantics of the shell language see javaDoc
***********************************************************************/
/*--- module initialisation ------------------------------------------*/
compIni: procedure expose m.
if m.compIni = 1 then
return
m.compIni = 1
call pipeIni
call scanReadIni
cc = classNew('n Compiler u')
m.comp.stem.0 = 0
m.comp.idChars = m.scan.alfNum'@_'
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.cmpRdr = src
return nn
endProcedure comp
m.nn.cmpRdr = scanRead(src)
return compReset(nn, src)
compReset: procedure expose m.
parse arg m
m.m.scan = scanRead(,,'|0123456789')
m.m.chDol = '$'
m.m.chSpa = ' ' || x2c('09')
m.m.chNotBlock = '${}='
m.m.chNotWord = m.m.chNotBlock || m.m.chSpa
m.m.chKind = '.-=#@'
m.m.chKinC = '.-=@'
return m
endProcedure compReset
/*--- push an empty stem on the stack --------------------------------*/
compNewStem: procedure expose m.
parse arg m
st = mAdd('COMP.STEM', '')
do ix=1 to arg()-1
m.st.ix = arg(ix+1)
end
m.st.0 = ix-1
return st
endProcedure compNewStem
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, spec
call compReset m
s = m.m.scan
kind = '@'
spec = strip(spec)
do while pos(left(spec, 1), m.m.chKinC) > 0
kind = left(spec, 1)
spec = strip(substr(spec, 2))
end
call scanSrc s, spec
call compSpComment m
m.m.dirKind = kind
m.m.compSpec = 1
res = oRunner()
nxt = res
doClose = 0
do cx=1 to 100
m.m.dir = ''
kind = m.m.dirKind
if kind == '@' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = comp2Code(m, ';'compShell(m))
end
else do
what = "data("kind")";
expec = "sExpression or block";
src = comp2Code(m, ';'compData(m, kind))
end
if m.m.dir == '' then
call compDirective m
if m.m.dir == '' then
return scanErr(s, expec "expected: compile" what ,
" stopped before end of input")
if abbrev(m.m.dir, '$#') then
if \ scanLit(s, m.m.dir) then
call scanErr m.m.scan 'directive' m.m.dir 'mismatch'
if src \== '' then do
call oRunnerCode nxt, src
nxt = m.m.dirNext
end
if wordPos(m.m.dir, 'eof next $#end $#out') > 0 then do
if doClose then
call jClose s
if m.m.dir \== 'next' | \ m.m.compSpec then
return res
call scanReadReset s, m.m.cmpRdr
doClose = jOpenIfNotYet(s)
m.m.compSpec = 0
end
end
call scanErr s, 'loop in compile'
endProcedure compile
compDirective: procedure expose m.
parse arg m, ki
if m.m.dir \== '' then
return ''
lk = scanLook(m.m.scan, 9)
if abbrev(lk, '$#') then do
if pos(substr(lk, 3, 1), m.m.chKinC) > 0 then do
m.m.dirKind = substr(lk, 3, 1)
m.m.dir = left(lk, 3)
end
else if abbrev(lk, '$#end') then do
m.m.dir = 'eof'
return ''
end
else
call scanErr m.m.scan, 'bad directive after $#'
end
else if scanAtEnd(m.m.scan) then do
if \ m.m.compSpec | m.m.cmpRdr == '' then do
m.m.dir = 'eof'
return ''
end
m.m.dir = 'next'
end
else do
return ''
end
m.m.dirNext = oRunner()
if ki == '@' then
return "; call oRun '"m.m.dirNext"'"
else
return ". '"m.m.dirNext"'"
endProcedure compDirective
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, ki
s = m.m.scan
lines = compNewStem(m)
do forever
state = 'f'
do forever
l = compExpr(m, 'd', ki)
if \ scanReadNL(s) then
state = 'l'
if \ compIsEmpty(m, l) | (state=='' &\abbrev(l, 'c')) then
call mAdd lines, l
if state == 'l' then
leave
call compComment m
state = ''
end
one = compStmt(m)
if one == '' then
leave
call mAdd lines, one
call compComment m
end
return 'l*' lines
endProcedure compData
/*--- compile shell and return code ----------------------------------*/
compShell: procedure expose m.
parse arg m
res = ''
do forever
one = compPipe(m)
if one \== '' then
res = res || one
if \ scanLit(m.m.scan, '$;') then
return res
call compSpNlComment m
end
endProcedure compShell
/*--- compile an expression, type d=data, w=word, s=strip ------------*/
compExpr: procedure expose m.
parse arg m, type, ki
s = m.m.scan
if length(type) \== 1 | pos(type, 'dsb') < 1 then
call scanErr s, 'bad type' type 'in compExpr(,' type','ki ')'
if length(ki) \== 1 | pos(ki, m.m.chKind';') < 1 then
call scanErr s, 'bad kind' ki 'in compExpr(,' type','ki ')'
charsNot = if(type=='b', m.m.chNotBlock, m.m.chDol)
laTx = 9e9
st = compNewStem(m)
gotCom = 0
if pos(type, 'sb') > 0 then do
call compSpComment m
gotCom = gotCom | m.m.gotComment
end
ki2 = if(ki=='=', '-=', ki)
do forever
if scanVerify(s, charsNot, 'm') then do
call mAdd st, ki2 m.s.tok
laTx = min(laTx, m.st.0)
end
else do
pr = compPrimary(m, ki)
if pr = '' then
leave
call mAdd st, pr
laTx = 9e9
end
gotCom = gotCom | compComment(m)
end
do rx = m.st.0 by -1 to laTx while m.st.rx = ki2
end
if pos(type, 'bs') > 0 then do
if rx >= laTx then
m.st.rx = strip(m.st.rx, 't')
m.st.0 = rx
end
if ki == '=' then
if m.st.0 < 1 then
return 'e='
else
ki = '-'
return substr('ce', 2-gotCom, rx < 1)ki'0*' st
endProcedure compExpr
/*--- transform abstract syntax tree to code ------------------------
wkTst??? codeTree besser dokumentieren
optimizer an/und/abschaltbar machen
(test sollte laufen, allenfalls gehen rexx variabeln
verloren)
syntax tree is simple, only where
* a transformation is needed from several places or
* must be deferred for possible optimizations
sn = ops* syntax node op or syntax function
( '=' constant none
| '-' rexxExpr yielding string cast to string
| '.' rexxExpr yielding object cast to object
| '<' rexxExpr yielding file cast to file
| ';' rexxStmts execute, write obj, Str
| '*' stem yielding multiple sn none
)
ops = '@' cast to ORun
| '|' single
| 'e' empty = space only
| 'c' empty = including a comment
| '0' cat expression parts
| 'l' cat lines
| '(' add ( ... ) or do ... end
---------------------------------------------------------------------*/
comp2Code: procedure expose m.
parse arg m, ki expr
/* wkTst??? optimize: use stem with code and interpret */
if expr = '' & pos(right(ki, 1), '@;=') < 1 then
return scanErr(m.m.scan, 'comp2Code empty expr' ki expr)
do forever
ki = comp2CodeKind(m, ki)
if length(ki) <= 1 then
if pos(ki, m.m.chKind';<') > 0 then
return expr
else
call err 'comp2Code bad return' ki expr
fr = right(ki, 1)
to = substr(ki, length(ki)-1, 1)
opt = ''
if pos(to, 'l0') > 0 then do
opt = to
to = substr(ki, length(ki)-2, 1)
end
nn = '||||'
if fr == '*' then do
if opt == '' then
call scanErr m.m.scan, 'no sOp for * kind' ki expr
cat = comp2CodeCat(m, expr, opt, to)
parse var cat to nn
end
else if to == '-' then do
if fr == '=' then
nn = quote(expr)
else if abbrev(fr expr, '. envGetO(') then
nn = 'envGet(' || substr(expr, 9)
else if fr == ';' then
nn = "o2String('"oRunner(expr)"')"
else if pos(fr, '.<') > 0 then
nn = "o2String("expr")"
end
else if to == '.' then do
if fr == '=' then
nn = quote(s2o(expr))
else if abbrev(fr expr, '- envGet(') then
nn = 'envGetO('substr(expr, 8)
else if fr == '-' then
nn = 's2o('expr')'
else if fr == '<' then
nn = expr
else if fr == ';' then
nn = quote(oRunner(expr))
end
else if to == '@' then do
if fr == '.' then
nn = 'call oRun' expr
else if fr == '<' then
nn = 'call pipeWriteAll' expr
else if fr == ';' then
nn = expr
to = ';'
end
else if to == ';' then do
if fr == '=' then
nn = 'call out' quote(expr)
else if fr == '-' then
nn = 'call out' expr
else if fr == '.' then
nn = 'call outO' expr
else if fr == '<' then
nn = 'call pipeWriteAll ' expr
end
else if to == ':' then do
if fr == '=' then
nn = quote(expr)
else
nn = expr
to = ';'
end
else if to == '<' then do
if fr == '-' then
nn = 'file('expr')'
else if fr == '=' then
nn = "file("quote(expr)")"
else if fr == '.' then
nn = 'o2File('expr')'
else if fr == ';' then
nn = 'o2File('oRunner(expr)')'
end
else if to == '(' then do
nn = compAddBracks(m, fr, expr)
to = fr
end
if nn == '||||' then
return scanErr(m.m.scan,
,'comp2code bad fr' fr 'to' to 'for' ki expr)
ki = left(ki, length(ki)-2-length(opt))to
expr = nn
end
endProcedure comp2Code
/*--- optimize operands: eliminate duplicates and
identity transformations -------------------*/
comp2CodeKind: procedure expose m.
parse arg m, ki
ki = '$'space(translate(ki, ' ', 'ce'), 0)
fr.2 = '== -- .. << ;; (( -( .( ;( (< @; @@ ;@ $l $0'
to.2 = '= - . < ; ( (- (. (; < ; @ @ $ $'
fr.3 = ';0; ;l; -.- -;- .-. .;. ;<; <(; '
to.3 = ' 0; l; - - . . ; <; '
do until ki = oldKi
oldKi = ki
do le=3 by-1 to 2
do cx=1 while cx <= length(ki)+1-le
wx = wordPos(substr(ki, cx, le), fr.le)
if wx > 0 then
ki = left(ki, cx-1) || ,
word(to.le, wx) || substr(ki, cx+le)
end
end
end
return substr(ki, 2)
endProcedure comp2CodeKind
/*--- generate one codeString for one stem -------------------------*/
comp2CodeCat: procedure expose m.
parse arg m, st, sOp, trgt
toCode = trgt == '@' | trgt == ';'
if m.st.0 < 1 & trgt \== '<' then
return trgt
tr1 = trgt
if \ toCode then do
/* check wether we need to evaluate statements
and cast the outptut to an object */
maxTy = 0
do x=1 to m.st.0
maxTy = max(maxTy, pos(left(m.st.x, 1), '=-.<;@'))
end
if trgt \== '<' then do
if maxTy >= 5 then do
tr1 = ';'
toCode = 1
end
end
else do /* handle files */
if maxTy > 1 then do /* not constant */
res = ';'
do sx=1 to m.st.0
res = res';' comp2Code(m, ';'m.st.sx)
end
return '<'res
end
/* constant file write to jBuf */
buf = jOpen(jBuf(), m.j.cWri)
do sx=1 to m.st.0
call jWrite buf, substr(m.st.sx, 3)
end
return '<' quote(jClose(buf))
end
end
if m.st.0 = 1 & trgt \== '<' then
return trgt comp2Code(m, trgt || m.st.1)
tr2 = tr1
if toCode then do
mc = '; '
if sOp == 0 then do
mc = ''
tr2 = ':'
end
end
else if sOp == '0' then
mc = if(tr1 == '.' | tr1 == '-', '', ' || ')
else if sOp == 'l' then
mc = ' '
else
call scanErr m.m.scan, 'bad sOp' sOp ,
'in comp2CodeCat('m',' st',' sOp',' trgt')'
if symbol('m.st.1') \== 'VAR' then
return err("bad m."st'.1')
sep = if(tr1 == '.' | tr1 == '-' | tr1 == '=', ' || ', ' ')
sep = if(sOp = 0, ' || ', ' ')
tr3 = left(tr2, sOp \== 0)
res = comp2Code(m, tr3 || m.st.1)
do sx = 2 to m.st.0
if (tr2 == '.' | tr2 == '-') ,
& (m.st.sx = '-' | m.st.sx = '.') then do
/* empty expr is simply a rexx syntax space */
if right(res, 1) \== ' ' then
res = res' '
end
else do
act = comp2Code(m, tr3 || m.st.sx)
res = compCatRexx(res, act, mc, sep)
end
end
return copies(trgt || sOp, tr1 \== trgt)tr1 res
endProcedure comp2CodeCat
/*--- add expression brackets if necessary --------------------------*/
compAddBracks: procedure expose m.
parse arg m, ki, ex
if ki == ';' then
return 'do;' ex || left(';', ex \= '') 'end'
if \ (ki == '.' | ki == '-') then
return ex
ex = strip(ex)
e1 = left(ex, 1)
if e1 == '(' & pos('(', ex, 2) = 0 & pos(')', ex) = length(ex) then
return ex
if pos(e1, '"''') > 0 & pos(e1, ex, 2) = length(ex) then
return ex
return '('ex')'
endProcedure compAddBracks
/*--- 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 || mi || ri
endProcedure compCatRexx
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m, ki
s = m.m.scan
if \ scanLit(s, '$') then
return ''
if scanString(s) then /*wkTst??? brauchts beides? */
return translate(ki, '.--', '@;=')'=' m.s.val
if scanLit(s, '.', '-') then do
op = m.s.tok
return op'('compCheckNN(m, compObj(m, op),
, 'objRef expected after $'op)
end
if pos(ki, '.<') >= 1 then
f = '. envGetO'
else
f = '- envGet'
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = '- envIsDefined'
else if scanLit(s, '>') then
f = '- envReadO'
res = compCheckNE(m, compExpr(m, 'b', '='), 'var name')
if \scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'(' || comp2Code(m, '-'res)')'
end
if scanName(s) then
return f"('"m.s.tok"')"
call scanBack s, '$'
return ''
endProcedure compPrimary
/*--- compile a pipe and return code ---------------------------------*/
compPipe: procedure expose m.
parse arg m
s = m.m.scan
ios = ''
stmts = ''
stmtLast = ''
do forever
io1 = compRedirIO(m, 1)
if io1 \== '' then do
ios = ios',' io1
call compSpNlComment m
end
else do
if stmtLast \== '' then do
if \ scanLit(s, '$|') then
leave
call compSpNlComment m
end
one = comp2code(m, ';'compStmts(m))
if one == '' then do
if stmtLast \== '' then
call scanErr s, 'stmts expected after $|'
if ios == '' then
return ''
leave
end
if stmtLast \== '' then
stmts = stmts'; call pipe' || stmtLast
stmtLast = ';' one
end
end
if stmts \== '' then
stmtLast = insert('Begin', stmts, pos('pipe;', stmts)+3) ,
|| '; call pipeLast' stmtLast'; call pipeEnd'
if ios \== '' then do
if stmtLast == '' then
stmtLast = '; call pipeWriteAll'
stmtLast = '; call pipeBeLa 'substr(ios, 3) || stmtLast';' ,
'call pipeEnd'
end
return stmtLast
endProcedure compPipe
/*--- compile an io redirection, return
if makeExpr then "option", expr
else code write inut to standard out -------------*/
compRedirIO: procedure expose m.
parse arg m
s = m.m.scan
if \ scanLit(s, '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
return "'"opt"'" comp2Code(m, compFile(m))
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
lst = compNewStem(m)
do forever
one = compStmt(m)
if one == '' then do
do forever
la = compExpr(m, 's', ';')
if compIsEmpty(m, la) then
leave
la = strip(comp2code(m, ';'la))
if right(la, 1) \== ',' then do
one = one la
leave
end
one = one strip(left(la, length(la)-1))
call compSpNlComment m
end
if one = '' then
return 'l*' lst
one = ';' one
end
call mAdd lst, one
call compSpNlComment m
end
endProcedure compStmts
/* wkTst???syntax start */
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = comp2Code(m, '-'compCheckNE(m,
, compExpr(m, 'b', '='), "variable name after $="))
if \ scanLit(s, "=") then
call scanErr s, '= expected after $=' nm
vl = compCheckNE(m, compBlockExpr(m, '='),
, 'block or expression after $=' nm '=')
if abbrev(vl, '-') then
return '; call envPut' nm',' comp2Code(m, vl)
else
return '; call envPutO' nm',' comp2Code(m, '.'vl)
end
if scanLit(s, '$@') then do
if \ scanName(s) then
return 'l;' comp2Code(m,
, '@'compCheckNN(m, compObj(m, '@'),
, "objRef expected after $@"))
fu = m.s.tok
if fu == 'for' then do
v = comp2Code(m, '-'compCheckNE(m, compExpr(m, 'b', '='),
, "variable name after $@for"))
call compSpComment m
st = comp2Code(m, ';'compCheckNN(m, compStmt(m),
, "statement after $@for" v))
return '; do while envReadO('v');' st'; end'
end
if fu == 'do' then do
call compSpComment m
var = if(scanName(s), m.s.tok, '')
pre = var
call compSpComment m
if scanLook(s, 1) \== '=' then
var = ''
suf = comp2Code(m, ':'compCheckNE(m, compExpr(m, 's', ';'),
, "$@do control construct"))
call compSpComment m
st = comp2Code(m, ";"compCheckNN(m, compStmt(m),
, "$@do statement"))
return "; do" pre suf";",
if(var \== "", "call envPut '"var"'," var";") st"; end"
end
if fu == 'ct' then do
call compSpComment m
call compInter(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'ct statement')));
return '; '
end
if fu == 'proc' then do
nm = compCheckNE(m, compExpr(m, 'b', '='), "proc name")
call compSpComment m
st = oRunner(comp2Code(m, ';'compCheckNN(m, compStmt(m),
, 'proc statement')));
call envPutO compInterEx(comp2Code(m, '-'nm)), st
return '; '
end
if \ scanLit(s, '(') then
call scanErr s, 'procCall, for, do, ct, proc' ,
'or objRef expected after $@'
call compSpComment m
if \ scanLit(s, ')') then
call scanErr s, 'closing ) expected after $@'fu'('
return '; call oRun envGetO("'fu'")'
end
if scanLit(s, '$$') then
return compCheckNN(m, compBlockExpr(m, '='),
, 'block or expression expected after $$')
return compDirective(m, '@')
endProcedure compStmt
/* wkTst???syntax end */
compInter: procedure expose m.
interpret arg(1)
return
endProcedure compInter
compInterEx: procedure expose m.
interpret 'return' arg(1)
endProcedure compInterEx
compBlockExpr: procedure expose m.
parse arg m, ki
s = m.m.scan
res = compBlock(m, ki)
if res \== '' then
return res
lk = scanLook(s, 1)
if pos(lk, m.m.chKind) > 0 then
call scanChar s, 1
else
lk = ki
return compExpr(m, 's', lk)
endProcedure compBlockExpr
compObj: procedure expose m.
parse arg m, ki
one = compPrimary(m, translate(ki, '.', '@'))
if one \== '' then
return one
ki = translate(ki, ';', '@')
one = compBlock(m, ki)
if one \== '' then
return ki || one
s = m.m.scan
if scanLit(s, '<') then
return compFile(m)
if scanLit(s, 'compile') then do
if pos(scanLook(s, 1), m.m.chKind) < 1 then
call scanErr s, 'compile kind expected'
call scanChar s, 1
return ki'. compile(comp(env2Buf()), "'m.s.tok'")'
end
return compDirective(m, ki)
endProcedure compObj
compFile: procedure expose m.
parse arg m
res = compBlock(m, '=')
if res \== '' then
return '<;'res
s = m.m.scan
ki = scanLook(s, 1)
if pos(ki, m.m.chKind) > 0 then do
call scanLit s, ki
end
else do
ki = '='
res = compDirective(m, '.')
if res \== '' then
return '<'res
end
res = compCheckNE(m, compExpr(m, 's', ki),
, 'block or expr expected for file')
return '<'res
endProcedure compFile
compBlock: procedure expose m.
parse arg m, ki
s = m.m.scan
t2 = scanLook(s, 2)
hasType = pos(left(t2, 1) , m.m.chKind) > 0
start = substr(t2, hasType+1, 1)
if pos(start, '{[/') < 1 then
return ''
if hasType then
ki = translate(left(t2, 1), ';', '@')
if \ scanLit(s, left(t2, hasType+1)) then
call scanErr s, 'compBlock internal 1'
starter = start
if start == '{' then
stopper = '}'
else if start == '[' then
stopper = '$]'
else do
call scanVerify s, '/', 'm'
starter = '/'m.s.tok'/'
stopper = '$'starter
if \scanLit(s, '/') then
call scanErr s, 'ending / after stopper' stopper 'expected'
end
if start == '{' then do
res = compNewStem(m)
if ki == '#' then do
tx = '= '
cb = 1
do forever
call scanVerify s, '{}', 'm'
tx = tx || m.s.tok
if scanLit(s, '{') then
cb = cb + 1
else if scanLook(s, 1) \== '}' then
call scanErr s, 'closing } expected'
else if cb <= 1 then
leave
else if scanLit(s, '}') then
cb = cb - 1
else
call scanErr s, 'closing } programming error'
tx = tx || m.s.tok
end
call mAdd res, tx
end
else do
one = compExpr(m, 'b', ki)
if one \== '' & \ abbrev(one, 'e') then
call mAdd res, one
end
res = 'l*' res
end
else if ki == '#' then do
res = compNewStem(m)
call compSpComment m
if \ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after' starter
do while \ abbrev(m.s.src, stopper)
call mAdd res, '=' strip(m.s.src, 't')
if \ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after' starter
end
res = 'l*' res
end
else if ki == ';' then do
call compSpNlComment m
res = compShell(m)
end
else if ki == '@' then do
call err 'compBlock bad ki' ki
end
else do
res = compData(m, ki)
if res == '' then
res = 'l*' compNewStem(m)
end
if \ scanLit(s, stopper) then
call scanErr s, 'ending' stopper 'expected after' starter
if res = '' then
return '('ki
else
return '('res
endProcedure compBlock
/*--- 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, ex
e1 = left(ex, 1)
return ex = '' | pos(e1, 'ce') > 0 | e1 = ex
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) then
call scanErr m.m.scan, msg 'expected'
return ex
endProcedure compCheckNE
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
res = 0
do forever
if scanLit(s, '$**') then
m.s.pos = 1 + length(m.s.src) /* before next nl */
else if scanLit(s, '$*+') then
call scanReadNl s, 1
else if scanLit(s, '$*(') then do
do forever
if scanVerify(s, m.m.chDol, 'm') then iterate
if scanReadNl(s) then iterate
if compComment(m) then iterate
if \ scanLit(s, '$') then
call scanErr s, 'source end in comment'
if scanLit(s, '*)') then
return 1
if scanLit(s, '$') then iterate
if scanString(s) then iterate
end
end
else
return res
res = 1
end
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
sp = 0
co = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
sp = 1
else if compComment(m) then
co = 1
else
leave
end
m.m.gotComment = co
return co | sp
endProcedure compSpComment
/*--- skip spaces, NLs and comments ----------------------------------*/
compSpNlComment: procedure expose m.
parse arg m
found = 0
do forever
if compSpComment(m) then
found = 1
else if scanReadNl(m.m.scan) then
found = 1
else
return found
end
endProcedure compSpComment
/* copy comp end ******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanRead??(m,ln): begin scanning all lines of an opened reader
scanAtEnd(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,u) : scan a space delimited word or a string,
if u=1 then uppercase non-strings
scanErr(m, txt): error with current scan location
m is an adress, to store our state
if a scan function succeeds, the scan posititon is moved
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
***********************************************************************/
scanIni: procedure expose m.
if m.scan.ini == 1 then
return
m.scan.ini = 1
m.scan.alfLC = 'abcdefghijklmnopqrstuvwxyz'
m.scan.alfUC = translate(m.scan.alfLC)
m.scan.alfa = m.scan.alfLC || m.scan.alfUC
m.scan.alfNum = m.scan.alfa || '0123456789'
return
endProcedure scanIni
scanReset: procedure expose m.
parse arg m, n1, np, co
m.m.rdr = ''
m.m.jReading = 0 /* if called without jReset */
m.m.jWriting = 0
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
if m.m.scanName1 == '' then
m.m.scanName1 = m.scan.alfa
if namePlus == '' then
m.m.scanNameR = m.m.scanName1 || '0123456789'
else
m.m.scanNameR = m.m.scanName1 || namePlus
return m
endProcedure scanOpts
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
return scanOpen(m)
endProcedure scanSrc
scanOpen: procedure expose m.
parse arg m
m.m.tok = ''
m.m.val = ''
m.m.key = ''
m.m.pos = 1
m.m.atEnd = m.m.rdr == ''
m.m.jReading = 1
return m
endProcedure scanOpen
/*--- return the next len characters ---------------------------------*/
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 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 the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
nx = 1 + length(m.m.src)
if len \= '' then
nx = min(m.m.pos + len, nx)
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok \== ''
endProcedure scanChar
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, prefs
m.m.tok = ''
bx = m.m.pos
if prefs = '' then do
qu = substr(m.m.src, bx, 1)
if pos(qu, "'""") < 1 then
return 0
ax = bx + 1
end
else do
do px=1 until abbrev(substr(m.m.src, bx), p1)
p1 = word(prefs, px)
if p1 = '' then
return 0
end
qu = right(p1, 1)
ax = bx + length(p1)
end
m.m.val = ''
do forever
qx = pos(qu, m.m.src, ax)
if qx < 1 then
return scanErr(m, 'ending Apostroph('qu') missing')
m.m.val = m.m.val || substr(m.m.src, ax, qx-ax)
if qx >= length(m.m.src) then
leave
else if substr(m.m.src, qx+1, 1) <> qu then
leave
ax = qx+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.m.src, bx, qx+1-bx)
m.m.pos = qx+1
return 1
endProcedure scanString
/*--- 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
/*--- scan with verify, vOpt is passed to verify ---------------------*/
scanVerify: procedure expose m.
parse arg m, alpha, vOpt, 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 a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if \ scanVerify(m, '0123456789') then
return 0
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure ScanNat
/*--- scan an integer (optional sign, no decpoint ...) ---------------*/
scanInt: procedure expose m.
parse arg m, chEn
call scanLit m, '+', '-'
si = m.m.tok
if \ scanNat(m, chEn) then do
m.m.pos = m.m.pos - si
return 0
end
m.m.tok = si || m.m.tok
return 1
endProcedure scanInt
/*--- scan a number (optional sign, decpoint, exponent) ------------*/
scanNum: procedure expose m.
parse arg m, chEn
sx = m.m.pos
call scanLit m, '+', '-'
po = scanLit(m, '.')
if \ scanNat(m, 0) then do
m.m.pos = sx
return 0
end
if \ po then
if scanLit(m, '.') then
call scanNat m, 0
if scanLit(m, 'e', 'E') then
if \ scanInt(m, 0) then
call scanErr 'exponent expected after' ,
substr(m.m.src, sx, m.m.pos-sx)
m.m.tok = substr(m.m.src, sx, m.m.pos-sx)
m.m.val = translate(m.m.tok)
if chEn \== 0 then
if pos(scanLook(m , 1), m.m.scanNameR) > 0 then
call scanErr m, 'illegal number end after' m.m.tok
return 1
endProcedure scanNum
/*--- 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
if scanString(m) then return 1
if \scanVerify(m, ' 'stopper, 'm') then return 0
m.m.val = m.m.tok
return 1
endProcedure scanWord
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 scanSpaceNl(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
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
call scanErr sc, 'cannot back "'tok'" value'
m.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if \ scanName(m) then
return 0
m.m.key = m.m.tok
if \ scanLit(scanSkip(m), '=') then do
m.m.val = def
m.m.tok = ' no='
end
else if \scanWord(scanSkip(m)) then
return scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
/*--- return true/false whether we are at the end of input ----------*/
scanAtEnd: procedure expose m.
parse arg m
return m.m.atEnd & m.m.pos > length(m.m.src)
endProcedure scanAtEnd
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.m.tok
if m.m.rdr \== '' then
interpret 'res = ' objMet(m, 'scanSpaceNl')
else
res = scanSpaceCom(m)
m.m.tok = lastTok
return res
endProcedure scanSpaceNL
scanSpaceCom: procedure expose m.
parse arg m
res = scanVerify(m, ' ')
if m.m.scanComment \== '' then
if abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
m.m.pos = 1 + length(m.m.src)
return 1
end
return res
endProcedure scanSpaceCom
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
m.m.err.0 = 0
call err 'scanErr' txt'\n'scanInfo(m, m'.ERR')
return 0
endProcedure scanErr
scanPos: procedure expose m.
parse arg m
if m.m.rdr \== '' then
interpret 'return' objMet(m, 'scanPos')
else if scanAtEnd(m) then
return E
else
return 1 m.m.pos
endProcedure scanPos
scanInfo: procedure expose m.
parse arg m
msg = 'last token' m.m.tok 'scanPosition' ,
strip(left(substr(m.m.src, m.m.pos), 40), 't')
if m.m.rdr == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg ||' objMet(m, 'scanInfo')
endProcedure scanInfo
/* copy scan end ****************************************************/
/* copy scanRead begin ************************************************/
scanReadIni: procedure expose m.
if m.scanRead.ini = 1 then
return
m.scanRead.ini = 1
call scanIni
call jIni
ts = classNew('n Scan u f TOK v, f VAL v, f KEY v, f TYPE v')
call classNew 'n ScanRead u JRW', 'm',
, 'jReset call scanReadReset m, arg, arg2, arg3',
, 'jOpen call scanReadOpen m',
, 'jClose if m.m.closeRdr then call jClose m.m.rdr',
, 'jRead call scanType m; call oClaCopy "'ts'", m, var;' ,
'return m.m.type \== ""',
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanInfo scanReadInfo(m)',
, 'scanPos scanReadPos(m)'
return
endProcedure scanReadIni
/*--- begin scanning the lines of a reader ---------------------------*/
scanRead: procedure expose m.
parse arg rdr, n1, np, co
return scanOpts(oNew('ScanRead', rdr), n1, np, co)
scanReadReset: procedure expose m.
parse arg m, r, n1, np, co
call scanReset m, n1, np, co
m.m.rdr = r
return m
endProcedure scanReadReset
scanReadOpen: procedure expose m.
parse arg m, r, n1, np, co
call scanOpen m
m.m.atEnd = 0
m.m.lineX = 0
m.m.closeRdr = jOpenIfNotYet(m.m.rdr, m.j.cRead)
call scanReadNl m, 1
return m
endProcedure scanReadOpen
/*--- 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
interpret objMet(m, 'scanReadNl')
endProcedure scanReadNl
/*--- implementation of scanReadNl ----------------------------------*/
scanReadNLimpl: procedure expose m.
parse arg m, unCond
if unCond \== 1 then
if m.m.pos <= length(m.m.src) then
return 0
if m.m.atEnd then
return 0
m.m.atEnd = \ jRead(m.m.rdr, m'.SRC')
if m.m.atEnd then do
m.m.pos = 1 + length(m.m.src)
end
else do
m.m.pos = 1
m.m.lineX = m.m.lineX + 1
end
return \ m.m.atEnd
endProcedure scanReadNLimpl
scanReadSpaceNl: procedure expose m.
parse arg m
fnd = 0
do forever
if scanSpaceCom(m) then
fnd = 1
if \ scanReadNl(m) then
return fnd
fnd = 1
end
endProcedure scanReadSpaceNl
scanReadPos: procedure expose m.
parse arg m, msg
if scanAtEnd(m) then
return E
else
return m.m.lineX m.m.pos
endProcedure scanReadPos
scanReadInfo: procedure expose m.
parse arg m, msg
if scanAtEnd(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
/* 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 scanIni
call jIni
call classNew 'n ScanWin u JRW', 'm',
, 'jReset call scanWinReset m, arg, arg2, arg3',
, 'jOpen call scanWinOpen m ',
, 'jClose call scanWinClose m ',
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanInfo scanWinInfo(m)',
, 'scanPos scanWinPos(m)'
return
endProcedure scanReadIni
/*--- instanciate a new window scanner, open rdr ---------------------*/
scanWin: procedure expose m.
parse arg rdr, wiSz, wiBa, cuPo, cuLe
return scanWinOpts(oNew('ScanWin', rdr), wiSz, wiBa, cuPo, cuLe)
/*--- set the reader and attributes of window scanner m -------------*/
scanWinReset: procedure expose m.
parse arg m, r, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.rdr = r
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
/*--- set the attributes of window scanner m ------------------------*/
scanWinOpts: procedure expose m.
parse arg m, wiSz, wiGa, cuPo, cuLe
wiSz = word(wiSz 5, 1)
wiGa = word(wiGa 1, 1)
m.m.cutPos = word(cuPo 1, 1)
m.m.cutLen = word(cuLe 72, 1)
m.m.winTot = (wiSz * 2 + wiGa) * m.m.cutLen
m.m.posLim = (wiSz + wiGa) * m.m.cutLen
m.m.posOff = wiGa * m.m.cutLen
return m
endProcedure scanWinReset
/*--- open reader and start scanning --------------------------------*/
scanWinOpen: procedure expose m.
parse arg m, lx
call scanOpen m
m.m.atEnd = 0
if lx = '' then
m.m.lineX = 1
else
m.m.lineX = lx
m.m.pos = 1
m.m.src = ''
call jOpen m.m.rdr, m.j.cRead
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.rdr
return
endProcedure scanWinClose
/*--- 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 // m.m.cutLen + m.m.posOff)
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
do while length(m.m.src) < m.m.winTot /* read and fill to len */
if \ jRead(m.m.rdr, m'.'one) then do
m.m.atEnd = 1
return dlt
end
m.m.src = m.m.src || substr(m.m.one, m.m.cutPos, m.m.cutLen)
end
call assert 'length(m.m.src) = m.m.winTot'
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 over spaces and comments ----------------------------------*/
scanWinSpaceNL: procedure expose m.
parse arg m
res = 0
do forever
r1 = 0
if scanVerify(m, ' ') then do
r1 = 1
end
else if m.m.scanComment \== '' ,
& abbrev(substr(m.m.src, m.m.pos), m.m.scanComment) then do
np = scanWinNlPos(m)
r1 = length(m.m.scanComment) <= np - m.m.pos
if r1 then
m.m.pos = np
end
if r1 then
res = 1
else if scanWinRead(m) = 0 then
return res
end
endProcedure scanWinSpaceNl
/*--- return current position in input ------------------------------*/
scanWinPos: procedure expose m.
parse arg m
if scanAtEnd(m) then
return 'E'
else
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 p == 'E' then do
res = 'atEnd after'
p = m.m.lineX - 1 + length(m.m.src) % m.m.cutLen
end
else do
res = 'pos' word(p, 2) 'in'
p = word(p, 1)
end
return '\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 ----------------------------------*/
scanSql: procedure expose m.
parse arg inRdr
return scanSqlReset(scanWin(inRdr), inRdr)
scanSqlReset: procedure expose m.
parse arg m, r, scanWin
if scanWin \== 0 then
call scanWinOpts m, 5, 2, 1, 72
else
m.m.rdr = r
return scanOpts(m, , '0123456789_' , '--')
scanSqlSeekId: procedure expose m.
parse arg m, lx, cmd, opts
if opts = '' then
opts = word
if adrEdit("cursor =" max(trunc(lx), 1), 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 editReadReset m.m.rdr, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlClass(m)
if m.m.sqlClass = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- 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 scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlClass = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlClass = 's'
if \abbrev(m.m.tok, "'") then
m.m.val = x2c(m.m.val)
end
else if scanSqlQuId(m) 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 scanSqlNum(m, 0, 1) then
m.m.sqlClass = 'n'
else if scanChar(m, 1) then
m.m.sqlClass = m.m.tok
else if scanAtEnd(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
res = ''
rto = ''
do qx=1
if \ scanSqlDeId(m) then do
if qx <> 1 then
call scanErr m, 'id expected after .'
return 0
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 scanSpaceNl 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 ----------------------------------------------*/
scanSqlNum: procedure expose m.
parse arg m, checkEnd, noSp
si = ''
if noSp == 1 then
call err 'deimplement ???? wk'
if noSp \== 1 then do
if scanLit(m, '+', '-') then do
si = m.m.tok
call scanSpaceNl m
ch = scanLook(m, 2)
if left(ch, 1) == '.' then
ch = substr(ch, 2)
if pos(left(ch, 1), '0123456789') < 1 then do
call scanBack m, si
m.m.val = ''
return 0
end
end
end
res = scanNum(m, checkEnd)
m.m.val = si || m.m.val
return res
endProcedure scanSqlNum
/*--- scan a sql number with a unit which may follow without space ---*/
scanSqlNumUnit: procedure expose m.
parse arg m, both, units
if \ scanSqlNum(m, 0) then
return 0
nu = m.m.val
sp = scanSpaceNl(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, 'scanSqlNumUnit after' nu 'bad unit' m.m.val
else
call scanBack m, m.m.tok
end
else if both then
call scanErr m, 'scanSqlNumUnit no unit after' nu
else if \sp & pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNumUnit bad number end after' nu
m.m.val = nu
return 1
endProcedure scanSqlNumUnit
/* copy scanSql end *************************************************/
/* copy scanUtil begin *************************************************
scan db2 utility input statements using scan and a reader
**********************************************************************/
/*--- initialize with reader inRdr ----------------------------------*/
scanUtilReader: procedure expose m.
parse arg m, inRdr
call scanReader m, inRdr
call scanOptions sc, , , '--'
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilSql: procedure expose m.
parse arg inRdr
m = scanSql(inRdr)
call scanUtilReset m
return m
endProcedure scanUtilReader
scanUtilReset: procedure expose m.
parse arg m
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
endProcedure scanUtilReset
/*--- 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 = scanSpaceNl(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 \scanAtEnd(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
/* copy scanUtil end **************************************************/
/* copy pipe begin *****************************************************
***********************************************************************/
pipeIni: procedure expose m.
if m.pipe.ini == 1 then
return
m.pipe.ini = 1
call catIni
call classNew "n PipeFrame u"
call classNew "n PipeFramedRdr u JRWO", "m",
, "jOpen call jOpen never-call-PipeFramedRdr-Open",
, "jReadO call pipePushFrame m;" ,
"res = jReadO(m.m.framedRdr, var);",
"call pipeEnd; return res",
, "jReset never-call-PipeFramedRdr-jReset",
, "jClose call pipeFramedClose m"
call mapReset env.vars
call jReset oMutate("PIPE.framedNoOut", "JRWErr")
m.pipe.0 = 0
call pipeBeLa /* by default pushes in and out */
return
endProcedure pipeIni
pipeOpen: procedure expose m.
parse arg e
if m.e.inCat then
call jClose m.e.in
m.e.inCat = 0
if m.e.in == '' then
m.e.in = m.j.in
else if jOpenIfNotYet(m.e.in, m.j.cRead) then
m.e.toClose = m.e.toClose m.e.in
if m.e.out == '' then
m.e.out = m.j.out
else if jOpenIfNotYet(m.e.out, m.e.outOp) then
m.e.toClose = m.e.toClose m.e.out
return e
endProcedure pipeOpen
pipePushFrame: procedure expose m.
parse arg e
call mAdd pipe, e
m.j.in = m.e.in
m.j.out = m.e.out
return e
endProcedure pipePushFrame
pipeBegin: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
if m.e.out \== '' then
call err 'pipeBegin output redirection' m.e.in
call pipeAddIO e, '>' Cat()
m.e.allInFrame = 1
return pipePushFrame(pipeOpen(e))
endProcedure pipeBegin
pipe: procedure expose m.
px = m.pipe.0
f = m.pipe.px
call pipeClose f
m.f.in = jOpen(m.f.out, '<')
m.f.out = jOpen(Cat(), '>')
m.f.toClose = m.f.in m.f.out
m.j.in = m.f.in
m.j.out = m.f.out
m.e.allInFrame = 1
return
endProcedure pipe
pipeLast: procedure expose m.
px = m.pipe.0
f = m.pipe.px
m.f.in = pipeClose(f)
m.f.out = ''
do ax=1 to arg()
if word(arg(ax), 1) = m.j.cRead then
call err 'pipeLast input redirection' arg(ax)
else
call pipeAddIO f, arg(ax)
end
m.f.allInFrame = 1
if m.f.out == '' then do
preX = px-1
preF = m.pipe.preX
m.f.out = m.preF.out
m.f.allInFrame = m.preF.allInFrame
end
call pipeOpen f
m.j.in = m.f.in
m.j.out = m.f.out
return
endProcedure pipeLast
pipeBeLa: procedure expose m.
e = pipeFrame()
do ax=1 to arg()
call pipeAddIO e, arg(ax)
end
return pipePushFrame(pipeOpen(e))
endProcedure pipeBeLa
/*--- activate the last pipeFrame from stack
and return outputbuffer from current pipeFrame --------------*/
pipeEnd: procedure expose m.
ox = m.pipe.0 /* wkTst??? streamLine|| */
if ox <= 1 then
call err 'pipeEnd on empty stack' ex
ex = ox - 1
m.pipe.0 = ex
e = m.pipe.ex
m.j.in = m.e.in
m.j.out = m.e.out
return pipeClose(m.pipe.ox)
endProcedure pipeEnd
pipeFramedRdr: procedure expose m.
parse arg e
m = pipeFrame()
m.m.jReading = 1
m.m.jWriting = 0
m.m.framedRdr = jOpen(jClose(m.e.out), m.j.cRead)
say 'framedRdr <' m.m.framedRdr
m.m.in = m.e.in
m.m.framedToClose = m.e.toClose
m.e.toClose = ''
m.m.out = "PIPE.framedNoOut"
call oMutate m, 'PipeFramedRdr'
return m
endProcedure pipeFramedRdr
pipeFramedClose: procedure expose m.
parse arg m
m.m.allInFrame = 0
call pipeClose m
call oMutate m, 'PipeFrame'
return
endProcedure pipeFramedClose
pipeFrame: procedure expose m.
m = oBasicNew("PipeFrame")
m.m.toClose = ''
m.m.in = ''
m.m.inCat = 0
m.m.out = ''
m.m.outOp = ''
m.m.allInFrame = 0
return m
endProcedure pipeFrame
pipeClose: procedure expose m.
parse arg m, finishLazy
if m.m.allInFrame == 2 then
return pipeFramedRdr(m)
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m.m.out
endProcedure pipeClose
pipeAddIO: procedure expose m.
parse arg m, opt file
if opt == m.j.cRead then do
if m.m.in == '' then
m.m.in = o2file(file)
else if m.m.inCat then
call catWriteAll m.m.in, o2file(file)
else do
m.m.in = jOpen(cat(m.m.in, o2file(file)), m.j.cApp)
m.m.inCat = 1
end
return m
end
if \ (opt = m.j.cWri | opt == m.j.cApp) then
call err 'pipeAddIO('opt',' file') bad opt'
else if m.m.out \== '' then
call err 'pipeAddIO('opt',' file') duplicate output'
m.m.out = o2file(file)
m.m.outOp = opt
return m
endProcedure pipeAddIO
/*--- 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
/*--- write all from rdr (rsp in) to out, possibly lazy
do lazy reads within current frame -----------*/
pipeWriteAllFramed: procedure expose m.
parse arg rdr
if rdr == '' then
rdr = m.j.in
px = m.pipe.0
f = m.pipe.px
if m.f.allInFrame = 0 then do
call jWriteNow m.j.out, rdr
return
end
m.f.allInFrame = 2
call jWriteall m.j.out, rdr
return
endProcedure pipeWriteFramed
pipePreSuf: procedure expose m.
parse arg le, ri
do while in(v)
call out le || m.v || ri
end
return
endProcedure pipePreSuf
/*--- out interface of pipe -----------------------------------------*/
outIni: procedure expose m.
call pipeIni
return
endProcedure outIni
outPush: procedure expose m.
parse arg st
call pipeBeLa '>' oNew('JRWOut', st)
return
endProcedure outPush
outPop: procedure expose m.
call pipeEnd
return
endProcedure outPop
/*--- write all from rdr (rsp in) to a new jBuf --------------------*/
env2Buf: procedure expose m. /*wkTst remove |||| */
parse arg rdr
b = jOpen(jBuf(), m.j.cWri)
call jWriteNow b, if(rdr=='', m.j.in, rdr)
return jClose(b)
endProcedure env2Buf
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGetO: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envGet: procedure expose m.
parse arg na
return o2String(mapGet(env.vars, na))
endProcedure envGet
envRead: procedure expose m.
parse arg na
return in("ENV.VARS."na)
envReadO: procedure expose m.
parse arg na
if \ inO("ENV.VARS.OBJ."na) then
return 0
call envPutO na, "ENV.VARS.OBJ."na
return 1
if \ inO('ENV.XX') then
return 0
call envPut na, m.env.xx
return 1
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na) /*wkTst??? remove?*/
envPutO: procedure expose m.
parse arg na, ref
return mapPut(env.vars, na, ref)
envPut: procedure expose m.
parse arg na, va
call mapPut env.vars, na, s2o(va)
return va
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, 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.catRdClose = 0
m.m.catIx = -9e9
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
if m.m.catRdClose then
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 \== '' & m.m.catRdClose 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
m.m.catRdClose = jOpenIfNotYet(m.m.catRd , m.j.cRead)
return 1
endProcedure catNextRdr
catReadO: procedure expose m.
parse arg m, var
do while m.m.catRd \== ''
if jReadO(m.m.catRd, var) then
return 1
call catNextRdr m
end
return 0
endProcedure catReadO
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
catWriteO: procedure expose m.
parse arg m, var
if m.m.catWr == '' then
m.m.catWr = jOpen(jBuf(), m.j.cWri)
call jWriteO m.m.catWr, var
return
endProcedure catWriteO
/*--- 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()
call mAdd m'.RWS', o2File(arg(ax))
end
return
endProcedure catWriteAll
/*--- create a reader/WriteO for an external file --------------------*/
file: procedure expose m.
parse arg str
if abbrev(str, m.j.cVar) then do
var = substr(str, 2)
if envHasKey(var) then
return envGetO(var)
else
return envPutO(var, jBuf())
end
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
return oNew('FileList', filePath(m), opt)
endProcedure fileList
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
call jIni
call classNew "n Cat u JRWO", "m",
, "jOpen return catOpen(m, opt)",
, "jReset return catReset(m, arg)",
, "jClose call catClose m",
, "jReadO return catReadO(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteO call catWriteO m, var; return",
, "jWriteAll call catWriteAll m, rdr; return"
os = errOS()
if os == 'TSO' then
call fileTsoIni
else if os == 'LINUX' then
call fileLinuxIni
else
call err 'file not implemented for os' os
return
endProcedure catIni
/* copy cat 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.class.o2c.var = m.class.classV
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.m \== value('m.'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
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 return fileLinuxReset(m, arg)",
, "jOpen return fileLinuxOpen(m, opt)",
, "jClose call fileLinuxClose m",
, "jRead return fileLinuxRead(m, var)",
, "jWrite call fileLinuxWrite m, line",
, "jWriteO call jWrite m, o2String(var)",
, "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 return fileLinuxListReset(m, arg, arg2)",
, "jOpen return 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'
if symbol('m.m.defDD') \== 'VAR' then do
ix = mInc('FILETSO.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'FILETSO.BUF'ix
m.m.spec = sp
end
if sp \== '' then do
m.m.spec = dsnSpec(sp)
rr = translate(subword(m.m.spec, 4))
m.m.stripT = \ (pos(':V', rr) > 0 | pos('RECFM(V', rr) > 0)
end
return m
endProcedure fileTsoReset
fileTsoOpen: procedure expose m.
parse arg m, opt
buf = m.m.buf
if opt == m.j.cRead then do
aa = dsnAlloc(m.m.spec, 'SHR', m.m.defDD)
if m.dsnAlloc.dsn <> '' then
if sysDsn("'"m.dsnAlloc.dsn"'") <> 'OK' then
call err 'cannot read' m.dsnAlloc.dsn':',
sysDsn("'"m.dsnAlloc.dsn"'")
call readDDBegin word(aa, 1)
m.m.jReading = 1
m.buf.0 = -1
m.m.readIx = 0
end
else do
if opt == m.j.cApp then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else if opt == m.j.cWri then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else
call err 'fileTsoOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
m.m.jWriting = 1
m.buf.0 = 0
m.m.readIx = 'w'
end
m.m.dd = word(aa, 1)
m.m.free = subword(aa, 2)
return m
endProcedure fileTsoOpen
fileTsoClose:
parse arg m
buf = m.m.buf
if m.m.readIx \== 'c' then do
if m.m.readIx == 'w' then do
if m.buf.0 > 0 then
call writeDD m.m.dd, 'M.'BUF'.'
call writeDDend m.m.dd
end
else do
call readDDend m.m.dd
end
interpret m.m.free
end
m.buf.0 = 'closed'
m.m.readIx = 'c'
m.m.free = ''
m.m.dd = ''
return m
endProcedure fileTsoClose
fileTsoRead: procedure expose m.
parse arg m, var
ix = m.m.readIx + 1
buf = m.m.buf
if ix > m.buf.0 then do
res = readDD(m.m.dd, 'M.'buf'.')
if \ res then
return 0
ix = 1
end
m.m.readIx = ix
m.var = m.buf.ix
call oMutate var, m.class.classV
return 1
endProcedure fileTsoRead
fileTsoWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
if m.m.stripT then
m.buf.ix = strip(var, 't')
else
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure fileTsoWrite
fileTsoWriteO: procedure expose m.
parse arg m, var
if objClass(var, m.class.classV) == m.class.classV then do
call fileTsoWrite m, m.var
return
end
call err 'fileTsoWriteO('m',' var') cannot write objects of class',
objClass(var)
endProcedure fileTsoWriteO
jclSub: procedure expose m.
return file('.sysout(T) writer(intRdr)')
endProcedure jclSub
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 return fileTsoOpen(m, opt)",
, "jReset return fileTsoReset(m, arg)",
, "jClose call fileTsoClose m",
, "jRead return fileTsoRead(m, var)",
, "jWrite call fileTsoWrite m, line",
, "jWriteO call fileTsoWriteO m, var",
, "filePath return word(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; m.m.jReading=1; return",
, "jClose" ,
, "jRead return csiNext(m, var)"
return
endProcedure fileTsoIni
/* copy fileTso end *************************************************/
/* copy sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
m.sqlO.cursors = left('', 10, 'r')left('', 30, ' ')
call sqlIni
call pipeIni
call classNew 'n SqlSel u JRWO', 'm',
, "jReset m.m.src = arg; m.m.type = arg2;",
"m.m.fetch = ''; m.m.type=''; m.m.cursor=''",
, "jOpen call sqlSelOpen m, opt",
, "jClose call sqlSelClose m",
, "jReadO return sqlSelRead(m, var)"
/* call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
*/ return
endProcedure sqlOini
sqlSel: procedure expose m.
parse arg src, type
return oNew('SqlSel', src, type)
endProcedure sqlSel
sqlSel1: procedure expose m.
parse arg src, type, var
r = jOpen(oNew('SqlSel', src, type), '<')
if \ jReadO(r, var) then
call err 'eof on 1. Read in sqlSel1'
if jReadO(r, sqlSql.ver) then
call err 'not eof on 2. Read in sqlSel1'
call jClose r
return
endProcedure sqlSel1
/*--- prepare and open cursor
generate type and fetchList ------------------------------------*/
sqlSelOpen: procedure expose m.
parse arg m, opt
if opt\== m.j.cRead then
call err 'opt not' m.j.cRead 'sqlSelOpen('m',' opt')'
m.m.cursor = sqlGetCursor(m.m.cursor)
call sqlPreOpen m.m.cursor, m.m.src, m.m.type == ''
if m.m.type == '' then do
m.m.type = sqlDA2type('SQL.'m.m.cursor'.D')
m.m.fetch = ''
end
if m.m.fetch == '' then
m.m.fetch = sqlFetchVars(m.m.type, 'M.V')
m.m.jReading = 1
return m
endProcedure sqlOpen
/*--- return a free cursor -------------------------------------------*/
sqlGetCursor: procedure expose m.
parse arg last
cx = 0
if datatype(last, 'n') & last>0 & last<=length(m.sqlO.cursors) then
if pos(substr(m.sqlo.cursors, last, 1), 'c ') > 0 then
cx = last
if cx == 0 then
cx = pos(' ', m.sqlo.cursors)
if cx == 0 then
cx = pos('c', m.sqlo.cursors)
if cx = 0 then
call err 'no more cursors' m.sqlo.cursors
m.sqlo.cursors = overlay('o', m.sqlo.cursors, cx)
return cx
endProcedure sqlGetCursor
/*--- mark a cursor as closed ----------------------------------------*/
sqlFreeCursor: procedure expose m.
parse arg cx
if cx < 1 | cx > length(m.sqlo.cursors) then
call err 'bad cursor sqlFreeCursor('cx')'
m.sqlo.cursors = overlay('c', m.sqlo.cursors, cx)
return cx
endProcedure sqlFreeCursor
/*--- create a type for a sqlDA --------------------------------------*/
sqlDA2type: procedure expose m.
parse arg da , ind
ff = ''
do ix=1 to m.da.sqlD
f1 = word(m.da.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
if (ind == 1 & m.da.ix.sqlType // 2 = 1) | ind == 2 then
ff = ff', f' f1' v, f' f1'.IND v'
else
ff = ff', f' f1 'v'
end
return classNew('n SQL* u' substr(ff, 3))
endProcedure sqlGenType
/*--- create the fetch vars sql syntx -------------------------------*/
sqlFetchVars: procedure expose m.
parse arg cla, pre
vv = ''
f = class4name(cla)'.FLDS'
la = '?'
do fx=1 to m.f.0
if la'.IND' \== m.f.fx then
vv = vv','
vv = vv ':'pre || m.f.fx
end
return substr(vv, 3)
endProcedure sqlFetchVars
/*--- fetch cursor for this sqlSel -----------------------------------*/
sqlSelRead: procedure expose m.
parse arg m, v
call oMutate v, m.m.type
return sqlFetchInto(m.m.cursor, m.m.fetch)
endProcedure sqlSelRead
/*--- close sql Cursor -----------------------------------------------*/
sqlSelClose: procedure expose m.
parse arg m, v
call sqlClose m.m.cursor
call sqlFreeCursor m.m.cursor
return m
endProcedure sqlSelClose
/*--- fetch cursor 'c'cx into destination dst
each column is formatted and assigned to m.dst.<colName> ---*/
sqlFetch: procedure expose m.
parse arg cx, dst
if ^ sqlFetchInto(cx, 'descriptor :M.SQL.'cx'.D') then
return 0
if dst == '' then
return 1
fi = oFlds(sqlType(cx))
fo = m.sql.cx.fmt
do ix=1 to m.sql.cx.d.SQLD
f = m.fi.ix
if m.sql.cx.d.ix.sqlInd = 0 then
m.dst.f = fmt(m.sql.cx.d.ix.sqlData, m.fo.ix)
else
m.dst.f = fmtS(m.sqlNull, m.fo.ix)
end
return 1
endProcedure sqlFetch
/*--- fetch all rows into stem st
from sql src using type ty and format fmt -----------------*/
sql2St: procedure expose m.
parse arg st, src, ty, fmt
cx = 49
call sql2Cursor cx, src, ty, fmt
call sqlOpen cx
do ix=1 by 1 while sqlFetch(cx, st'.'ix)
end
m.st.0 = ix-1
call sqlClose cx
return ix-1
endProcedure sql2St
/*--- prepare statement 's'cx and declare cursor 'c'cx from sql src
use or generate type ty and format fo ---------------------*/
sql2Cursor: procedure expose m.
parse arg cx, src, ty, fo
call sqlPreDeclare cx, src, 1 /* with describe output */
call sqlGenType cx, ty
m.Sql.cx.FMT.0 = 0
m.Sql.cx.FMT = sqlGenFmt('SQL.'cx'.FMT', cx, fo)
call assert 'm.'m.sql.cx.fmt'.0 >= m.sql.cx.d.sqlD', 'too few fmt'
return
endProcedure sql2Cursor
/*--- return the type for sql cx -------------------------------------*/
sqlType: procedure expose m.
parse arg cx
return oGetTypePara('SQL.TY.'cx)
/*--- fetch cursor 'c'cx
put the formatted and concatenated columns into m.var
return 1 if a row fetched, 0 if not ------------------------*/
sqlFetchLn: procedure expose m.
parse arg cx, var
st = 'SQL.'cx'.FET'
if ^ sqlFetch(cx, st) then
return 0
m.var = oFldCat(sqlType(cx), st, m.sql.cx.fmt)
return 1
endProcedure sqlFetchLn
/*--- generate the type sql cx as specified in ty
use the information from the sqlDa -------------------------*/
sqlGenType: procedure expose m.
parse arg cx, ty
if ty == '*' | ty = '' then do
ff = ''
do ix=1 to m.sql.cx.d.sqlD
f1 = word(m.sql.cx.d.ix.sqlName, 1)
if f1 == '' then
f1 = 'COL'ix
ff = ff f1
end
ty = oFldOnly(ff, 'e')
end
call oSetTypePara 'SQL.TY.'cx, ty, 'noCall'
return ty
endProcedure sqlGenType
/*--- generate the format ff for a sql cx as specified in sp
use the information from the sqlDa -------------------------*/
sqlGenFmt: procedure expose m.
parse arg ff, cx, sp
if abbrev(sp, '=') then
return substr(sp, 2)
if sp = '' then
sp = '*st'
m.ff.0 = m.sql.cx.d.sqlD
m.ff.flds = oFlds(sqlType(cx))
if abbrev(sp, '*') then do
do ix=1 to m.ff.0
m.ff.ix = substr(sp, 2)
end
return ff
end
if abbrev(fmts, '=') then
m.Sql.cx.FMT = substr(fmts, 2)
defs = 'ir7 fr9 sl12 Tl26' sp
do wx = 1 to words(defs)
parse value word(defs, wx) with ty 2 fo
select
when ty = 'd' then t.384 = fo
when ty = 'f' then t.480 = fo'/f'
when ty = 'i' then t.496 = fo'/i'
when ty = 'n' then t.484 = fo'/n'
when ty = 's' then t.448 = fo
when ty = 't' then t.388 = fo
when ty = 'T' then t.392 = fo
otherwise call err 'bad type' ty 'for format' fo
end
end
if symbol('t.496') == 'VAR' then
t.500 = t.496
if symbol('t.448') == 'VAR' then do
t.452 = t.448
t.456 = t.448
t.464 = t.448
end
do wx = 1 to m.ff.0
ty = m.sql.cx.d.wx.sqlType
le = m.sql.cx.d.wx.sqlLen
withNulls = ty // 2
ty = ty - withNulls
if symbol('t.ty') <> 'VAR' then
call err 'sqlType' ty 'not supported'
parse var t.ty fo 2 fl '/' op
if op = 'i' then
if le = 2 then le = 6
else le = 12
else if op <> '' then
call err 'length for sqlType' ty 'op' op 'not implemented'
if fl = '=' then
fl = le
else if abbrev(fl, '<') then
fl = min(le, substr(fl, 2))
m.ff.wx = fo || fl
end
return ff
endProcedure sqlGenFmt
/*--- sql o interface ------------------------------------------------*/
/*--- return a reader for the givenn sql or std input ----------------*/
sql2Obj: procedure expose m.
parse arg cx, src, ty, fo
if ty = '' then
ty = '*'
if src == '' then
src = envCatStr(' ', 'sb')
call sql2Cursor cx, src, ty, substr(fo, 1+abbrev(fo, '~'))
call oMutate 'SQL.TY.'cx, 'SqlType'
return 'SQL.TY.'cx
endProcedure sql2obj
/*--- write to std output the result columns of
the sql given in src or std input --------------------------*/
sql: procedure expose m.
parse arg cx, src, ty, fo
call jWriteAll m.j.out, "r£", sql2Obj(cx, src, ty, fo)
return
endProcedure sql
/*--- write to std output the result lines of
the sql given in src or std input --------------------------*/
sqlLn: procedure expose m.
parse arg cx, src, ty, fo
if fo = '' then
fo = '~'
squash = abbrev(fo, '~')
if ^ abbrev(fo, '=') then
fo = left(fo, squash) 'sl=' substr(fo, squash+1)
t = sql2Obj(cx, src, ty, fo)
if squash then do
call fmtFldSquashRw t, 'opCl'
return
end
m = 'SQL.LN.'cx
call oMutate m, 'SqlLn'
call jWrite m.j.out, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.out, "r£", m
return
endProcedure sqlLn
/* copy sqlO end **************************************************/
/* copy sql begin ***************************************************
sql interface
***********************************************************************/
sqlIni: procedure expose m.
m.sqlNull = '---'
return
endProcedure sqlIni
/*--- prepare statement 's'cx from sql src into descriptor desc ------*/
sqlPrepare: procedure expose m.
parse arg cx, src, descOut, descInp
s = ''
if descOut == 1 then
s = 'into :M.SQL.'cx'.D'
call sqlExec 'prepare s'cx s 'from :src'
if descInp == 1 | (descInp == '' & pos('?', src) > 0) then
call sqlExec 'describe input s'cx 'into :M.SQL.'cx'.I'
else
m.sql.cx.i.sqlD = 0
return
endProcedure
/*--- prepare and declare 'c'cx from sql src -------------------------*/
sqlPreDeclare: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPrepare cx, src, descOut, descInp
call sqlExec 'declare c'cx 'cursor for s'cx
return
endProcedure sqlPreDeclare
/*--- prepare, declare and open 'c'cx from sql src -------------------*/
sqlPreOpen: procedure expose m.
parse arg cx, src, descOut, descInp
call sqlPreDeclare cx, src, descOut, descInp
call sqlOpen cx
return
endProcedure sqlPreOpen
/*--- open cursor 'c'cx using arguments arg(2), arg(3)... ------------*/
sqlOpen: procedure expose m.
parse arg cx
do ix=1 to arg()-1
call sqlDataSet 'SQL.'cx'.I', ix, arg(ix+1)
end
call sqlExec 'open c'cx 'using descriptor :M.SQL.'cx'.I'
return
endProcedure sqlOpen
/*--- close cursor 'c'cx ---------------------------------------------*/
sqlClose: procedure expose m.
parse arg cx, src
return sqlExec('close c'cx)
endProcedure sqlClose
/*--- fetch cursor 'c'cx into variables ggVars -----------------------*/
sqlFetchInto:
parse arg ggCx, ggVars
if ggVars == '' then
ggVars = 'descriptor :M.SQL.'ggCX'.D'
/* accept sqlCodes > 0 except 100 */
return sqlExec('fetch c'ggCx 'into' ggVars, 0 100) <> 100
endProcedure sqlFetchInto
/*--- return sql variable list for stem st and fields the word in vars
if withInd == 1 then with sqlIndicator variables
sqlVars('S', 'A B') --> ':S.A, :S.B'
sqlVars('S', 'A B', 1) --> ':S.A :S.A.SQLIND, :S.B :S.B.SQLIND'
----------------------------------------------------------------------*/
sqlVars: procedure expose m.
parse arg st, vars, withInd
res = ''
if st ^== '' then
st = st'.'
do ix=1 to words(vars)
res = res', :'st || word(vars, ix)
if withInd == 1 then
res = res ':'st || word(vars, ix)'.SQLIND'
end
return substr(res, 3)
endProcedure sqlVars
sqlVarsNull: procedure expose m.
parse arg st, vars
hasNulls = 0
do ix = 1 to words(vars)
fld = word(vars, ix)
if m.st.fld.sqlInd < 0 then do
m.st.fld = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlVarsNull
sqlDescNull: procedure expose m.
parse arg cx
desc = 'SQL.'ggCX'.D',
hasNulls = 0
do ix=1 to m.desc.SQLD
if m.desc.ix.sqlInd < 0 then do
m.desc.ix.sqlData = m.sqlNull
hasNulls = 1
end
end
return hasNulls
endProcedure sqlDescNull
/*--- open cursor 'c'cx fetch all into variables vars and close
st = passed stem, sx = row number
return number of rows fetched ----------------------------------*/
sqlOpAllCl:
parse arg ggCx, st, ggVars
do ggAx=4 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-3, arg(ggAx)
end
call sqlOpen ggCx
do sx = 1 while sqlFetchInto(ggCx, ggVars)
end
m.st.0 = sx - 1
call sqlClose ggCx
return m.st.0
endProcedure sqlOpAllCl
sqlDataSet: procedure expose m.
parse arg da, ix, val
m.da.ix.sqlData = val
m.da.ix.sqlInd = - (arg(ix+2) == m.sqlNull)
return
endProcedure sqlDataSet
/*--- prepare, declare open cursor 'c'cx, fetch all and close
return number of rows fetched ----------------------------------*/
sqlPreAllCl:
parse arg ggCx, ggSrc, st, ggVars
call sqlPreDeclare ggCx, ggSrc
return sqlOpAllCl(ggCx, st, ggVars)
endProcedure sqlPreAllCl
/*--- execute statement 's'cx using arguments arg(2), arg(3)... ------*/
sqlExecute:
parse arg ggCx retOk
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
return sqlExec('execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I',
, retOk)
endProcedure
/*--- execute immediate the sql src ----------------------------------*/
sqlExImm:
parse arg ggSrc, ggRet
return sqlExec('execute immediate :ggSrc', ggRet)
endProcedure sqlExImm
sqlCommit: procedure expose m.
parse arg src
return sqlExec('commit')
endProcedure sqlCommit
/*--- execute sql thru the dsnRexx interface -------------------------*/
sqlExec: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggRet, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
/* say 'sqlCode' sqlCode 'rc' rc 'for' ggSqlStmt ggNo */
if rc = 0 then
return 0
else if ggRet = '*' | wordPos(sqlCode, ggRet) > 0 then
return sqlCode
else if rc < 0 then
call err sqlmsg()
else if sqlWarn.0 ^== ' ' | sqlCode <> 0 then
call errSay sqlMsg(), ,'w'
return sqlCode
endSubroutine sqlExec
/*--- connect to the db2 subsystem ggSys -----------------------------*/
sqlConnect: procedure expose m.
parse arg ggSys, ggRetCon
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 ggSys = '-' then
return 0
return sqlExec("connect" ggSys, ggRetCon ,1)
endProcedure sqlConnect
/*--- diconnect from db2 ---------------------------------------------*/
sqlDisconnect: procedure expose m.
parse arg ggRet
return sqlExec("disconnect ", ggRet, 1)
endProcedure sqlDisconnect
/*--- issue an sql error message -------------------------------------*/
sqlMsg: /* no procedure, to keep variables sql... */
signal on syntax name sqlMsgOnSyntax
ggRes = 'sqlCode' sqlCodeT(sqlCode, sqlErrMc, sqlwarn.0':' ,
|| sqlwarn.1||sqlwarn.2||sqlwarn.3||sqlwarn.4||sqlwarn.5',',
|| sqlwarn.6||sqlwarn.7||sqlwarn.8||sqlwarn.9||sqlwarn.10)
if 0 then
sqlMsgOnSyntax: do
ggRes = 'sqlCode' sqlCode translate(sqlErrMc, ',', 'ff'x),
'<<rexx sqlCodeT not found or syntax>>\nwarnings'
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggRes = ggRes ggx'='sqlWarn.ggx
end
end
signal off syntax
ggRes = ggRes'\nstate' sqlState'\nstmt = ' ggSqlStmt
ggPref = '\nwith'
ggXX = pos(':', ggSqlStmt)+1
do 12 while ggXX > 1
ggYY = verify(ggSqlStmt, ' ,:+-*/&%?|()[]', 'm', ggXX)
if ggYY < 1 then
ggYY = length(ggSqlStmt) + 1
ggVar = substr(ggSqlStmt, ggXX, ggYY - ggXX)
if ggVar <> '' then do
ggRes = ggRes || ggPref ggVar '=' value(ggVar)
ggPref = '\n '
end
ggXX = pos(':', ggSqlStmt, ggYY+1) + 1
end
return ggRes
endSubroutine sqlMsg
/*--- 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
/* copy sql end **************************************************/
/* copy csi begin ***************************************************
csi interface: see dfs managing catalogs appendix c
returncode/reason see message IDC3009I
**********************************************************************/
/*--- specify dsn mask and fields to start a csi catalog search --------
arguments:
m objectPointer
dsnMask specifies the dsns with wildcards:
% 1 character
* 0 - n character in one level
** 0 - n levels
fields a (space separated) list of field names -------------*/
csiOpen: procedure expose m.
parse arg m, dsnMask, fields
m.m.fld.0 = words(fields)
ffix = d2c(m.m.fld.0, 2)
do x=1 to m.m.fld.0
m.m.fld.x = translate(word(fields, x))
ffix = ffix || left(m.m.fld.x, 8)
end
if dsnMask \== '' & pos('*', dsnMask) < 1 then
dsnMask = dsnMask'.**'
m.m.filt = left(dsnMask, 149) ,
|| left('Y', 3) , /* resume offset 149 */
|| ffix /* csiNumEn offset 152 */
WORKLEN = 1024 * 64
m.m.work = D2C(WORKLEN,4) || COPIES('00'X,WORKLEN-4)
m.m.pos = workLen + 1
return
endProcedure csiOpen
/*--- put the next dsn into m.o and m.o.* (for other fields)
return 1 if next dsn exists 0 otherwise ------------------------*/
csiNext: procedure expose m.
parse arg m, o
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET AMOUNT OF WORK AREA USED */
px = m.m.pos
do forever
if px > usedL then do
if substr(m.m.filt, 150, 1) \== 'Y' then do
m.m.pos = px
m.o = ''
return 0
end
reason = left('', 4)
ADDRESS LINKPGM 'IGGCSI00 reason m.'m'.filt m.'m'.work'
if rc == 0 & substr(reason, 3, 2) == '0000'x then
nop
else if rc == 4 & substr(reason, 3, 2) == '0464'x then
say 'data set entry with error'
else
call err 'call csi returns' rc,
'rc' c2d(substr(reason, 4,1)),
'reason' c2d(substr(reason, 3,1)),
'module' substr(reason, 1,2)
usedL = C2D(SUBSTR(m.m.work,9,4)) /* GET WORK AREA USED */
numFD = C2D(SUBSTR(m.m.work,13,2)) /* no flds + 1 */
if numFd <> m.m.fld.0 + 1 then
call err 'csiNumFd' numFd 'not' m.m.fld.0 '+' 1
px = 15
iterate
end
eType = substr(m.m.work, px+1, 1)
m.o = strip(substr(m.m.work, px+2, 44), 't')
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o 'flag' c2x(flag) */
if eType == '0' then do
if flag \== '00'x & flag \== '40'x then
call err 'flag' c2x(flag) 'for catalog' m.o
px = px + 50 /* length of catalog entry */
iterate
end
else do
if \ abbrev(x2b(c2x(flag)), '101') then
call err 'call csi entry flag' x2b(c2x(flag)),
'rc' c2d(substr(m.m.work, px+49,1)),
'reason' c2d(substr(m.m.work, px+48,1)),
'module' substr(m.m.work, px+46, 2),
'for entry' m.o,
'see qw IDC3009I'
py = px + 46
tl = c2d(substr(m.m.work, py, 2))
pl = py + 4
pf = py + m.m.fld.0 * 2 + 4
do fx = 1 to m.m.fld.0
fi = m.m.fld.fx
fl = c2d(substr(m.m.work, pl, 2))
m.o.fi = substr(m.m.work, pf, fl)
if fi = 'MGMTCLAS' then
m.o.fi = substr(m.o.fi, 3, c2d(left(m.o.fi ,2)))
else if wordPos(fi, 'COMUDSIZ NOBYTTRK') > 0 then
m.o.fi = c2d(m.o.fi)
pf = pf + fl
pl = pl + 2
end
if py + tl <> pf then
call err 'length mismatch for entry' m.o
m.m.pos = pf
return 1
end
end
endProcedure csiNext
/*--- if dsn is arcived return 'arcive'
if dsn is tape return 'tape'
otherwise return managment class ------------------------------*/
csiArcTape: procedure expose m.
parse arg vo, cl, dt, dsn
if vo = '' then
say err '||| no volume for dsn' dsn
else if vo = 'ARCIVE' then
res = 'arcive'
else if cl <> '' then
res = cl
else if abbrev(vo, 'SHR') then
res = 'SHR'
else
res = 'tape'
if res = 'arcive' then
return res
/*if abbrev(res, 'ar') \= abbrev(dt, '00'x) , */
if abbrev(res, 'ta') \= abbrev(c2x(left(dt, 1)), '7') ,
| (left(res, 1) >= 'A') \= abbrev(dt, '30'x) then
say '||| mismatch cl' cl 'vo' vo 'dt' c2x(dt) 'dsn' dsn
return res
endProcedure csiArcTape
/* copy csi end ******************************************************/
/* copy csm begin ******************************************************
interface to csm,
it is integrate with adrTso, eg. dsnAlloc , 'RZ3/..' uses csm
***********************************************************************/
adrCsm:
return adrTso('csmExec' arg(1), arg(2))
endProcedure adrCsm
csmCopy: procedure expose m.
parse arg csnFr, csnTo, ggRet
if dsnGetMbr(csnTo) ^= '' ,
& dsnGetMbr(csnFr) <> dsnGetMbr(csnTo) then
call err 'member rename' csnFr 'to' csnTo
parse value csmSysDsn(csnFr) with sysFr '/' dsnFr
parse value csmSysDsn(csnTo) with sysTo '/' dsnTo
if sysFr = '*' & sysTo <> '*' then do
pdsTo = dsnSetMbr(dsnTo)
al = "SYSTEM("sysTo") DDNAME(COPYTo)",
"DATASET('"pdsTo"') DISP(SHR)"
alRes = dsnAlloc(systo'/'pdsTo, ,'COPYTO', '*')
if datatype(alRes, 'n') then do
/* wir müssen es selbst allozieren csmxUtil
vergisst management class ||||| */
say 'could not allocate' al
say 'trying to create'
rc = listDsi("'"dsnSetMbr(dsnFr)"' SMSINFO")
if rc = 0 then
mv = ''
else if rc = 4 & sysReason = 19 then do
mv = 'UNITCNT(30)'
say 'multi volume' mv
end
else if rc ^= 0 then
call err 'listDsi rc' rc 'reason' sysReason,
sysMsgLvl1 sysMsgLvl2
al = left(al, length(al)-4)'CAT)'
if right(sysDsSms, 7) == 'LIBRARY' ,
| abbrev(sysDsSms, 'PDS') then
al = al 'DSNTYPE(LIBRARY)'
if sysUnits = 'TRACK' then
sysUnits = 'TRACKS'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits mv
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.RZ1.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse arg dsn dd disp rest ':' nn, retRc
sys = ''
a2 = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if dsn <> '' then do
a2 = "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
a2 = a2 'MEMBER('mbr')'
end
if abbrev(disp, 'SYSOUT(') then
a2 = a2 disp
else
a2 = a2 "DISP("disp")"
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al a2 rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrCsm('allocate' al a2 rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 then
return err('cmsAlloc rc' alRc 'for' al rest)
say 'csmAlloc rc' alRc 'for' al a2 rest '...trying to create'
nn = al 'disp(cat)' dsnCreateAtts(dsn, nn, 1)
call adrCsm 'allocate' nn
call adrTso 'free dd('dd')'
end
endProcedure csmAlloc
csmSysDsn: procedure expose m.
parse upper arg dsn, withStar
if pos('/', dsn) < 1 then
sys = '*'
else
parse var dsn sys '/' dsn
if sys <> '' & sys <> '*' & sys <> sysvar(sysnode) then
return sys'/'dsn
else if withStar == 0 then
return dsn
else
return '*/'dsn
endProcedure csmSysDsn
/* copy csm end********************************************************/
/* copy adrIsp begin *************************************************/
/**********************************************************************
lmd: catalog read
call sequence: lmdBegin, lmdNext*, lmdEnd
mit lmd service (mit save in file und read,
weil list zu langsam und listcat abstürzt)
1. arg (grp) als group dataset für lmd save
und dd name für file read
***********************************************************************/
lmdBegin: procedure expose m.
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
res = adrIsp('lmdlist listid(&lmdId) option(save) group('grp')', 4)
call adrIsp 'lmdfree listid(&lmdId)'
if res = 0 then do
call trc timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' timing() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
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 readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
lmd: procedure expose m.
parse arg lev, withVol
call lmdBegin gg1, lev
do while lmdNext(gg1, q., withVol)
do x=1 to q.0
call out q.x
end
end
call lmdEnd gg1
return
endProcedure lmd
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmm: procedure expose m.
parse arg dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
call out m
end
call lmmEnd id
return
endProcedure lmm
lmmBegin: procedure expose m.
parse arg dsn
mbr = dsnGetMbr(dsn)
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET('"pds"') ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(INPUT) "
res = lmmId
if mbr <> '' then
res = res 'pattern('mbr')'
return res
endProcedure lmmBegin
lmmEnd: procedure expose m.
parse arg lmmId opt
call adrIsp "LMMLIST DATAID("lmmId") option(free)", 8
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure expose m.
parse arg lmmId opt
if adrIsp("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return strip(mbr)
else
return ''
endProcedure lmmNext
lmmRm: procedure expose m.
parse arg dsn, mbrs
mbrs = dsnGetMbr(dsn) mbrs
pds = dsnSetMbr(dsn, )
call adrIsp "LMINIT DATAID(lmmId) DATASET("pds") ENQ(SHRW)"
call adrIsp "LMOPEN DATAID("lmmId") OPTION(OUTPUT) "
err = ''
do wx=1 to words(mbrs)
m1 = word(mbrs, wx)
rr = adrIsp("lmmDel dataid("lmmId") member("m1")", 0 8 12)
if rc = 0 then
say 'removed' m1 'from' pds
else if rc = 8 then
say 'not found' m1 'in' pds
else do
err = 'error deleting' m1 'in' pds 'rc' rr strip(zerrlm)
say err
leave
end
end
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
if err <> '' then
call err err
return
endProcedure lmmRm
/*--- address ispf with error checking -------------------------------*/
adrIsp:
parse arg ggIspCmd, ggRet
address ispexec ggIspCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr ispExec rc' rc 'in' ggIspCmd':' strip(zerrlm)
endSubroutine adrIsp
/*--- address editor with error checking -----------------------------*/
adrEdit:
parse arg ggEditCmd, ggRet
address isrEdit ggEditCmd
if rc = 0 then return 0
else if ggRet == '*' then return rc
else if wordPOS(rc, ggRet) > 0 then return rc
else
call err 'adr isrEdit rc' rc 'for' ggEditCmd
endSubroutine adrEdit
/* copy adrIsp end *************************************************/
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- 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 */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
call outtrap off
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(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)'
interpret subword(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
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy sleep begin ***************************************************/
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
/* copy sleep end *****************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
call objMetClaM m, 'jRead'
if m.m.jReading then
interpret ggCode
else
return err('jRead('m',' var') but not opened r')
endProcedure jRead
jReadO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jReadO'
if m.m.jReading then
interpret ggCode
else
return err('jReadO('m',' var') but not opened r')
endProcedure jReadO
jWrite: procedure expose m.
parse arg m, line
call objMetClaM m, 'jWrite'
if \ m.m.jWriting then
return err('jWrite('m',' line') but not opened w')
interpret ggCode
return
endProcedure jWrite
jWriteO: procedure expose m.
parse arg m, var
call objMetClaM m, 'jWriteO'
if \ m.m.jWriting then
return err('jWriteO('m',' var') but not opened w')
interpret ggCode
return
endProcedure jWriteO
jWriteAll: procedure expose m.
parse arg m, rdr
rdr = o2file(rdr)
call objMetClaM m, 'jWriteAll'
if \ m.m.jWriting then
return err('jWriteAll('m',' rdr') but not opened w')
interpret ggCode
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
doClose = jOpenIfNotYet(m, opt)
do ax=2 to arg()
call jWriteAll m, arg(ax)
end
if doClose then
call jClose m
return m
endProcedure jCat
jWriteNowImpl: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jRead(rdr, line)
call jWrite m, m.line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
jWriteNowImplO: procedure expose m.
parse arg m, rdr
doClose = jOpenIfNotYet(rdr, m.j.cRead)
do while jReadO(rdr, line)
call jWriteO m, line
end
if doClose then
call jClose rdr
return
endProcedure jWriteNow
/*--- reset JRW: fail if open, initialise ---------------------------*/
jReset: procedure expose m.
parse arg m, arg, arg2, arg3
if m.m.jReading == 1 | m.m.jWriting == 1 then
return err('still open jReset('m',' arg2')') / 3
m.m.jReading = 0
m.m.jWriting = 0
interpret objMet(m, 'jReset')
return m
endProcedure jReset
jOpenIfNotYet: procedure expose m.
parse arg m, opt
if opt == m.j.cRead & m.m.jReading then
return 0
if (opt == m.j.cWri | opt == m.j.cApp) & m.m.jWriting then
return 0
call jOpen m, opt
return 1
endProcedure jOpenIfNotYet
jOpen: procedure expose m.
parse arg m, opt
call objMetClaM m, 'jOpen'
if m.m.jReading | m.m.jWriting then
return err('already opened jOpen('m',' opt')')
interpret ggCode
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
call objMetClaM m, 'jClose'
if m.m.jReading | m.m.jWriting then
interpret ggCode
else
call err 'jClose' m 'but already closed'
m.m.jReading = 0
m.m.jWriting = 0
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, mid
call jOpen m, '<'
if \ jRead(m, line) then
return ''
res = m.line
do while jRead(m, line)
res = res m.line
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 = '>>'
m.j.cVar = '}'
call oIni
am = "call err 'call of abstract method"
call classNew 'n JRW u ORun, f JREADING v, f JWRITING v', 'm',
, "new call jReset m, arg, arg2, arg3",
, "jRead" am "jRead('m',' var')'" ,
, "jReadO if \ jRead(m, var) then return 0;" ,
"call oMutate arg, m.class.classV; return 1" ,
, "jWrite" am "jWrite('m',' line')'" ,
, "jWriteO call jWrite(m, o2string(var))" ,
, "jWriteAll call jWriteNowImpl m, rdr",
, "jWriteNow call jWriteNowImpl m, rdr",
, "jReset",
, "jOpen" am" jOpen('m',' opt')'" ,
, "jClose" ,
, "oRun call pipeWriteAll m",
, "o2String return jCatLines(m, ' ')",
, "o2File return m"
call classNew 'n JRWO u JRW', 'm',
, "jRead if \ jReadO(m, 'J.GGVAR.'m) then return 0;" ,
"m.var = o2string('J.GGVAR.'m); return 1" ,
, "jReadO" am "jReadO('m',' var')'" ,
, "jWrite call jWriteO(m, s2o(var))" ,
, "jWriteO" am "jWriteO('m',' line')'",
, "jWriteAll call jWriteNowImplO m, rdr",
, "jWriteNow call jWriteNowImplO m, rdr",
am = "call err 'call errObject"
call classNew 'n JRWErr u JRW', 'm',
, "jWriteAll" er "jWriteAll 'm', rdr'",
, "jWriteNow" er "jWriteNow 'm', 'rdr'",
, "jClose" er "jClose 'm'"
call classNew 'n JRWOut u JRW', 'm',
, "jReset m.m.stem = arg;",
"if arg \== '' & \ dataType(m.arg.0, 'n') then",
"m.arg.0 = 0" ,
, "jWrite if m.m.stem == '' then say line;" ,
"else call mAdd m.m.stem, line" ,
, "jWriteO call classOut , var, 'outO: '",
, "jOpen if \ abbrev(opt, m.j.cWri) then",
"call err 'can only write JRWOut.jOpen('m',' opt')';" ,
"else m.m.jWriting = 1"
call classNew 'n JRWEof u JRW', 'm',
, "jRead drop m.var; return 0",
, "jOpen if pos('>', opt) > 0 then",
"call err 'can only read JRWEof.jOpen('m',' opt')';" ,
"else m.m.jReading = 1"
m.j.in = jOpen(oNew('JRWEof'), '<')
m.j.out = jOpen(oNew('JRWOut'), m.j.cWri)
call classNew "n JBuf u JRWO, f BUF s r", "m",
, "jOpen return jBufOpen(m, opt)",
, "jReset return jBufReset(m, arg)",
, "jRead return jBufRead(m, var)",
, "jReadO return jBufReadO(m, var)",
, "jWrite call jBufWrite m, line",
, "jWriteO call jBufWriteO m, var"
call classNew "n JBufRun u JBuf, f RUNNER r", "m",
, "jOpen return jBufRunOpen(m, opt)",
, "jReset return jBufRunReset(m, arg)"
return
endProcedure jIni
in: procedure expose m.
parse arg arg
return jRead(m.j.in, arg)
endProcedur in
inO: procedure expose m.
parse arg arg
return jReadO(m.j.in, arg)
endProcedur in
out: procedure expose m.
parse arg line
call jWrite m.j.out, line
return 0
endProcedure out
outO: procedure expose m.
parse arg arg
call jWriteO m.j.out, arg
return
endProcedure outO
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('JBuf') /* calls jBufReset */
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
end
m.m.buf.0 = ax-1
m.m.allV = 1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == m.j.cRead then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == m.j.cWri then do
m.m.buf.0 = 0
m.m.allV = 1
end
else if opt \== m.j.cApp then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
jBufWrite: procedure expose m.
parse arg m, line
nx = mAdd(m'.BUF', line)
if \ m.m.allV then
m.class.o2c.nx = m.class.classV
return
endProcedure jBufWrite
jBufWriteStem: procedure expose m.
parse arg m, st
ax = m.m.buf.0
if m.m.allV then do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = m.st.sx
end
end
else do
do sx=1 to m.st.0
ax = ax + 1
m.m.buf.ax = o2String(m.st.sx)
m.class.o2c.m.buf.ax = m.class.classV
end
end
m.m.buf.0 = ax
return m
endProcedure jBufWrite
jBufWriteO: procedure expose m.
parse arg m, ref
if m.m.allV then do
cl = objClass(ref)
if cl = m.class.classV then do
call mAdd m'.BUF', m.ref
return
end
if cl = m.class.classW then do
call mAdd m'.BUF', substr(ref, 2)
return
end
m.m.allV = 0
do ax=1 to m.m.buf.0
adr = m'.BUF.'ax
m.class.o2c.adr = m.class.classV
end
end
call oCopy ref, m'.BUF.'mInc(m'.BUF.0')
return
endProcedure jBufWriteO
jBufReadO: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
m.class.o2c.var = m.class.classV
end
else
call oCopy m'.BUF.'nx, var
return 1
endProcedure jBufReadO
jBufRead: procedure expose m.
parse arg m, var
nx = m.m.readIx + 1
if nx > m.m.buf.0 then
return 0
m.m.readIx = nx
if m.m.allV then do
m.var = m.m.buf.nx
end
else
m.var = o2String(m'.BUF.'nx)
return 1
endProcedure jBufRead
jBufRun: procedure expose m.
parse arg oRun
return oNew('JBufRun', oRun) /* calls jBufRunReset */
endProcedure jBufRun
jBufRunReset: procedure expose m.
parse arg m, m.m.runner
return m
endProcedure jBufRunReset
jBufRunOpen: procedure expose m.
parse arg m, opt
call jBufOpen m, m.j.cWri /* to avoid recursive loop in push| */
call pipeBeLa m.j.cWri m
call oRun m.m.runner
li = m.m.buf.0
call pipeEnd
call jBufOpen jClose(m), opt
m.m.buf.0 = li
return m
endProcedure jBufRunOpen
/* copy j end *********************************************************/
/* copy o begin ******************************************************
an object has a class which describes fields and methods
an object has fields (e.g. m.o.fld1)
an object may call it's methods (dynamic binding)
***********************************************************************/
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call classIni
call oClassAdded m.class.classV
call mRegister 'Class', 'call oClassAdded arg'
call classNew 'n ORun u',
, 'm oRun call err "call of abstract method oRun"',
, 'm o2File return JBufRun(m)',
, 'm o2String return jCatLines(JBufRun(m), " ")'
return
endProcedure oIni
/*--- when notified about a new class cl, build the redundancies ----*/
oClassAdded: procedure expose m.
parse arg cl
m.class.o2c.cl = m.class.class
m.cl.oAdr = 'O.'substr(cl, 7) /* object adresses */
m.cl.oCnt = 0
new = 'new'
m.cl.oMet.new = ''
call oAddMethod cl'.OMET', cl
call oAddFields mCut(cl'.FLDS', 0), cl
co = '' /* build code for copy */
do fx=1 to m.cl.flds.0
nm = m.cl.flds.fx
if translate(nm) == nm & \ abbrev(nm, 'GG') ,
& pos('.M.', nm'.') < 1 & pos('.T.', nm'.') < 1 then
co = co'm.t'nm '= m.m'nm';'
else
co = co 'f='quote(substr(nm, 2))';m.t.f = m.m.f;'
end
p = cl'.OMET.oCopy'
if symbol('m.p') \== VAR then
m.p = co
return
endProcedure oClassAdded
/*--- add the methods of class cl to the methodtable mt -------------*/
oAddMethod: procedure expose m.
parse arg mt, cl
if pos(m.cl, 'frsv') > 0 then
return
if m.cl = 'm' then do
nm = m.cl.name
m.mt.nm = m.cl.met
return
end
if m.cl.class \== '' then
call oAddMethod mt, m.cl.class
if m.cl.0 \== '' then
do x=1 to m.cl.0
call oAddMethod mt, m.cl.x
end
return
endProcedure oAddMethod
/*--- add the the fields of class cl to stem f ----------------------*/
oAddFields: procedure expose m.
parse arg f, cl, nm
if pos(m.cl, 'rv') > 0 then do
do fx=1 to m.f.0
if m.f.fx == nm then
return 0
end
if nm == '' then do
call mMove f, 1, 2
m.f.1 = ''
end
else do
call mAdd f, nm
end
return 0
end
if m.cl = 'f' then
return oAddFields(f, m.cl.class, nm'.'m.cl.name)
if m.cl.class \== '' then
return oAddFields(f, m.cl.class, nm)
if m.cl.0 = '' then
return 0
do tx=1 to m.cl.0
call oAddFields f, m.cl.tx, nm
end
return 0
endProcedure oAddFields
/*--- create an an object of the class className --------------------*/
oBasicNew: procedure expose m.
parse arg className
cl = class4Name(className)
m.cl.oCnt = m.cl.oCnt + 1
m = m.cl.oAdr'.'m.cl.oCnt
m.class.o2c.m = cl
return m
endProcedure oBasicNew
/*--- create an an object of the class className
and call it's new method ------------------------------------*/
oNew: procedure expose m.
parse arg className, arg, arg2, arg3
m = oBasicNew(className)
interpret classMet(className, 'new')
return m
endProcedure oNew
/*--- return the class of object obj --------------------------------*/
objClass: procedure expose m.
parse arg obj
if symbol('m.class.o2c.obj') == 'VAR' then
return m.class.o2c.obj
if abbrev(obj, m.class.escW) then
return m.class.classW
if abbrev(obj, 'CLASS.CAST.') then
return substr(obj, 12, pos(':', obj, 12)-12)
if arg() >= 2 then
return arg(2)
return err('objClass no class found for object' obj)
endProcedure objClass
oKindOf: procedure expose m.
parse arg obj, sup
cl = objClass(obj, '')
if cl == '' then
return 0
return classInheritsOf(cl, class4name(sup))
endProcedure oKindOf
classInheritsOf: procedure expose m.
parse arg cl, sup /* wkTst optimierung in classAdded */
if cl == sup then
return 1
do until m.cl = 'u'
if m.cl.class == '' then
return 0
cl = m.cl.class
end
do cx=1 to m.cl.0
d = m.cl.cx
if m.d == 'n' then
if classInheritsOf(d, sup) then
return 1
end
return 0
endProcedure classInheritsOf
classSetMet: procedure expose m.
parse arg na, me, code
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
m.cl.oMet.me = code
return cl
endProcedure classSetMet
/*--- return the code of method me of the class with name na --------*/
classMet: procedure expose m.
parse arg na, me
if symbol('m.class.n2c.na') \== 'VAR' then
call err 'no class' na 'in classMet('na',' me')'
cl = m.class.n2c.na
if symbol('m.cl.oMet.me') \== 'VAR' then
call err 'no method in classMet('na',' me')'
return m.cl.oMet.me
endProcedure classMethod
/*--- set m, ggClass, ggCode to the address, class and code
of method me of object m ------------------------------------*/
objMetClaM: procedure expose m. m ggClass ggCode
parse arg m, me
if symbol('m.class.o2c.m') == 'VAR' then
ggClass = m.class.o2c.m
else if abbrev(m, 'CLASS.CAST.') then
parse var m 'CLASS.CAST.' ggClass ':' m
else
return err('no class found for object' m)
if symbol('m.ggClass.oMet.me') == 'VAR' then
ggCode = m.ggClass.oMet.me
else
call err 'no method' me 'in class' className(ggClass),
'of object' m
return
endProcedure objMetClaM
/*--- return the code of method me of object obj --------------------*/
objMet: procedure expose m.
parse arg obj, me
/* handle the easy and frequent case directly */
if symbol('m.class.o2c.obj') == 'VAR' then
c = m.class.o2c.obj
else if abbrev(obj, m.class.escW) then
c = m.class.classW
else do
call objMetClaM obj, me
return 'M="'m'";'ggCode
end
if symbol('m.c.oMet.me') == 'VAR' then
return m.c.oMet.me
return err('no method' me 'in class' className(c) 'of object' obj)
endProcedure objMet
/*--- return the stem of fieldnames of object m ---------------------*/
oFlds: procedure expose m.
parse arg m
return objClass(m)'.FLDS'
endProcedure oFlds
/*--- mutate object m to the class named name -----------------------*/
oMutate: procedure expose m.
parse arg m, name
m.class.o2c.m = class4Name(name)
return m
endProcedure oMutate
/*--- return object obj cast'd to class named cl --------------------*/
oCast: procedure expose m.
parse arg obj, cl
if abbrev(obj, 'CLASS.CAST.') then
obj = substr(obj, 1 + pos(':', obj, 12))
return 'CLASS.CAST.'class4Name(cl)':'obj
endProcedure oCast
/*--- copy object m of class c to t ---------------------------------*/
oClaCopy: procedure expose m.
parse arg ggCla, m, t
if ggCla == m.class.classW then do
m.t = o2String(m)
m.class.o2c.t = m.class.classV
return t
end
ggCode = ggCla'.OMET.oCopy'
interpret m.ggCode
m.class.o2c.t = ggCla
return t
endProcedure oClaCopy
/*--- copy object m to t --------------------------------------------*/
oCopy: procedure expose m.
parse arg m, t
return oClaCopy(objClass(m), m, t)
endProcedure oCopy
/*--- copy object to a newly created object -------------------------*/
oCopyNew: procedure expose m.
parse arg m
if symbol('m.o.o2c.m') == 'VAR' then
return oCopy(m, oBasicNew(m.o.o2c.m))
return oCopy(m, oBasicNew(m.class.classV))
endProcedure oCopyNew
/*--- return a new instance of a subclass of Run
with code code in method oRun -------------------------------*/
oRunner: procedure expose m.
parse arg code
r = oNew(classNew('n ORun* u', '\', 'ORun' ,
, 'm oRun call err "undefined method oRun in oRun"'))
if arg() > 0 then
call oRunnerCode r, arg(1)
return r
endProcedure oRunner
/*--- set code for runner -------------------------------------------*/
oRunnerCode: procedure expose m.
parse arg r, code
call classSetMet objClass(r), 'oRun', code
return r
endProcedure oRunnerCode
/*--- run method oRun of object m -----------------------------------*/
oRun: procedure expose m.
parse arg m, arg, arg2, arg3
interpret objMet(m, 'oRun')
return
endProcedure oRun
/*--- 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, arg, arg2, arg3
interpret objMet(m, 'o2String')
call err 'o2String did not return'
endProcedure o2String
/*--- cast a String to an object -----------------------------------*/
s2o: procedure expose m.
parse arg str
return m.class.escW || str
return r
endProcedure s2o
/*--- cast a String to an object or Null ---------------------------*/
s2oNull: procedure expose m.
parse arg str
if str == '' then
return ''
return m.class.escW || str
endProcedure s2oNull
/* 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 done in O, which, hower, extends the class definitions
meta
c choice name class
f field name class
m method name met
n name name class
r reference class
s stem class
u union stem
v string (value)
class expression (ce) allow the following syntax
ce = name | 'v' # value contains a string
| 'w' # string reference =m.class.escW||string
| 'o' # object: dynamic class lookup
| 'r' ce? # reference instance of ce default 'o'
| ('n' # names ce
| 'f' # field
| 'c') name ce # choice if value=name
| 's' ce # stem
| 'm' name code # method
| 'u' (ce (',' ce)*)? # union
# 'm' and 'u' extend to the end of whole ce
***********************************************************************/
classIni: procedure expose m.
if m.class.ini == 1 then
return
m.class.ini = 1
call mapIni
/* to notify other modules (e.g. O) on every new named class */
call mRegisterSubject 'Class',
, 'call classAddedListener subject, listener'
m.class.0 = 0
m.class.tmp.0 = 0
call mapReset 'CLASS.N2C' /* name to class */
/* meta meta data: description of the class datatypes */
m.class.classV = classNew('n v u v', 'm o2String return m.m',
, 'm o2File return file(m.m)')
m.class.escW = ']'
m.class.classW = classNew('n w u v',
, 'm o2String return substr(m, 2)',
, 'm o2File return file(substr(m, 2))')
m.class.classO = classNew('o')
m.class.classR = classNew('r')
m.class.class = classNew('n class u', '\')
call classNew 'class',
, 'c v v' ,
, 'c w w' ,
, 'c o o' ,
, 'c r f CLASS r class' ,
, 'c s f CLASS r class' ,
, 'c u s r class',
, 'c f' classNew('u f NAME v, f CLASS r class'),
, 'c n' classNew('u f NAME v, f CLASS r class'),
, 'c c' classNew('u f NAME v, f CLASS r class'),
, 'c m' classNew('u f NAME v, f MET v')
return
endProcedure classIni
/*--- to notify a new listener about already defined classes --------*/
classAddedListener: procedure expose m.
parse arg subject, listener
do y = 1 to m.class.0
if m.class.y == 'n' then
call mNotify1 'Class', listener, 'CLASS.'y
end
return
endProcedure classAddedListener
/*--- return the name of a class if it exists otherwise the class ---*/
className: procedure expose m.
parse arg cl
if m.cl = 'n' then
return m.cl.name
else
return cl
endProcedure class4Name
/*--- 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
/*--- get or create a class from the given class expression
arg(2) may contain options
'\' do not search for existing class
'+' do not finish class
type (1 char) type of following args
the remaining args are type expressions and will
be added to the first union -----------------------------*/
classNew: procedure expose m.
parse arg clEx
if arg() <= 1 then
if mapHasKey(class.n2c, clEx) then
return mapGet(class.n2c, clEx)
oldTmp = m.class.tmp.0
ox = verify(arg(2), '\+')
if ox < 1 then
ox = length(arg(2)) + 1
opts = left(arg(2), ox-1)
pr = substr(arg(2), ox, (length(arg(2)) = ox) * 2)
t = classNewTmp(clEx)
if arg() > 1 then do
u = t
do while m.u \== 'u'
if m.u.class == '' then
call err 'no union found' clEx
u = m.u.class
end
do ax = 2 + (opts \== '' | pr \== '') to arg()
call mAdd u, classNew(pr || arg(ax))
end
end
srch = pos('\', opts) < 1
p = classPermanent(t, srch)
if arg() <= 1 then
call mapAdd class.n2c, clEx, p
if \srch & p \== t & pos('+', opts) < 1 then
call mNotify 'Class', p
m.class.tmp.0 = oldTmp
return p
endProcedure classNew
/*--- create a temporary class
with type ty, name nm and class expression ce ---------------*/
classNewTmp: procedure expose m.
parse arg ty nm ce
if length(ty) > 1 then do
if nm \== '' then
call err 'class' ty 'should stand alone:' ty nm ce
return class4Name(ty)
end
t = mAdd(class.tmp, ty)
m.t.name = ''
m.t.class = ''
m.t.met = ''
m.t.0 = ''
if pos(ty, 'vwo') > 0 then do
if nm \== '' then
call err 'basicClass' ty 'end of Exp expected:' ty nm ce
end
else if ty = 'u' then do
fx = 0
m.t.0 = 0
ce = nm ce
ux = 0
do until fx = 0
tx = pos(',', ce, fx+1)
if tx > fx then
sub = strip(substr(ce, fx+1, tx-fx-1))
else
sub = strip(substr(ce, fx+1))
if sub \== '' then do
ux = ux + 1
m.t.ux = classNewTmp(sub)
end
fx = tx
end
m.t.0 = ux
end
else if nm == '' & ty \== 'r' then do
call err 'basicClass' ty 'name or class Exp expected:' ty nm ce
end
else do
if pos(ty, 'sr') > 0 then do
if nm == '' then
nm = 'o'
m.t.class = classNewTmp(nm ce)
end
else do
if pos(ty, 'cfmn') < 1 then
call err 'unsupported basicClass' ty 'in' ty nm ce
m.t.name = nm
if ty = 'm' then
m.t.met = ce
else if ce = '' then
call err 'basicClass' ty 'class Exp expected:' ty nm ce
else
m.t.class = classNewTmp(ce)
end
end
return t
endProcedure classNewTmp
/*--- return the permanent class for the given temporary class
an existing one if possible otherwise a newly created -------*/
classPermanent: procedure expose m.
parse arg t, srch
if \ abbrev(t, 'CLASS.TMP.') then
return t
if m.t.class \== '' then
m.t.class = classPermanent(m.t.class, srch)
if m.t.0 \== '' then do
do tx=1 to m.t.0
m.t.tx = classPermanent(m.t.tx, srch)
end
end
/* search equal permanent class */
do vx=1 to m.class.0 * srch
p = class'.'vx
if m.p.search then
if classEqual(t, p, 1) then
return p
end
p = mAdd(class, m.t)
m.p.name = m.t.name
m.p.class = m.t.class
m.p.met = m.t.met
m.p.search = srch
if m.t.0 > 0 then
call mAddSt mCut(p, 0), t
else
m.p.0 = m.t.0
if mapHasKey(class.n2c, p) then
call err 'class' p 'already defined as className'
else
call mapAdd class.n2c, p, p
if m.p = 'n' then do
if right(m.p.name, 1) == '*' then
m.p.name = left(m.p.name, length(m.p.name)-1) ,
|| substr(p, length('class.x'))
if mapHasKey(class.n2c, m.p.name) then
call err 'class' m.p.name 'already defined'
else
call mapAdd class.n2c, m.p.name, p
if srch then
call mNotify 'Class', p
end
return p
endProcedure classPermanent
/*--- return true iff the two classes are equal
(up to the name pattern if lPat == 1) -----------------------*/
classEqual: procedure expose m.
parse arg l, r, lPat
if m.l \== m.r | m.l.class \== m.r.class | m.l.0 \= m.r.0,
| m.l.met \== m.r.met then
return 0
if m.l.name \== m.r.name then
if lPat \== 1 | right(m.l.name, 1) \== '*' ,
| \ abbrev(m.r.name,
, left(m.l.name, length(m.l.name)-1)) then
return 0
if m.l.0 == '' then
return 1
do sx=1 to m.l.0
if m.l.sx \== m.r.sx then
return 0
end
return 1
endProcedure classEqual
/*--- print object ---------------------------------------------------*/
objOut: procedure expose m.
parse arg m, pr, p1
c = objClass(m, '')
if c == '' then
call out p1 'no class for' m
else if c == m.class.classV then
call out p1 || m.m
else if c == m.class.classW then
call out p1 || o2String(m)
else
call classOutDone c, m, pr, p1
return
endProcedure objOut
/*--- recursively ouput (with out:) the object a with class t -------*/
classOut: procedure expose m.
parse arg t, a, pr, p1
return classOutDone(if(t=='',m.class.classO, t), a, pr, p1)
endProcedure classOut
/*--- ouput object a with class t and stopper done ------------------*/
classOutDone: procedure expose m. done.
parse arg t, a, pr, p1
if p1 == '' then
p1 = pr
if right(p1, 1) \== ' ' then
p1 = p1' '
if done.ini \== 1 then do
done.ini = 1
t = class4Name(t, t)
p1 = p1'@'a' '
end
if done.t.a == 1 then
return out(p1'done :'className(t) '@'a)
done.t.a = 1
if m.t = 'o' then do
t = objClass(a, '')
if t = '' then
return out(p1'obj has no class @'m.a)
else
return classOutDone(t, a, pr, p1'isA')
end
if m.t == 'v' then
return out(p1'=' m.a)
if m.t == 'w' then
return out(p1'}' substr(a, 2))
if m.t == 'n' then
return classOutDone(m.t.class, a, pr, p1':'m.t.name)
if m.t == 'f' then
return classOutDone(m.t.class, a'.'m.t.name, pr, p1'.'m.t.name)
if m.t == 'r' then do
if m.a == '' then
call out p1'refTo :'className(m.t.class) '@null@'
else
return classOutDone(m.t.class, m.a, pr,
, p1'refTo @'m.a)
end
if m.t = 'u' then do
t1 = m.t.1
vv = m.t.0 > 0 & m.t1 == 'v'
call out p1'union' || copies(' =' m.a, vv)
do ux=1+vv to m.t.0
call classOutDone m.t.ux, a, pr' '
end
return 0
end
if m.t = 's' then do
call out p1'stem' m.a.0
do ux=1 to m.a.0
call classOutDone m.t.class, a'.'ux, pr' ', pr' .'ux
end
return 0
end
if m.t = 'c' then do
if m.t.name = m.a then
call classOutDone m.t.class, a, pr, p1'choice' m.a
return 0
end
if m.t = 'm' then
return 0
return err('bad class type' m.t)
endProcedure classOutDone
/* copy class end ***************************************************/
/* copy 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.mAlfDot, '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
return
endProcedure mapIni
mapInline: procedure expose m.
parse arg pName
if mapHasKey(map.inlineName, pName) then
return mapGet(map.inlineName, pName)
if m.map.inlineSearch == 1 then
call mapReset map.inlineName, map.inline
inData = 0
name = ''
do lx=m.map.inlineSearch to sourceline()
if inData then do
if abbrev(sourceline(lx), stop) then do
inData = 0
if pName = name then
leave
end
else do
call mAdd act, strip(sourceline(lx), 't')
end
end
else if abbrev(sourceline(lx), '/*<<') then do
parse value sourceline(lx) with '/*<<' name '<<' stop
name = strip(name)
stop = strip(stop)
if stop == '' then
stop = name
if words(stop) <> 1 | words(name) <> 1 then
call err 'bad inline data' strip(sourceline(lx))
if mapHasKey(map.inline, name) then
call err 'duplicate inline data name' name ,
'line' lx strip(sourceline(lx), 't')
act = mapAdd(map.inlineName, name,
, mCut('MAP.INLINE.' || (m.map.inline.0 + 1), 0))
inData = 1
end
end
if inData then
call err 'inline Data' name 'at' m.map.inlineSearch,
'has no end before eof'
m.map.inlineSearch = lx + 1
if name = pName then
return act
if arg() > 1 then
return arg(2)
call err 'no inline data named' pName
endProcedure mapInline
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, if opt <> '' maintain stem of keys
('K' in map.keys, '=' in a else in opt) --------------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
if opt = '=' then
st = a
else if translate(opt) = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st \== '' then
m.st.0 = 0
return a
endProcedure
/*--- add a new key value pair to the map ----------------------------*/
mapAdd: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'a')
m.vv = val
return val
endProcedure mapAdd
/*--- change the value at a key or add key value ---------------------*/
mapPut: procedure expose m.
parse arg a, ky, val
vv = mapValAdr(a, ky, 'p')
m.vv = val
return val
endProcedure mapPut
/*--- return 1 if key ky exists in map a, 0 otherwise ----------------*/
mapHasKey: procedure expose m.
parse arg a, ky
return mapValAdr(a, ky) \== ''
endProcedure mapHasKey
/*--- return the value of key ky in map a if it exists,
else if called with a third argument return third argument
else issue an error ----------------------------------------*/
mapGet: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv \== '' then
return m.vv
else if arg() > 2 then
return arg(3)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- return a stem of all keys --------------------------------------*/
mapKeys: procedure expose m.
parse arg a
if m.map.keys.a == '' then
call err 'mapKeys('a') with no keys'
return m.map.keys.a
endProcedure mapKeys
/*--- remove a key from the map, do nothing if it is missing ---------*/
mapRemove: procedure expose m.
parse arg a, ky
vv = mapValAdr(a, ky)
if vv == '' then
return ''
if m.map.keys.a \== '' then do
trace ?R /* not tested yet ???wkTest */
k = m.map.keys.a
mx = m.k.0
do i=1 to mx
if m.k.i == ky then do
m.k.i = m.k.mx
m.k.0 = mx - 1
return
end
end
end
val = m.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
liLe = 243 - length(a)
do kx=1 to m.st.0
ky = m.st.kx
drop m.st.kx
if length(ky) <= liLe then do
drop m.a.ky
end
else do
adr = mapValAdr(a, ky)
if adr \== '' then do
ha = left(adr, lastPos('.', adr) - 3)
do i = 1 to m.ha.k.0
drop m.ha.k.i m.ha.v.i
end
drop m.ha.k.0
end
end
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return the value pointer for a key, '' if non existing
with fun = 'a' add a key, with 'p' put a key ------------*/
mapValAdr: procedure expose m.
parse arg a, ky, fun
if length(ky) + length(a) <= 243 then do
res = a'.'ky
if symbol('m.res') == 'VAR' then do
if fun == 'a' then
call err 'duplicate key' ky 'in map' a
return res
end
else if fun == '' then
return ''
end
else do
len = 243 - length(a)
q = len % 4
ha = a'.'left(ky, len - 2 * q) || substr(ky,
, (length(ky)-len) % 2 + 2 * q, q) || right(ky, q)
if symbol('M.ha.k.0') == 'VAR' then do
do i=1 to m.ha.k.0
if m.ha.k.i == ky then do
if fun == 'a' then
call err 'duplicate key' ky ,
'map' a 'hash' ha'.K.'i
return ha'.V.'i
end
end
end
else do
i = 1
end
if fun == '' then
return ''
if i > 9 then
call err 'overflow long key' y 'in map' a 'hash' ha'.K.'i
m.ha.k.0 = i
m.ha.k.i = ky
res = ha'.V.'i
end
opt = left('K', m.map.keys.a \== '')
if opt == 'K' then
call mAdd m.map.Keys.a, ky
return res
endProcedure mapValAdr
/* 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>.** to avoid conflicts: every rexx Module (copy) should
only allocate addresses m.<mbr>.** with <mbr> the name of
the rexx module
we pass parameters around (e.g. a=address, m=memory, st=stem)
and the called function may use m.a or m.a.subField etc.
gg*: local variable in subroutines without procedure
everything else: temporary data within procedure
every subroutine is declared as procedure expose m.
(also if no m. variable is used, because e.g. of error handling)
the few subroutines that cannot use procedure, should use only
variables starting with gg
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a
m.a = m.a + 1
return m.a
endProcedure mInc
/*--- cut stem a to length len ---------------------------------------*/
mCut: procedure expose m.
parse arg a, len
m.a.0 = len
return a
endProcedure mCut
/*--- add one or several arguments to stem m.a -----------------------*/
mAdd: procedure expose m.
parse arg a
ix = m.a.0
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
end
m.a.0 = ix
return a'.'ix
endProcedure mAdd
/*--- pop last element from stem m.a ---------------------------------*/
mPop: procedure expose m.
parse arg a
ix = m.a.0
if ix < 1 then
call err 'pop from empty stem' a
m.a.0 = ix-1
return m.a.ix
endProcedure mPop
/*--- add to m.dst.* a (sub)sequence of m.src.* ----------------------*/
mAddSt: procedure expose m.
parse arg dst, src
dx = m.dst.0
do sx = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return
endProcedure mAddSt
/*--- 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
/*--- 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 all elements of a stem together ----------------------------*/
mCat: procedure expose m.
parse arg st, mid
if m.st.0 < 1 then
return ''
res = m.st.1
do x=2 to m.st.0
res = res || mid || m.st.x
end
return res
endProcedure mCat
/*--- notify all listeners of subject subj with argument arg --------*/
mNotify: procedure expose m.
parse arg subj, arg
if symbol('m.m.subLis.subj') \== 'VAR' then
call err 'subject' subj 'not registered'
do lx=1 to m.m.subLis.subj.0
call mNotify1 subj, lx, arg
end
return
endProcedure mNotify
/*--- notify the listener listener of subject subj with arg ---------*/
mNotify1: procedure expose m.
parse arg subject, listener, arg
interpret m.m.subLis.subject.listener
return
endProcedure mNotify1
/*--- notify subject subject about a newly registered listener
or a new subject about previously registered listener -------*/
mNotifySubject: procedure expose m.
parse arg subject, listener
interpret m.m.subLis.subject
return
endProcedure mNotifySubject
/*--- register a new subject with the code for mNotifySubject -------*/
mRegisterSubject: procedure expose m.
parse arg subj, addListener
if symbol('m.m.subLis.subj') == 'VAR' then
call err 'subject' subj 'already registered'
m.m.subLis.subj = addListener
if symbol('m.m.subLis.subj.0') \== 'VAR' then do
m.m.subLis.subj.0 = 0
end
else do lx=1 to m.m.subLis.subj.0
call mNotifySubject subj, lx
end
return
endProcedure registerSubject
/*--- register a listener to subject subj with the code for mNotify -*/
mRegister: procedure expose m.
parse arg subj, notify
if symbol('m.m.subLis.subj.0') \== 'VAR' then
m.m.subLis.subj.0 = 0
call mAdd 'M.SUBLIS.'subj, notify
if symbol('m.m.subLis.subj') == 'VAR' then
call mNotifySubject subj, m.m.subLis.subj.0
return
endProcedure mRegister
mIni: procedure expose m.
if m.m.ini = 1 then
return
m.m.ini = 1
m.mAlfLC = 'abcdefghijklmnopqrstuvwxyz'
m.mAlfUC = translate(m.mAlfLC)
m.mAlfa = m.mAlfLC || m.mAlfUC
m.mAlfNum = m.mAlfa || '0123456789'
m.mAlfDot = m.mAlfNum || '.'
return
endProcedure mIni
/* copy m end *********************************************************/
/* copy stringUt begin ***********************************************/
/*--- return the count of occurrences of needle in heyStack ----------*/
posCount: procedure
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, w, new
res = ''
cx = 1
do forever
nx = pos(w, src, cx)
if nx < 1 then
return res || substr(src, cx)
res = res || substr(src, cx, nx-cx) || new
cx = nx + length(w)
end
endProcedure repAll
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
/* copy stringUt end ***********************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
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
if m.err.ini \== 1 then
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
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- 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
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/