zOs/REXX.O08/WSH
/* rexx ****************************************************************
wsh
***********************************************************************/
call errReset h
parse arg arg
call sqlOIni
call compIni
if arg = '' then do
if adrEdit('macro (mArgs) NOPROCESS', '*') == 0 then do
if mArgs = '' then do
call adrEdit '(d) = dataset'
call adrEdit '(m) = member'
IF dsnSetMbr(d, m) = 'A540769.WK.REXX(WSH)' then
exit tstAct()
else
exit wshEditMacro(mArgs)
end
arg = mArgs
end
end
parse var arg fun rest
upper fun
if fun = '' then
exit wshBatch('S')
if fun = 'S' | fun = 'D' then
exit wshBatch(fun)
if wordPos(fun, 'R E S D') > 0 then
exit wshInter('-'fun rest)
if wordPos(fun, '-R -E -S -D') > 0 then
exit wshInter(fun rest)
if abbrev(fun, 'T') then
if fun <> 'T' then
c = call fun rest
else do
c = ''
do wx=1 to words(rest)
c = c 'call tst'word(rest, wx)';'
end
if c = '' then
c = call 'tstAct;'
else
c = c 'call tstTotal;'
end
else
call err 'bad fun' fun 'in arg' arg
say 'wsh interpreting' c
interpret c
exit 0
endMain wsh
tstAct: procedure expose m.
return tstSqlStoredWk()
return wshInter('-e')
return tstAll()
return tstMatch()
return tstSql()
call tstPlus
return tstSqlO()
return tstMap()
call tstCsi
return tstCatDsn()
return 0
endProcedure tstAct
wshInter: procedure expose m.
parse arg inp
call compIni
call sqlOini
do forever
w1 = translate(word(inp, 1))
if abbrev(w1, '-') then do
mode = substr(w1, 2)
inp = subWord(inp, 2)
if mode = '' then
return 0
end
if inp <> '' then do
say 'as' mode 'interpreting' inp
if mode = 'R' then
interpret inp
else if mode = 'E' then
interpret 'say' inp
else if mode = 'S' | mode = 'D' then 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
else
say 'mode' mode 'not implemented yet'
end
say 'enter' mode 'expression, - for end, -r or -e for Rexx' ,
'-s or -d for WSH'
parse pull inp
end
endProcedure wshInter
wshBatch: procedure expose m.
parse upper arg ty
call compIni
call sqlOini
i = catDsn("-WSH")
cmp = comp(i)
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
r = compile(cmp, ty)
useOut = listDsi('OUT FILE')
useOut = ^ (useOut = 16 & sysReason = 2)
if useOut then
call envPush env('>', '-OUT')
call oRun r
if useOut then
call envPop
return 0
endProcedure wshBatch
/*-- edit macro to call wsh ------------------------------------------*/
wshEditMacro: procedure expose m.
parse upper arg mArgs
call adrIsp 'control errors return'
pc = adrEdit("process dest range Q", 0 4 8 12 16)
dst = ''
if pc = 0 | pc = 8 then do
call adrEdit "(rFi) = lineNum .zFrange"
call adrEdit "(rLa) = lineNum .zLrange"
if pc = 0 then
call adrEdit "(dst) = lineNum .zDest"
else
dst = rLa
end
else if pc = 12 then do
if adrEdit("find first '$***out' 1", 4) = 0 then do
call adrEdit "(dst) = cursor"
call adrEdit "(li) = line" dst
li = overlay(date(s) time(), li, 20)
call adrEdit "line_before" dst "= (li)"
rFi = 1
rLa = dst-1
end
end
if dst = '' then
msg = 'bitte Bereich mit q oder qq auswaehlen ???' rc ,
'oder $***out Zeile einfuegen'
else if rLa < rFi then
msg = 'firstLine' rFi 'before last' rLa
else
msg = ''
if msg ^== '' then do
say msg
return 4
end
/* say 'range' c1 'rc' pc':' rFi '-' rLa 'after' dst */
call compIni
i = jBuf()
o = jBuf()
call jOpen i, 'w'
do lx=rFi to rLa
call adrEdit "(li) = line" lx
call jWrite i, li
end
cmp = comp(i)
if pos('D', mArgs) > 0 then
ty = 'd'
else
ty = 's'
call errReset 'h',
, 'return wshEditCompErrH(ggTxt, ' rFi',' rLa')'
r = compile(cmp, ty)
call errReset 'h',
, 'return wshEditRunErrH(ggTxt, ' quote(o)',' dst')'
call envPush env('>£', o)
call oRun r
call envPop
lab = wshEditInsLinSt(dst+1, , o'.BUF')
call wshEditLocate dst-7
return 0
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 errSay 'compErr' ggTxt
call errSay ggTxt, ggStem
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), '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 errSay ggTxt, ggStem, '*** 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, type, st
cmd = wshEditInsLinCmd(wh)
do ax=1 to m.st.0
call wshEditInsLin cmd, type, m.st.ax
end
return cmd
endProcedure wshEditInsLinSt
listCatClass: procedure expose m. /* ???wkTst remove or move */
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 jOut '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 jOut '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('DEVTYPE--', 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 jOut '??? 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 jOut 'err ??? mismatch cl' cl 'vo' vo 'dt' dt 'dsn' dsn
return res
endProcedure listCatClass
/* copy tstAll begin *************************************************/
/* copx tstSql end ***************************************************/
tstAll: procedure expose m.
call sqlOIni
call compIni
call tstBase
call tstComp
call tstPlus
return 0
endProcedure tstAll
tstPlus:
call tstSort
call tstMatch
call sqlIni
call tstSql
call tstSqlO
call tstSqlEnv
call tstTotal
return
tstWshBatch:
call adrTso 'alloc dd(WSH) shr dsn(WK.TEXT(WSHBATCH))'
call wshBatch
return adrTso('free dd(WSH)')
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.dsn '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.dsn)
/* oo = csiCla(strip(m.s.dsn))
if oo <> nn then
say nn '<>' oo m.s.dsn
*/ if i // 1000 = 0 then
say timing() i nn m.s.dsn
end
say timing() (i-1) nn m.s.dsn
return
tstTypePara:
b = jBuf()
say 'b typePara undef' oGetTypePara(b)
ty = oFldNew('Ty*', '=', '=', 'A = B =')
call oSetTypePara b, ty
say 'b argCla def' oGetTypePara(b)
call tstJ2
return
tstSort: procedure expose m.
call tst t, "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 Z",
|| "WOELF 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 N",
|| "EUN VIERZEHN 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"
m.i.1 = eins
m.i.2 = zwei
m.i.3 = drei
m.i.4 = vier
m.i.5 = fuenf
m.i.6 = sechs
m.i.7 = sieben
m.i.8 = acht
m.i.9 = neun
m.i.10 = zehn
m.i.11 = elf
m.i.12 = zwoelf
m.i.13 = dreizehn
m.i.14 = vierzehn
m.i.15 = 1
m.i.16 = 2
m.i.17 = 3
m.i.18 = 4
m.i.19 = 4
m.i.20 = 3
m.i.21 = 2
m.i.22 = 1
m.i.23 = 0
m.i.24 = 1
m.i.28 = 'c'
yy = 29
do while yy > 0
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
yy = yy-1
end
call tstEnd t
return
endProcedure tstSort
tstMatch: procedure expose m.
call tst t, "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*) 000x00",
|| "000xx",
, "match(000xx, *0*) 1 1 2,00,xx trans(ab*cd*ef) ab00cdxxef"
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
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;"
upper 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 tst t, "tstSql",
, "*** 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",
, "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.SQ",
|| "LIND, :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"
call mAdd t.cmp,
, "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"
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 jOut '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 jOut 'sqlVars' sv
call jOut sqlPreAllCl(cx,
, "select 'a', 2, case when 1=0 then 1 else null end ",
"from sysibm.sysDummy1",
, stst, sv) 'all from dummy1'
call jOut 'a='m.stst.a 'b='m.stst.b 'c='m.stst.c
call jOut 'sqlVarsNull' sqlVarsNull(stst, A B C)
call jOut '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 jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call jOut 'fetchBT' sqlFetchInto(cx, ':NM') nm
call sqlClose cx
call sqlOpen cx, 'SYSINDEXES'
a = 'a b c'
b = 1234565687687234
call jOut 'fetchBI' sqlFetchInto(cx, ':NM') nm
call jOut '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 jOut 'opAllCl' sqlOpAllCl(cx, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut 'fetchC' x m.st.x.name
end
st = 'auch noch'
src = "select strip(creator) || '.' || strip(name)" substr(src,12)
call jOut 'PreAllCl' sqlPreAllCl(cx+11, src, st, ':M.ST.SX.NAME')
do x=1 to m.st.0
call jOut '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 jOut '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, type, 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 jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut 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, sqlType(13), fe
call jOut fmtFldTitle(sqFmt)
do ix=1 to m.fe.0
call jOut oFldCat(sqlType(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 jOut fmtFldTitle(m.sql.13.fmt)
do while sqlFetchLn(13, li)
call jOut 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 envBarBegin
call jOut 'select d.*, 123, current timestamp "jetzt und heute",'
call jOut 'case when 1=0 then 1 else null end caseNull,'
call jOut "'anonym'"
call jOut 'from sysibm.sysdummy1 d'
call envBar
call sql 13
call envBarLast
do while envRead(abc)
call jOut '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 envBarEnd
call jOut 'sql fmtFldRw sl<15'
call envBarBegin
call jOut 'select name, type, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldRW sqlGenFmt(fmtAbc, 13, 'sl<15')
call envBarEnd
call jOut 'sql fmtFldSquashRW'
call envBarBegin
call jOut 'select name, type, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBar
call sql 13
call envBarLast
call fmtFldSquashRW
call envBarEnd
call jOut 'sqlLn sl='
call envBarBegin
call jOut 'select char(name, 13), type, dbName, char(tsName, 8)'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13, , ,'sl='
call envBarEnd
call jOut 'sqlLn ---'
call envBarBegin
call jOut 'select name, type, dbName, tsName'
/* ,alteredTS, obid, cardf'*/
call jOut 'from sysibm.systables'
call jOut "where creator = 'SYSIBM' and name like 'SYSTA%'"
call jOut "fetch first 5 rows only"
call envBarLast
call sqlLn 13
call envBarEnd
call sqlDisconnect
call tstEnd t
return
endProcedure tstSqlEnv
/* copx tstSql end ***************************************************/
/* copx tstComp begin **************************************************
test the wsh comp
***********************************************************************/
tstComp: procedure expose m.
call compIni
call tstCompDataConst
call tstCompDataVars
call tstCompShell
call tstCompPrimary
call tstCompStmt
call tstCompDataIO
call tstCompPipe
call tstCompRedir
call tstCompComp
call tstTotal
return
endProcedure tstComp
tstCompRun: procedure expose m.
parse arg type cnt
src = jBuf()
call jOpen src, 'w'
do sx=2 to arg()
call jWrite src, arg(sx)
end
cmp = comp(src)
call jOut 'compile' type',' (sx-2) 'lines:' arg(2)
r = compile(cmp, type)
say "compiled: >>>>" r "<<<<" m.r.code
call jOut "run without input"
call mCut 'T.IN', 0
call oRun r
if cnt == 3 then do
call jOut "run with 3 inputs"
call mAdd 'T.IN', "eins zwei drei", "zehn elf zwoelf?",
, "zwanzig 21 22 23 24 ... 29|"
m.t.inIx = 0
call oRun r
end
return
endProcedure tstCompRun
tstCompDataConst: procedure expose m.
call tst t, 'tstCompDataConst',
, "compile d, 8 lines: Lline one, $** asdf",
, "run without input",
, " Lline one, ",
, "line two.",
, "line threecontinued on 4",
, "line five fortsetzung",
, "line six fortsetzung"
call tstCompRun 'd' ,
, ' 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'
call tstEnd t
return
endProcedure tstCompDataComm
tstCompDataVars: procedure expose m.
call tst t, 'tstCompDataVars',
, "compile d, 4 lines: Lline one, $** asdf",
, "run without input",
, " Lline one, ",
, "lline zwei output",
, "lline 3 ",
, "variable v1 = valueV1 ${v1}= valueV1| "
call tstCompRun 'd' ,
, ' Lline one, $** asdf',
, ' $$ lline zwei output',
, 'lline 3 $=v1= valueV1 ' ,
, 'variable v1 = $v1 $"${v1}=" ${ v1 }| '
call tstEnd t
return
endProcedure tstCompDataVars
tstCompShell: procedure expose m.
call tst t, 'tstCompShell',
, "compile s, 9 lines: $$ Lline one, $** asdf",
, "run without input",
, "Lline one,",
, "lline zwei output",
, "v1 = valueV1 ${v1}= valueV1|",
, "REXX JOUT L5 CONTINUED L6 CONTINUED L7",
, "L8 ONE",
, "L9 END"
call tstCompRun 's' ,
, ' $$ Lline one, $** asdf',
, ' $$ lline zwei output',
, ' $=v1= valueV1 ' ,
, '$$ v1 = $v1 $"${v1}=" ${ v1 }| ' ,
, 'call jOut rexx jout l5, ' ,
, ' continued l6 , ' ,
, ' continued l7 ' ,
, 'call jOut l8 one ' ,
, 'call jOut l9 end'
call tstEnd t
return
endProcedure tstCompDataVars
tstCompPrimary: procedure expose m.
call tst t, 'tstCompPrimary',
, "compile d, 11 lines: Strings $""$""""$""""""""$"""""" $'$'",
|| "'$''''$'''",
, "run without input",
, "Strings $""$""""$"" $'$''$'",
, "rexx 3*5 = 15",
, "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",
, "run with 3 inputs",
, "Strings $""$""""$"" $'$''$'",
, "rexx 3*5 = 15",
, "data line three line four bis hier",
, "shell line five line six bis hier",
, "var get v1 value Eins, v1 value Eins "
call mAdd t.cmp,
, "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?"
call envRemove 'v2'
call tstCompRun 'd' 3 ,
, 'Strings $"$""$""""$"""' "$'$''$''''$'''",
, 'rexx 3*5 = $( 3 * 5 $)',
, 'data $-[ line three',
, 'line four $] bis hier',
, 'shell $-{ $$ line five',
, '$$ line six $} bis hier',
, '$= v1 = value Eins $=rr=undefined',
, 'var get v1 $v1, v1 ${ v1 } ',
, 'var isDef v1 ${? v$( 1 * 1 + 0 $) }, v2 ${?v2 } ',
, 'var read >1 ${> rr} rr $rr' ,
, 'var read >2 ${> rr} rr $rr'
call tstEnd t
return
endProcedure tstCompPrimary
tstCompStmt: procedure expose m.
call tst t, 'tstCompStmt1',
, "compile s, 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"
call envPut 'oRun', oRunner('call jOut "oRun ouput" (1*1)')
call envRemove 'v2'
call tstCompRun 's' ,
, '$= v1 = value eins $= v2 £ 3*5*7 ',
, '$$ data v1 $v1 v2 ${ v2 }',
, '$$eins $@{$$ zwei $$ drei ',
, ' $@{ $} $@{ $@{ $$vier $} $} $} $$fuenf',
, '$$elf $@[ zwoelf dreiZ ',
, ' $@[ $] $@[ $@[ vierZ $] $] $] $$fuenfZ',
, '$£ "lang v1" $v1 "v2" ${v2}*9',
, '$@run $oRun'
call tstEnd t
call tst t, 'tstCompStmt2',
, "compile s, 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"
call tstCompRun 's' 3 ,
, '$@for qq $$ loop qq $qq'
call tstEnd t
return
endProcedure tstCompStmt
tstCompDataIO: procedure expose m.
call tst t, 'tstCompDataHereData',
, "compile d, 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 {"
call tstCompRun 'd' ,
, ' 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 jOut heredata 1 $x',
, '$$heredata 2 $y',
, 'st $$ nach heredata {'
call tstEnd t
dsn = tstDsn('lib37', 'r')'(readInp)'
call mAdd mCut(abc, 0), 'readInp line 1', 'readInp line 2'
call writeDsn dsn '::f37', m.abc., ,1
call envPut 'dsn', dsn
call tst t, 'tstCompDataIO',
, "compile d, 4 lines: input 1 $<$dsn ::fb ",
, "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."
call tstCompRun 'd' ,
, ' input 1 $<$dsn ::fb ',
, ' nach dsn input und nochmals mit & ' ,
, ' $<&dsn('dsn2jcl(dsn)') dd(xyz)',
, ' und schluiss.'
call tstEnd t
return
endProcedure tstCompDataIO
tstCompPipe: procedure expose m.
call tst t, 'tstCompPipe1',
, "compile s, 1 lines: call envPreSuf ""(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"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"'
call tstEnd t
call tst t, 'tstCompPipe2',
, "compile s, 2 lines: call envPreSuf ""(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]"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! call envPreSuf "[2 ", " 2]"'
call tstEnd t
call tst t, 'tstCompPipe3',
, "compile s, 3 lines: call envPreSuf ""(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>"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! call envPreSuf "[2 ", " 2]"',
, ' $! call envPreSuf "<3 ", " 3>"'
call tstEnd t
call tst t, 'tstCompPipe4',
, "compile s, 7 lines: call envPreSuf ""(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] 22",
|| "2] 3>",
, "<3 [222 [221 [21 [20 (1 zwanzig 21 22 23 24 ... 29| 1) 20]",
|| " 21] 221] 222] 3>"
call tstCompRun 's' 3 ,
, ' call envPreSuf "(1 ", " 1)"' ,
, ' $! $@{ call envPreSuf "[20 ", " 20]"',
, ' $! call envPreSuf "[21 ", " 21]"',
, ' $! $@{ call envPreSuf "[221 ", " 221]"',
, ' $! call envPreSuf "[222 ", " 222]"',
, '$} $} ',
, ' $! call envPreSuf "<3 ", " 3>"'
call tstEnd t
return
endProcedure tstCompPipe
tstCompRedir: procedure expose m.
call tst t, 'tstCompRedir',
, "compile s, 5 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 2",
|| "1 22 23 24 ... 29|>",
, "output piped zwei ab<eins zwei drei>yz ab<zehn elf zwoelf?",
|| ">yz ab<zwanzig 21 22 23 24 ... 29|>yz"
dsn = tstDsn('libvb', 'r')'(redir1)'
call envPut 'dsn', dsn
call tstCompRun 's' 3 ,
, ' $>#eins $@for vv $$<$vv> $; ',
, ' $$ output eins $-{$<#eins$}$; ',
, ' $@for ww $$b${ww}y ',
, ' $> $dsn ::v $! call envPreSuf "a", "z" $<# eins',
, '$;$$ output piped zwei $-{$<$dsn$} '
call tstEnd t
return
endProcedure tstCompRedir
tstCompComp: procedure expose m.
call tst t, 'tstCompCompShell',
, "compile s, 5 lines: $$compiling shell $; $= rrr = $-cmpShe",
|| "ll $<<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"
call mAdd t'.CMP',
, "<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"
call tstCompRun 's' 3 ,
, "$$compiling shell $; $= rrr = $-cmpShell $<<aaa",
, "call jOut run 1*1*1 compiled $cc; $@for v $$ compRun $v$cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
call tst t, 'tstCompCompData',
, "compile s, 5 lines: $$compiling data $; $= rrr = $-cmpData",
|| " $<<aaa",
, "run without input",
, "compiling data",
, "running einmal",
, "call jOut run 1*1*1 compiled einmal",
, "running zweimal",
, "call jOut run 1*1*1 compiled zweimal",
, "run with 3 inputs",
, "compiling data",
, "running einmal",
, "call jOut run 1*1*1 compiled einmal",
, "running zweimal",
, "call jOut run 1*1*1 compiled zweimal"
call tstCompRun 's' 3 ,
, "$$compiling data $; $= rrr = $-cmpData $<<aaa",
, "call jOut run 1*1*1 compiled $cc",
, "aaa $;",
, "$=cc=einmal $$ running $cc $@run $rrr",
, "$=cc=zweimal $$ running $cc $@run $rrr"
call tstEnd t
return
endProcedure tstCompComp
/* copx tstComp end *************************************************/
/* copx tstBase begin **************************************************
test the basic classes
***********************************************************************/
tstBase: procedure expose m.
call tstM
call tstMap
call tstMapVia
call tstScan
call tstO
call tstJsay
call tstJ
call tstJ2
call tstCat
call tstScanRead
call tstScanWin
call tstScanSQL
call tstEnv
call tstEnvCat
call tstEnvLazy
call tstEnvVars
call tstCatDsn
call tstTotal
return
endProcedure tstBase
tstTstSay: procedure
call tst x, 'test eins', "test eins einzige testZeile"
call tstOut x, "test eins einzige testZeile"
call tstEnd x
call tst x, 'test zwei', "zwei 1. testZeile",
, "zwei 2. und letsdfazte testZeile"
call tstOut x, "zwei 1. testZeile"
call tstOut x, "zwei 2. und letzte testZeile"
call tstEnd x
call tst y, 'test drei',
, "drei 1. testZeile",
, "drei 2. tEstZeile",
, "drei 3. testZeile test line drei ganz lang 1 ",
|| " ...line drei ganz lang 2 ",
|| " ...line drei ganz lang 3 .",
|| "..line drei ganz lang 4 und schluss."
call tstOut y, 'drei 1. testZeile'
call tstOut y, 'drei 2. testZeile'
call tstOut y, 'drei 3. testZeile',
'test line drei ganz lang 1 ',
' ...line drei ganz lang 2 ',
' ...line drei ganz lang 3 ',
' ...line drei ganz lang 4 und schluss.'
call tstEnd y
call tstTotal
endProcedure tstTstSay
tstM: procedure
call tst t, '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 vor AddSt a 2=eins 3=zwei",
, " 4=drei 5=c nach addSt a 6=M.C.6"
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 vor AddSt a'
call mAddSt c, a
call mAdd c, 'c nach addSt a'
call tstOut t, 'm.c:' m.c.0': 1='m.c.1 '2='m.c.2 '3='m.c.3
call tstOut t, ' 4='m.c.4 '5='m.c.5 '6='m.c.6
call tstEnd t
return
endProcedure tstM
tstMap: procedure expose m.
m = mapNew('K')
ky = mapKeys(m)
say '***mapNew' m 'keys' ky
call tst t, 'tstMap',
, "map "m": zwei --> 2",
, "map "m": Zwei is not defined",
, "map stem "ky" 4",
, "map "m": eins --> 1",
, "map "m": zwei --> 2",
, "map "m": drei --> 3",
, "map "m": vier --> 4",
, "*** err: duplicate key eins in map MAP.2",
, "map MAP.2: zwei is not defined",
, "q 2 zw dr",
, "map stem Q 2",
, "map Q: zw --> 2Q",
, "map Q: dr --> 3Q",
, "map stem MAP.2 3",
, "map MAP.2: eins --> 1",
, "map MAP.2: zwei --> 2PUT",
, "map MAP.2: vier --> 4PUT",
, "*** err: duplicate key zwei in map MAP.2"
call mAdd t'.CMP',
, "tstMapLong eins keys 3",
, "tstMapLong zweiMal keys 48",
, "tstMapLong dreiMal keys 93",
, "tstMapLong vier keys 138",
, "tstMapLong <fuenf> keys 188",
, "tstMap clear keys 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
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.
call tst t, 'tstMap',
, "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"
drop m.a.
call mapReset m
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 = 'valAt m.a'
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')
u='A.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**')
u= m.a
m.u = 'valAt m.'u
m.u.f = 'valAt m.'u'.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
tstJsay: procedure expose m.
call jIni
call jOut 'out eins'
call jOut 'out zwei jIn' jIn(vv) 'vv='vv
vv = 'value'
call jOut 'out drei jIn' jIn(vv) 'vv='vv 'Schluss'
return
endProcedure tstJsay
tstJ: procedure expose m.
call jIni
oldJin = m.j.jIn
oldJOut = m.j.jOut
m.j.jIn = t
m.j.jOut = t
b = jOpen(jBuf(), 'w')
call tst t, "tstJ",
, "out eins",
, "<jIn 1< tst in line 1 eins ,",
, "1 jIn() tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "2 jIn() tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "3 jIn() tst in line 3 drei |",
, "jIn eof 4",
, "jIn() 3 reads vv VV",
, "line buf line one",
, "line buf line two",
, "line buf line three",
, "line buf line four",
, "*** err: jWrite(" || b", buf line four) but not ope",
|| "ned w"
call jOut 'out eins'
do lx=1 by 1 while jIn(var)
call jOut lx 'jIn()' m.var
end
call jOut 'jIn()' (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, 'r'
do while (jRead(b, line))
call jOut 'line' m.line
end
call jWrite b, 'buf line four'
call jClose b
call tstEnd t
return
endProcedure tstJ
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
tstCat: procedure expose m.
call catIni
call tst t, "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"
i = cat('£', jBuf('line 1', 'line 2'), '£', jBuf('line 3'))
call jOpen i, 'r'
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'catRead' lx m.v
end
call jOpen i, 'a'
call jWrite i, 'append 4'
call jWrite i, 'append 5'
call jOpen i, 'r'
do lx=1 by 1 while jRead(i, v)
call tstOut t, 'appRead' lx m.v
end
call tstEnd t
return
endProcedure tstCat
tstJ2: procedure expose m.
call jIni
call tst t, "tstJ2",
, "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",
, "c read EINS feld eins, ZWEI feld zwei 2, DREI drei cat 2"
ty = oFldNew('Tst*', , , 'EINS = ZWEI = DREI =')
m.qq.eins = 'feld eins'
m.qq.zwei = 'feld zwei'
m.qq.drei = 'feld drei'
b = jBuf()
call oSetTypePara b, ty
call jOpen b, 'w'
call jWrite b, qq
m.qq.zwei = 'feld zwei 2'
call jWrite b, qq
call jOpen b, 'r'
c = jOpen(cat(), 'w')
call oSetTypePara c, ty
do xx=1 while jRead(b, res)
call jOut 'b read EINS' m.res.eins', ZWEI' m.res.zwei,
|| ', DREI' m.res.drei
m.res.drei = 'drei cat' xx
call jWrite c, res
end
call jOpen c, 'r'
do while jRead(c, ccc)
call jOut 'c read EINS' m.ccc.eins', ZWEI' m.ccc.zwei,
|| ', DREI' m.ccc.drei
end
call tstEnd t
return
endProcedure tstJ2
tstCatDsn: procedure expose m.
call catIni
call tst t, "tstCatDsn",
, "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 | . ",
|| " "
pds = tstDsn('lib', 'r')
call tstCatDsnWr pds, 0, ' links0', ' und rechts | . '
call tstCatDsnWr pds, 1, ' links1', ' und rechts | . '
call tstCatDsnWr pds, 2, 'liinks2', ' und rechts | . '
call tstCatDsnWr pds, 5, 'links5', 'rechts5'
call tstCatDsnWr pds, 99, 'links99', 'rechts'
call tstCatDsnWr pds, 100, 'links100', 'rechts'
call tstCatDsnWr pds, 101, 'links101', 'rechts'
call tstCatDsnWr pds, 999, 'links999', 'rechts'
call tstCatDsnWr pds, 1000, 'links1000', 'rechts'
call tstCatDsnWr pds, 1001, 'links1001', 'rechts'
call tstCatDsnWr pds, 2109, 'links2109', 'rechts'
pd2 = tstDsn('li2', 'r')
call envPush env('>', pd2'(eins) ::F')
call jOut 'out > eins 1'
call jOut 'out > eins 2 schluss.'
call envPop
call envPush env('>', pd2'(zwei) ::F')
call jOut 'out > zwei mit einer einzigen Zeile'
call envPop
b = jBuf("buf eins", "buf zwei", "buf drei")
call envPush env('<+', pd2'(eins) ::F', '+£', b,
,'+£', jBuf(), '+', pd2'(zwei)',
,'+', pds'(WR0)','', pds'(wr1)')
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstCatDsn
tstCatDsnWR: procedure expose m.
parse arg dsn, num, le, ri
io = catDsn(dsn'(wr'num') ::F')
call jOpen io, 'w'
do x = 1 to num
call jWrite io, le x ri
end
if num > 100 then
call catDsnReset io, dsn'(wr'num') ::F'
call jOpen io, 'r'
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'
if jRead(io, vv) then
call err x'+1 jRead'
call jClose io
call tstOut t, 'write read' num 'last' length(m.vv) strip(m.vv,'t')
return
endProcedure tstCatDsnRW
tstEnv: procedure expose m.
call envIni
c = jBuf()
call tst t, "tstEnv",
, "before envPush",
, "after envPop",
, "*** err: jWrite("c", write nach pop) but not op",
|| "ened w",
, "<jIn 1< tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "jIn eof 4",
, "before readWrite 2 c --> std",
, "before readWrite 1 b --> c",
, "b line eins",
, "b zwei |",
, "nach readWrite 1 b --> c",
, "add nach pop",
, "after push c only",
, "tst in line 1 eins ,",
, "tst in line 2 zwei ; "
call mAdd t'.CMP',
, "tst in line 3 drei |",
, "nach readWrite 2 c --> std",
, "*** err: jWrite("c", ) but not opened w"
call jOut 'before envPush'
b = jBuf("b line eins", "b zwei |")
call envPush env('<£', b, '>£', c)
call jOut 'before readWrite 1 b --> c'
call envReadWrite
call jOut 'nach readWrite 1 b --> c'
call envPop
call jOut 'after envPop'
call jWrite c, 'write nach pop'
call mAdd c'.BUF', 'add nach pop'
call envPush env('>>£', c)
call jOut 'after push c only'
call envReadWrite
call envPop
call envPush env('<£', c)
call jOut 'before readWrite 2 c --> std'
call envReadWrite
call jOut 'nach readWrite 2 c --> std'
call envPop
call jWrite c
call tstEnd t
return
endProcedure tstEnv
tstEnvCat: procedure expose m.
call tst t, "tstEnvCat",
, "c1 contents",
, "c1 line eins |",
, "before readWrite 1 b* --> c*",
, "b1 line eins|",
, "b2 line eins",
, "b2 zwei |",
, "c2 line eins |",
, "after readWrite 1 b* --> c*",
, "c2 contents",
, "c2 line eins |"
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 envPush env('<+£', b0, '<+£', b1, '<+£', b2, '<£', c2,
,'>>£', c1)
call jOut 'before readWrite 1 b* --> c*'
call envReadWrite
call jOut 'after readWrite 1 b* --> c*'
call envPop
call jOut 'c1 contents'
call envPush env('<£', c1)
call envReadWrite
call envPop
call envPush env('<£', c2)
call jOut 'c2 contents'
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstEnv
tstEnvBar: procedure expose m.
call tst t, 'tstEnvBar',
, "+0 vor envBarBegin",
, "<jIn 1< tst in line 1 eins ,",
, "<jIn 2< tst in line 2 zwei ; ",
, "<jIn 3< tst in line 3 drei |",
, "jIn eof 4",
, "+7 nach envBarLast",
, "[7 +6 nach envBar 7]",
, "[7 +2 nach envBar 7]",
, "[7 +4 nach nested envBarLast 7]",
, "[7 (4 +3 nach nested envBarBegin 4) 7]",
, "[7 (4 (3 +1 nach envBarBegin 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 | 3) 4) 7]",
, "[7 (4 (3 +1 nach readWrite vor envBar 3) 4) 7]",
, "[7 (4 +3 nach preSuf vor nested envBarLast 4) 7]",
, "[7 +4 nach preSuf vor nested envBarEnd 7]"
call mAdd t.cmp,
, "[7 +5 nach nested envBarEnd vor envBar 7]",
, "[7 +6 nach readWrite vor envBarLast 7]",
, "+7 nach readWrite vor envBarEnd",
, "+8 nach envBarEnd"
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call envReadWrite
call jOut '+1 nach readWrite vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call envPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call envPreSuf '(4 ', ' 4)'
call jOut '+4 nach preSuf vor nested envBarEnd'
call envBarEnd
call jOut '+5 nach nested envBarEnd vor envBar'
call envBar
call jOut '+6 nach envBar'
say '?? 6 call envReadWrite'
call envReadWrite
say 'jOut +6 nach readWrite vor envBarLast'
call jOut '+6 nach readWrite vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call envPreSuf '[7 ', ' 7]'
call jOut '+7 nach readWrite vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call tstEnd t
return
endProcedure tstEnvBar
tstEnvLazy: procedure expose m.
call tst t, "tstEnvLazy",
, "vor envBarBegin",
, "vor 2 writeAll jIn inIx 0",
, "vor writeAll jBuf",
, "jBuf line 1",
, "jBuf line 2",
, "vor writeAll jIn 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 |",
, "tst in line 3 drei |",
, "jIn eof 4",
, "vor barLast inIx 0",
, "vor barEnd inIx 4",
, "nach barEnd"
call jOut 'vor envBarBegin'
call envBarBegin
call jOut 'vor writeAll jBuf'
call jWriteAll m.j.jOut, "£", jBuf('jBuf line 1', 'jBuf line 2')
call jOut 'vor writeAll jIn inIx' m.t.inIx
call jWriteAll m.j.jOut, "£-", m.j.jIn
call jOut 'vor barLast inIx' m.t.inIx
call envBarLast
call jOut 'vor 2 writeAll jIn inIx' m.t.inIx
call jWriteAll m.j.jOut, "£-", m.j.jIn
call jOut 'vor barEnd inIx' m.t.inIx
call envBarEnd
call jOut 'nach barEnd'
call tstEnd t
return
endProcedure tstEnvLazy
tstEnvVars: procedure expose m.
call tst t, "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"
put1 = envPut('v1', 'value eins')
call tstOut t, 'put v1' 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 envPush env('>#', 'theBuf')
call jOut 'one to theBur'
call jOut 'two to theBuf'
call envPop
call envPush env('<#', 'theBuf')
call envReadWrite
call envPop
call tstEnd t
return
endProcedure tstEnvVars
tstScan: procedure expose m.
call tst t, 'tstScan.1',
, "scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' ",
, "scan n tok 4: a034 key val ",
, "scan 1 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"
call tstScan1 ,'l"litEins"l"litZwei"ndv" "aq1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
call tst t, 'tstScan.2',
, "scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' ",
, "scan n tok 4: a034 key val ",
, "scan 1 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 s tok 5: ""st1"" key val st1",
, "scan b tok 0: key val st1",
, "scan s tok 19: 'str2''mit''apo''s' key val str2'mit'apo's",
, "scan b tok 0: key val str2'mit'apo's"
call tstScan1 , 'ndsb1' ,
,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call tstEnd t
call tst t, 'tstScan.3',
, "scan src a034,'wie 789abc",
, "scan n tok 4: a034 key val ",
, "scan 1 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 1 tok 1: ' key val ",
, "scan n tok 3: wie key val ",
, "scan 1 tok 1: key val ",
, "*** err: scanErr illegal number end",
, " 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 "
call tstScan1 , 'nds1' ,
,"a034,'wie 789abc"
call tstEnd t
call tst t, 'jTestScan.4',
, "scan src litEinsefr 23 sdfER'str1'litZwei ""str2""""mit qu",
|| "o""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"
call tstScan1 , 'l"litEins"l"litZwei"ndbaq1' ,
,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call tstEnd t
call tst t, 'jTestScan.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 1 tok 1: ; key aha val def",
, "scan 1 tok 1: + key aha val def",
, "scan 1 tok 1: - key aha val def",
, "scan 1 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"
call tstScan1 , 'bk1'," aha;+-=f ab=cdEf eF='strIng' "
call tstEnd t
return
endProcedure tstScan
tstScanRead: procedure expose m.
call tst t, 'jTestScanRead',
, "name erste",
, "space",
, "name Zeile",
, "space",
, "nextLine",
, "nextLine",
, "space",
, "name dritte",
, "space",
, "name Zeile",
, "space",
, "name schluss",
, "space"
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
s = 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 tstEnd t
call tst t, 'jTestScanRead mit spaceLn',
, "name erste",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name dritte",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name schluss",
, "spaceLn"
s = scanRead(b)
do forever
if scanName(s) then call jOut 'name' m.s.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call tstEnd t
return
endProcedure tstScanRead
tstScanWin: procedure expose m.
call scanWinIni
call tst t, 'jTestScanWin',
, "info 0: last token scanPosition erste Zeile ",
|| " dritteZe\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 undZehnueberElfundNochWe",
|| "iterZwoelfundim1\npos 9 in line 10: undZehn",
, "name undZehnueberElfundNochWeiterZwoelfundim13",
, "spaceNL",
, "name Punkt",
, "infoE 14: last token Punkt scanPosition \natEnd after line",
|| " 13: im13 Punkt"
b = jBuf('?erste Zeile?',,'? dritteZeeeile?', '? zeile4 ',
,'? fuenf?', '?ueberSechsUnddS?', '?iebenUNDundUndU?',
,'?Acht ?', '? ?', '? undZehn?',
,'?ueberElfundNoch?', '?WeiterZwoelfund?', '?im13 Punkt?')
s = 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
call tst t, 'jTestScanRead',
, "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 ",
|| " fuenf\npos 4 in line 3: z3 com Zeeeile",
, "spaceNL",
, "name z4",
, "spaceNL",
, "name fuenf",
, "spaceNL",
, "info 10: last token scanPosition com Sechs com siebe",
|| "n comAcht com\npos 15 in line 5: fuenf c",
, "name com",
, "spaceNL"
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(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
call tst t, 'jTestScanSql id',
, "sqlId ABC",
, "spaceNL",
, "sqlId AB__345EF",
, "spaceNL"
b = jBuf('abc -- kommentar', right('ab_', 72), '_345ef-- kom')
s = 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
call tst t, 'jTestScanSql delimited',
, "sqlDeId ABC",
, "spaceNL",
, "sqlDeId AB_3F",
, "spaceNL",
, "sqlDeId abc",
, "spaceNL",
, "sqlDeId ab_Ef",
, "spaceNL"
b = jBuf('abc -- kommentar',,' -- ',,right('ab_', 72),'3F-- kom',
, '"abc" -- ko', ' -- ',,right('"ab_', 72),'Ef"-- kom')
s = 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
call tst t, 'jTestScanSql qualified',
, "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"
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 = 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
call tst t, 'jTestScanSql Num',
, "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"
call mAdd t.cmp,
, "sqlNum 1E2",
, "spaceNL",
, "sqlNum -2E-2",
, "spaceNL",
, "sqlNum +.3E+3",
, "spaceNL"
b = jBuf('1 2. .3 4.5 +6 + --kom', , ' -- com ', , ' 7.03 -8 - .9',
'1e2 - 2.e-2 + .3e+3')
s = 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
call tst t, 'jTestScanSql Num Unit',
, "sqlNumUnit 1 KB",
, "spaceNL",
, "sqlNumUnit .3 MB",
, "sqlNumUnit .5",
, "sqlNumUnit +6E-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.Tb",
, "sqlNumUnit +9",
, "spaceNL"
b = jBuf('1 kb .3mB.5 + 6.e-5B -7* -.8 TB + 9.Tb')
s = 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
call tst t, 'jTestScanRead',
, "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 ",
|| " fuenf\npos 4 in line 3: z3 com Zeeeile",
, "spaceNL",
, "name z4",
, "spaceNL",
, "name fuenf",
, "spaceNL",
, "info 10: last token scanPosition com Sechs com siebe",
|| "n comAcht com\npos 15 in line 5: fuenf c",
, "name com",
, "spaceNL"
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, , ,'com', , , 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
return
call tst t, 'jTestScanRead mit spaceLn',
, "name erste",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name dritte",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name schluss",
, "spaceLn"
s = scanRead(b)
do forever
if scanName(s) then call jOut 'name' m.s.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call tstEnd t
return
endProcedure tstScanSql
/*--- one single test scan with lines to scan in stem ln -------------*/
tstScan1:
parse arg sc, types, 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, types)
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 = ''
do while cx <= length(opt)
f = substr(opt, cx, 1)
cx = cx + 1
if pos(substr(opt, cx, 1), "'""") > 0 then do
m.scan.type.src = opt
m.scan.type.pos = cx
call scanString 'SCAN.TYPE'
a2 = m.scan.type.val
cx = m.scan.type.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 == 'n' then
res = scanName(s)
else if f == 'q' then
res = scanString(s, '"')
else if f == 's' 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')
else if pos(f, '123456789') > 0 then
res = scanChar(s, f)
else
call err 'bad scanType' f
if res then
return f
end
return ''
endProcedure tstScanType
tstO: procedure expose m.
cR = oNewClass('R')
iR = 'O.C'm.o.cla.cR'I'
oo = 'call tstOut' t','
call oDecMethods cR, "print" oo "'Rprint' m a1",
, "say" oo "'Rsay ' m a2; return"
cS = oNewClass('S', "R")
is = 'O.C'm.o.cla.cS'I'
call oDecMethods cS, "print" oo "'Sprint' m a1; return",
, "quak" oo "'Squak ' m a3; return 'quak'a3"
call tst t, 'tstO',
, "class R with 2 methods",
, " print call tstOut T, 'Rprint' m a1",
, " say call tstOut T, 'Rsay ' m a2; return",
, "class S with 3 methods",
, " print call tstOut T, 'Sprint' m a1; return",
, " say call tstOut T, 'Rsay ' m a2; return",
, " quak call tstOut T, 'Squak ' m a3; return 'quak'a3",
, "oR.print call tstOut T, 'Rprint' m a1",
, "oS.print call tstOut T, 'Sprint' m a1; return",
, "oS.say call tstOut T, 'Rsay ' m a2; return",
, "Rsay "iR"1 arg oR say",
, "Rprint "iR"1 arg oR print",
, "Rsay "iS"1 arg oS say"
call mAdd t.cmp ,
, "Sprint "iS"1 arg oS print",
, "Squak "iS"1 arg oS quak",
, "quak: quakarg oS quak",
, "Rprint "iS"1 cast(os, R)",
, "Sprint "iS"1 cast(os, R), S)",
, "mutate oS R "iS"1",
, "Rprint "iS"1 mutate R",
, "oRun 7*3 21",
, "oRun 12*12 144"
cc = 'R S'
do cx=1 to words(cc)
cl = word(cc, cx)
call tstOut t, 'class' cl 'with' m.o.cla.cl.met.0 'methods'
do mx=1 to m.o.cla.cl.met.0
me = m.o.cla.cl.met.mx
call tstOut t, ' ' me m.o.cla.cl.met.me
end
end
oR = oNew(cR)
oS = oNew(cS)
call tstOut t, 'oR.print' oObjMethod(oR, 'print')
call tstOut t, 'oS.print' oObjMethod(oS, 'print')
call tstOut t, 'oS.say' oObjMethod(oS, 'say')
call tstClassRsay oR, 'arg oR say'
call tstClassRprint oR, 'arg oR print'
call tstClassRsay oS, 'arg oS say'
call tstClassRprint oS, 'arg oS print'
call tstOut t, 'quak:' tstClassSquak(oS, 'arg oS quak')
q1 = oCast(oS, 'R')
call tstClassRprint q1, 'cast(os, R)'
q2 = oCast(q1, 'S')
call tstClassRprint q2, 'cast(os, R), S)'
call tstOut t, 'mutate oS R' oMutate(oS, 'R')
call tstClassRprint oS, 'mutate R'
rr = oRunner('return 7 * 3')
call tstOut t, 'oRun 7*3' oRun(rr)
call oRunnerReset rr, 'return 12 * 12'
call tstOut t, 'oRun 12*12' oRun(rr)
call tstEnd t
return
endProcedure tstO
tstOType: procedure
call oIni
si = 'Simple'
call oFldNew 'T1', '=', '=', 'A = B ='
m.x.0 = 3
call oSay 'T1', x
call oSay 'Class', 'O.CLA.='
call oSay 'Class', 'O.CLA.Class'
call oClear 'Class', abc, 'abc'
call oSay 'Class', abc
call oTyCopy 'Class', abc, 'O.CLA.Class'
call oSay 'Class', abc
call oCopy efg, 'O.CLA.Class'
call oSay 'Class', efg
ff = oFlds('Class')
x = m.ff.0
say 'fields' x':' m.ff.1 m.ff.2 '...' m.ff.x
return
endProcedure tstOType
tstClassRprint: procedure expose m.
parse arg m, a1
interpret oObjMethod(m, 'print')
return
endProcedure tstClassRprint
tstClassRsay: procedure expose m.
parse arg m, a2
interpret oObjMethod(m, 'say')
endProcedure tstClassRsay
tstClassSquak: procedure expose m.
parse arg m, a3
interpret oObjMethod(m, 'quak')
endProcedure tstClassSquak
/* copx tstBase end *************************************************/
/* copx tst begin ****************************************************
test infrastructure
***********************************************************************/
/*--- return stems ---------------------------------------------------*/
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
tst: procedure expose m.
parse arg m, nm
if m.tst.ini <> 1 then
call tstIni
m.m.name = nm
m.tst.act = m
m.tst.tests = m.tst.tests+1
call oMutate m, 'Tst'
m.m.jReading = 1
m.m.jWriting = 1
ox = 1
m.m.cmp.ox = left('****** start tst' nm '', 79, '*')
do ax=3 to arg()
ox = ox + 1
m.m.cmp.ox = arg(ax)
end
m.m.cmp.0 = ox
m.m.in.0 = 0
m.m.inIx = 0
m.m.out.0 = 0
m.m.err = 0
call mAdd m'.IN', 'tst in line 1 eins ,' ,
, 'tst in line 2 zwei ; ' ,
, 'tst in line 3 drei |'
call oMutate m, 'Tst'
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
call envPush env( '<-£', m, '>-£', m)
call tstOut m, m.m.cmp.1
return 'TST.'m
endProcedure tst
tstEnd: procedure expose m.
parse arg m, opt
m.tst.act = ''
call envPop
if m.env.0 <> 1 then
call tstErr m, 'm.env.0' m.env.0 '<> 1'
if m.m.out.0 ^= m.m.cmp.0 then do
call tstErr m, 'old' m.m.cmp.0 'lines ^= new' m.m.out.0
do nx = m.m.out.0 + 1 to min(m.m.out.0+10, m.m.cmp.0)
say 'old - ' m.m.cmp.nx
end
end
if m.m.err > 0 then do
say 'new lines:' (m.m.out.0 - 1)
len = 60
do nx=2 to m.m.out.0
str = quote(m.m.out.nx, '"')
pr = ' , '
do while length(str) > len
l=len
if substr(str, l-1, 1) = '"' then
if posCount('"', left(str, l-1)) // 2 = 0 then
l = l-1
say pr left(str, l-1)'",'
str = '"'substr(str, l)
pr = ' ||'
end
say pr str || left(',', nx < m.m.out.0)
end
end
say left('******' m.m.name 'end with' m.m.err 'errors ', 79,
, '*')
return
endProcedure tstEnd
/*--- write to test: say lines and compare them ----------------------*/
tstWrite: procedure expose m.
parse arg m, arg
call tstOut m, 'jOut:' arg
return
endProcedure tstWrite
tstOut: procedure expose m.
parse arg m, arg
call mAdd m'.OUT', arg
nx = m.m.out.0
if nx > m.m.cmp.0 then do
if nx = m.m.cmp.0+1 then
call tstErr m, 'more new Lines' nx
end
else if m.m.cmp.nx ^== arg then do
call tstErr m, 'next line old' nx '^^^ new overnext'
say m.m.cmp.nx
end
say arg
return
endProcedure tstOut
tstRead: 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
call tstOut m, '<jIn' ix'<' m.arg
return 1
end
call tstOut m, 'jIn eof' ix
return 0
endProcedure tstRead
tstDsn: procedure
parse arg suf, opt
dsn = dsn2jcl('~tmp.tst.'suf)
if opt = 'r' & sysDsn("'"dsn"'") ^== 'DATASET NOT FOUND' then
call adrTso "delete '"dsn"'"
return dsn
endProcedure tstDsn
/*--- 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
endProcedure tstErr
/*--- tstErrHandler: intercept errors --------------------------------*/
tstErrHandler: procedure expose m.
parse arg ggTxt
if m.tst.act == '' then
call err ggTxt, '*'
call errSay ggTxt, tstErrHandler
call tstOut m.tst.act, '*** err:' m.tstErrHandler.1
do x=2 to m.tstErrHandler.0
call tstOut m.tst.act, ' e' (x-1)':' m.tstErrHandler.x
end
return 12
endSubroutine tstErrHandler
/*--- tstIni: global initialization ----------------------------------*/
tstIni: procedure expose m.
if m.tst.ini == 1 then
return
m.tst.ini = 1
call envIni
m.tst.err = 0
m.tst.errNames = ''
m.tst.tests = 0
m.tst.act = ''
call oDecMethods oNewClass("Tst", 'JRW'),
, "jRead return tstRead(m, var)",
, "jWrite call tstOut m, line"
call errReset 'h', 'return tstErrHandler(ggTxt)'
return
endProcedure tstIni
/*--- 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
/* copx tst end **************************************************/
/* copy tstAll end **************************************************/
/* copy sort begin ****************************************************/
sort: procedure expose m.
parse arg i, o
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, w1
if le <= 1 then do
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, w1
call sort1 i, i0+h, le-h, w, w1, o, o0
call sortMerge o, o0+le-h, o0+le, w, w1, w1+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
if m.l.l0 <<= m.r.r0 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 sortWork
/* 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 envIni
call scanReadIni
cc = oNewClass('Compiler')
return
endProcedure compIni
/*--- constructor of Compiler ----------------------------------------*/
comp: procedure expose m.
parse arg src
nn = oNew('Compiler')
m.nn.scan = scanRead(src)
return compReset(nn, src)
endProcedure comp
compReset: procedure expose m.
parse arg m, src
call scanReadReset m.m.scan, src, , ,'$*'
m.m.chDol = '$'
m.m.chSpa = ' '
m.m.chNotWord = '${}=£:' || m.m.chSpa
m.m.stack = 0
return m
endProceduere compReset
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp ^== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile the source and return an oRunner with the code ---------*/
compile: procedure expose m.
parse arg m, type
if type == 's' then do
what = "shell"
expec = "pipe or $;";
call compSpNlComment m
src = compShell(m)
end
else if type == 'd' then do
what = "data";
expec = "sExpression or block";
src = compData(m, 0)
end
else do
call err "bad type " type
end
if ^ scanAtEnd(m.m.scan) then
call scanErr m.m.scan, expec "expected: compile" what ,
" stopped before end of input"
call scanClose m.m.scan
r = oRunner(src)
return r
endProcedure compile
/*--- compile data lines return stmts or expr ------------------------*/
compData: procedure expose m.
parse arg m, makeExpr
s = m.m.scan
exprs = compPushStem(m)
do forever
aftEol = 0
do forever
text = "";
do forever
if scanVerify(s, m.m.chDol, 'm') then
text = text || m.s.tok
if ^ compComment(m) then
leave
end
nd = compExpr(m, 'd')
befEol = scanReadNL(s)
if nd <> '' | (aftEol & befEol) ,
| verify(text, m.m.chSpa) > 0 then do
if text ^== '' then
text = quote(text)
if text ^== '' & nd ^= '' then
text = text '|| '
call mAdd exprs, 'e' compNull2EE(text || nd)
end
if ^ befEol then
leave
aftEol = 1
end
one = compStmt(m)
if one == '' then
one = compRedirIO(m, 0)
if one == '' then
leave
call mAdd exprs, 's' one
end
if m.exprs.0 < 1 then do
if makeExpr then
res = '""'
else
res = ';'
end
else do
do x=1 to m.exprs.0 while left(m.exprs.x, 1) = 'e'
end
res = ''
if makeExpr & x > m.exprs.0 then do
res = substr(m.exprs.1, 3)
do x=2 to m.exprs.0
res = res substr(m.exprs.x, 3)
end
end
else do
do x=1 to m.exprs.0
if left(m.exprs.x, 1) = 'e' then
res = res 'call jOut'
res = res substr(m.exprs.x, 3)';'
end
if makeExpr then
res = "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
end
call compPop m, exprs
return res
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 strip(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
res = ''
if type == 'w' then
charsNot = m.m.chNotWord
else
charsNot = m.m.chDol
s = m.m.scan
if pos(type, 'sw') > 0 then
call compSpComment m
do forever
txt = ''
do forever
if scanVerify(s, charsNot, 'm') then
txt = txt || m.s.tok
if ^ compComment(m) then
leave
end
pr = compPrimary(m)
if pr = '' & pos(type, 'sw') > 0 then
txt = strip(txt, 't')
if txt ^== '' then
res = res '||' quote(txt)
if pr = '' then do
if pos(type, 'sw') > 0 then
call compSpComment m
if res == '' then
return ''
return substr(res, 5)
end
res = res '||' pr
end
return ''
endProcedure compExpr
/*--- push an empty stem on the stack --------------------------------*/
compPushStem: procedure expose m.
parse arg m
m.m.stack = m.m.stack + 1
pp = m'.STACK'm.m.stack
m.pp.0 = 0
return pp
endProcedure compPushStem
/*--- push a stem from the stack -------------------------------------*/
compPop: procedure expose m.
parse arg m, pp
if pp ^== m'.STACK'm.m.stack then
call err 'compPop pp' pp 'mismatch to' m'.STACK'm.m.stack
m.m.stack = m.m.stack - 1
return m
endProcedure compPop
/*--- compile a primary and return code ------------------------------*/
compPrimary: procedure expose m.
parse arg m
s = m.m.scan
if ^ scanLit(s, '$') then
return ''
if scanString(s) then
return m.s.tok
if scanLit(s, '(') then do
one = compCheckNN(m, compLang(m, 0), 'rexx expexted after $(')
if ^ scanLit(s, '$)') then
call scanErr s, 'closing $) missing after $(...'
return '('one')'
end
if scanLit(s, '-[') then do
res = compData(m, 1)
if ^scanLit(s, '$]') then
call scanErr s, 'closing $] missing after $-[ data'
return res
end
if scanLit(s, '-{') then do
res = compShell(m)
if ^scanLit(s, '$}') then
call scanErr s, 'closing $} missing after $-{ shell'
return "mCat("compStmts2ExprBuf(res)"'.BUF', ' ')"
end
if scanLit(s, '-cmpShell', '-cmpData') then do
return 'compile(comp(envRead2Buf()),' ,
'"'substr('ds', 1+(m.s.tok == '-cmpShell'), 1)'")'
end
if scanLit(s, '{') then do
if scanLit(s, '?') then
f = 'envIsDefined'
else if scanLit(s, '>') then
f = 'envRead'
else
f = 'envGet'
nm = compExpr(m, 'w')
if ^scanLit(s, '}') then
call scanErr s, 'closing } missing after ${'
return f'('nm')'
end
if scanName(s) then
return 'envGet('quote(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 = compStmts(m)
if one == '' then do
if stmtLast ^== '' then
call scanErr s, 'stmts expected afte $!'
if ios == '' then
return ''
leave
end
if stmtLast ^== '' then
stmts = stmts 'call envBar;' stmtLast
stmtLast = one
end
end
if stmts ^== '' then
stmtLast = insert('Begin', stmts, pos('envBar;', stmts)+5) ,
'call envBarLast;' stmtLast 'call envBarEnd;'
if ios ^== '' then do
if stmtLast == '' then
stmtLast = 'call envReadWrite;'
stmtLast = 'call envPush env('substr(ios, 3)');' stmtLast ,
'call envPop;'
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, makeExpr
s = m.m.scan
if ^ scanLit(s, '$&', '$<<', '$<', '$>>', '$>') then
return ''
opt = substr(m.s.tok, 2)
call scanVerify s, '+-£#[{'
opt = opt || m.s.tok
/* ???? call compSpComment m */
if left(opt, 2) ^== '<<' then do
if verify(opt, '[{', 'm') > 0 ,
| (left(opt, 1) == '&' & pos('£', opt) > 0) then
call scanErr s, 'inconsistent io redirection option' opt
ex = compCheckNN(m, compExpr(m, 's'),
, 'expression expected after $'opt)
end
else do
if verify(opt, '-£#', 'm') > 0 then
call scanErr s, 'inconsistent io redirection option' opt
if ^ scanName(s) then
call scanErr s, 'stopper expected in heredata after $'opt
stopper = m.s.tok
call scanVerify s, m.m.chSpa
if ^ scanReadNl(s) then
call scanErr s,
, 'space nl expected in heredata after $'opt||stopper
buf = jOpen(jBuf(), 'w')
do while ^ scanLit(s, stopper)
call jWrite buf, m.s.src
if ^ scanReadNl(s, 1) then
call scanErr s, 'eof in heredata after $'opt||stopper
end
call jClose buf
if verify(opt, '[{', 'm') > 0 then do
if pos('[', opt) > 0 then
ex = compile(comp(buf), 'd')
else
ex = compile(comp(buf), 's')
if makeExpr then
return "'<£', envRun("quote(ex)")"
else
return "call oRun" quote(ex)";"
end
opt = '<£'
ex = quote(buf)
end
if makeExpr then
return "'"opt"'," ex
else if left(opt, 1) = '>' then
call scanErr s, 'cannot write ioRedir $'opt
else
return "call envReadWrite '"opt"'," ex
endProcedure compRedirIO
/*--- compile stmts (stmt or java) -----------------------------------*/
compStmts: procedure expose m.
parse arg m
res = ''
do forever
one = compStmt(m)
if one == '' then
one = compLang(m, 1)
if one == '' then
return res
res = res strip(one)
call compSpNlComment m
end
endProcedure compStmts
/*--- compile a single statement -------------------------------------*/
compStmt: procedure expose m.
parse arg m
s = m.m.scan
if scanLit(s, "$=") then do
nm = compCheckNN(m, compExpr(m, 'w'), "variable name")
if scanLit(s, "=") then
vl = compExpr(m, 's')
else if scanLit(s, "£") then
vl = compCheckNN(m, compLang(m, 0),
, 'java expression after $= .. £')
else
call scanErr s, '= or £ expected after $= name'
return 'call envPut' nm',' vl';'
end
else if scanLit(s, '$@{') then do
call compSpNlComment m
one = compShell(m)
if ^ scanLit(s, "$}") then
call scanErr s, "closing $} missing for $@{ shell"
return "do;" one "end;"
end
else if scanLit(s, '$@[') then do
call compSpNlComment m
one = compData(m, 0)
if ^ scanLit(s, "$]") then
call scanErr s, "closing $] missing for $@] data"
return "do;" one "end;"
end
else if scanLit(s, '$$') then do
return 'call jOut' compExpr(m, 's')';'
end
else if scanLit(s, '$£') then do
return 'call jOut' compCheckNN(m, compLang(m, 0),
, 'language expression after $£')';'
end
else if scanLit(s, '$@for') then do
v = compCheckNN(m, compExpr(m, 'w') ,
, "variable name after $@for")
call compSpNlComment m
return 'do while envRead('v');',
compCheckNN(m, compStmt(m),
, "statement after $@for variable") 'end;'
end
else if scanLit(s, '$@run') then do
return 'call oRun' compCheckNN(m, compExpr(m, 's'),
, 'expression after $@run') ';'
end
return ''
endProcedure compStmt
/*--- compile a language clause
multi=0 a single line for a rexx expression
multi=1 mulitple lines for rexx statements
(with rexx line contiunation) -----------------------*/
compLang: procedure expose m.
parse arg m, multi
s = m.m.scan
res = ''
do forever
if scanVerify(s, m.m.chDol, 'm') then do
res = res || m.s.tok
end
else do
one = compPrimary(m)
if one ^== '' then
res = res || one
else if compComment(m) then
res = res || ' '
else if ^multi then
return res
else if ^ scanReadNl(s) then do
if res == '' then
return res
else
return strip(res)';'
end
else do
res = strip(res)
if right(res, 1) = ',' then
res = strip(left(res, length(res)-1))
else
res = res';'
end
end
end
endProcedure compLang
/*--- convert stmts to an expression yielding the output ------------*/
compStmts2ExprBuf: procedure expose m.
parse arg stmts
rr = oRunner(stmts)
return "envRun('"rr"')"
endProcedure compStmts2ExprBuf
/*--- convert '' to an empty expression ------------------------------*/
compNull2EE: procedure
parse arg e
if e = '' then
return '""'
return e
endProcedure compNull2EE
/*--- if va == '' 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
/*--- skip a comment. return 0 if there is none ----------------------*/
compComment: procedure expose m.
parse arg m
s = m.m.scan
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 0
return 1
endProcedure compComment
/*--- skip spaces and comments ---------------------------------------*/
compSpComment: procedure expose m.
parse arg m
found = 0
do forever
if scanVerify(m.m.scan, m.m.chSpa) then
found = 1
else if compComment(m) then
found = 1
else
return found
end
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 sqlO begin ***************************************************
sql interface mit o und j Anbindung
***********************************************************************/
sqlOini: procedure expose m.
if m.sqlO.ini == 1 then
return
m.sqlO.ini = 1
call sqlIni
call envIni
call oDecMethods oNewClass("SqlType", "JRW"),
, "jOpen call sqlOpen substr(m, 8); m.m.jReading = 1",
, "jClose call sqlClose substr(m, 8)",
, "jRead return sqlFetch(substr(m, 8), var)"
call oDecMethods oNewClass("SqlLn", "SqlType"),
, "jRead return sqlFetchLn(substr(m, 8), var)"
return
endProcedure sqlOini
/*--- 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 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 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.jOut, "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.jOut, fmtFldTitle(m.sql.cx.fmt)
call jWriteAll m.j.jOut, "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
do ggAx=2 to arg()
call sqlDataSet 'SQL.'ggCx'.I', ggAx-1, arg(ggAx)
end
call sqlExec 'execute s'ggCx 'using descriptor :M.SQL.'ggCx'.I'
return
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
call sqlExec "disconnect ", ggRet, 1
return
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
call 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 fmt begin **************************************************/
/*--- format the first arg by the format in the second ---------------*/
fmt: procedure
parse arg v, f 2 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 = '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, f
return fmt(v, f)
endProcedure fmtS $
/* copy fmt end **************************************************/
/* copy fmtF begin **************************************************/
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, type, src
fs = oFlds(type)
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
fmtFldRW: procedure expose m.
parse arg fo
ty = oGetTypePara(m.j.jIn)
call assert 'oFlds(ty) == m.fo.flds', 'fo different flds than type'
call jOut fmtFldTitle(fo)
do while jIn(ii)
call jOut fmtFld(fo, ii)
end
return
endProcedure fmtTypeRW
fmtFldSquashRW: procedure expose m.
parse arg in, opCl
if in = '' then
in = m.j.jIn
if opCl == 'opCl' then
call jOpen in, 'r'
ty = oGetTypePara(in)
flds = oFlds(ty)
st = 'FMT.TYPEAD'
do ix=1 while jRead(in, st'.'ix)
end
m.st.0 = ix - 1
fo = fmtFldSquash(sqFo, ty, st)
call jOut fmtFldTitle(fo)
do ix = 1 to m.st.0
call jOut fmtFld(fo, st'.'ix)
end
if opCl == 'opCl' then
call jClose in
return
endProcedure fmtFldSquashRW
/* copy fmtF end * **************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
nn = oNew("Env")
m.nn.toClose = ''
call envReset nn
do ax=1 by 2 to arg()-1
call envAddIo nn, arg(ax), arg(ax+1)
end
return nn
endProcedure env
envReset: procedure expose m.
parse arg m
call envClose m
m.m.in = ''
m.m.out = ''
m.m.lastCat = ''
do ax=2 by 2 to arg()-1
call envAddIo m, arg(ax), arg(ax+1)
end
return m
endProcedure envReset
envClose: procedure expose m.
parse arg m
do wx=1 to words(m.m.toClose)
call jClose word(m.m.toClose, wx)
end
m.m.toClose = ''
return m
endProcedure envClose
envAddIO: procedure expose m.
parse arg m, opt, spec
contX = pos("+", opt)
if contX > 0 then do
opt = left(opt, contX-1)substr(opt,contX+1)
contX = 1
if m.m.lastCat == '' then
m.m.lastCat = cat()
end
if m.m.lastCat ^== '' then
call catWriteAll m.m.lastCat, opt, spec
else
oc = catMake(opt, spec)
if contX then
return
if m.m.lastCat ^== '' then do
oc = m.m.lastCat
m.m.lastCat = ''
opt = left(m.oc.opts.1, 1)
end
o1 = left(opt, 1)
if pos(o1, 'r<') > 0 then do
if m.m.in ^== '' then
call err 'envAddIo('opt',' spec') duplicate stdIn'
m.m.in = oc
end
else if pos(o1, 'wa>') > 0 then do
if m.m.out ^== '' then
call err 'envAddIo('opt',' spec') duplicate stdOut'
m.m.out = oc
end
if pos('-', opt) < 1 then do
call jOpen oc, catOpt(opt)
m.m.toClose = m.m.toClose oc
end
return m
endProcedure envAddIO
envLink: procedure expose m.
parse arg m, old
if m.m.lastCat ^== '' then
call err 'envLink with open cat'
if m.m.in == '' then
m.m.in = m.j.jIn
if m.m.out == '' then
m.m.out = m.j.jOut
return m
endProcedure envLink
envReadWrite: procedure expose m.
parse arg opt, rdr
if opt = '' then
call jWriteAll m.j.jOut, '-£', m.j.jIn
else
call jWriteAll m.j.jOut, opt, catMake(opt, rdr)
return
endProcedure envReadWrite
envRead2Buf: procedure expose m.
b = jBuf()
call envPush env('>£', b)
call envReadWrite
x = envPop()
return b
endProcedure envRead2Buf
envPreSuf: procedure expose m.
parse arg le, ri
do while jIn(v)
call jOut le || m.v || ri
end
return
endProcedure envPreSuf
envCatStr: procedure expose m.
parse arg mi, fo
res = ''
do while jIn(v)
res = res || mi || fmt(m.v)
end
return substr(res, length(mi))
endProcedure envCatStr
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.vars.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
return mapGet(env.vars, na)
envRead: procedure expose m.
parse arg na
return jIn('ENV.VARS.'na)
envHasKey: procedure expose m.
parse arg na
return mapHasKey(env.vars, na)
envVia: procedure expose m.
parse arg na
return mapVia(env.vars, na)
envPut: procedure expose m.
parse arg na, va
return mapPut(env.vars, na, va)
envRemove: procedure expose m.
parse arg na
return mapRemove(env.vars, na)
envIni: procedure expose m.
if m.env.ini == 1 then
return
m.env.ini = 1
call catIni
call oDecMethods oNewClass("Env", "JRW"),
, "jOpen call err 'envOpen('m', 'arg')'",
, "jReset return envReset(m, arg, arg(3), arg(4), arg(5))",
, "jClose call envClose m"
m.env.0 = 1
call mapReset env.vars
ex = env()
m.env.1 = ex
m.ex.in = m.j.jIn
m.ex.out = m.j.jOut
return
endProcedure envIni
envPush: procedure expose m.
parse arg e
ex = m.env.0
call envLink e, m.env.ex
ex = ex + 1
m.env.0 = ex
m.env.ex = e
m.j.jIn = m.e.in
m.j.jOut = m.e.out
return e
endProcedure envPush
envPop: procedure expose m.
ox = m.env.0
if ox <= 1 then
call err 'envPop on empty stack' ox
lazy = 0
if wordPos(oGetClass(m.j.jOut), 'Cat CatWrite CatRead') > 0 then do
e = m.env.ox
lazy = catLazyClose(m.j.jOut, m.e.toClose)
end
if lazy then
m.e.toClose = 'lazyDoNotClosePlease||||'
else
call envClose m.env.ox
ex = ox - 1
m.env.0 = ex
e = m.env.ex
m.j.jIn = m.e.in
m.j.jOut = m.e.out
return m.env.ox
endProcedure envPop
envBarBegin: procedure expose m.
call envPush env('>£', Cat())
return
endProcedure envBarBegin
envBar: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.oldEnv.out, '>£', Cat())
return
endProcedure envBar
envBarLast: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.oldEnv.out)
return
endProcedure envBarLast
envBarEnd: procedure expose m.
oldEnv = envPop()
return
endProcedure envBarEnd
/*--- return the output buffer of oRunner m --------------------------*/
envRun: procedure expose m.
parse arg m
b = jBuf()
call envPush env('>£', b)
call oRun m
x = envPop()
return b
endProcedure envRun
/* copy env end *******************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
catOpt: procedure
parse arg opt, keep
if abbrev(opt, '<') then
o = 'r'substr(opt, 2)
else if abbrev(opt, '>>') then
o = 'a'substr(opt, 3)
else if abbrev(opt, '>') then
o = 'w'substr(opt, 2)
else if pos(left(opt, 1), 'rwa') > 0 then
o = opt
else
o = '?'opt
if keep ^== 1 then
o = translate(o, ' ', '£#')
return space(o, 0)
endProcedure catOpt
/*--- create and possibly open a reader or writer --------------------*/
catMake: procedure expose m.
parse arg opt, spec
o = catOpt(opt, 1)
if pos('£', o) > 0 then
return spec
else if pos('#', o) > 0 then do
if envhasKey(spec) then
return catMake(translate(opt, '£', '#'), envGet(spec))
else
return envPut(spec, jBuf())
end
else if pos('&', o) > 0 then
return catDsn('&'spec)
else
return catDsn(spec)
call err 'catMake implement' opt
if defDsn == '' then do
o = left(o, length(o)-1)
end
else if defDsn == '' then do
rw = catDsn(spec)
end
else do
rw = jReset(defDsn, spec)
end
if pos('-', o) < 1 then
call jOpen rw, o
return rw
endProcedure catMake
/*--- create a new cat -----------------------------------------------*/
cat: procedure expose m.
m = oNew('Cat')
m.m.catIx = -9
call catReset m
do ax=1 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
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.catToClose = ''
m.m.catIx = -9
call oSetTypePara m
do ax=2 by 2 to arg()
call catWriteAll m, arg(ax), arg(ax+1)
end
return m
endProcedure catReset
catClose: procedure expose m.
parse arg m
if m.m.catIx == -9 then
return
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx = mInc(m'.RWS.0')
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
if m.m.catIx >= 0 then do
if m.m.catRd ^== '' then do
ix = m.m.catIx
if pos('-', m.m.opts.ix) < 1 then
call jClose m.m.catRd
m.m.catRd = ''
end
do wx = 1 to words(m.m.catToClose)
cl = word(m.m.catToClose, wx)
if cl ^== m then
call jClose cl
end
m.m.catToClose = ''
end
m.m.catIx = -9
return m
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
call jClose m
if oo = 'r' then do
m.m.catIx = 0
m.m.catRd = catNextRdr(m)
m.m.jReading = 1
end
else if oo == 'w' | oo == 'a' then do
if oo == 'w' then
m.m.RWs.0 = 0
m.m.catIx = -7
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
cx = m.m.catIx
if cx > 0 & cx <= m.m.RWs.0 & pos('-', m.m.opts.cx) < 1 then
call jClose m.m.catRd
cx = cx + 1
m.m.catIx = cx
if cx > m.m.RWs.0 then
return ''
oo = overlay('r', m.m.opts.cx)
if pos('-', oo) < 1 then
call jOpen m.m.RWs.cx, oo
return m.m.RWs.cx
endProcedure catNextRdr
catRead: procedure expose m.
parse arg m, var
do while m.m.catRd ^== ''
if jRead(m.m.catRd, var) then
return 1
m.m.catRd = catNextRdr(m)
end
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, line
if m.m.catWr == '' then do
m.m.catWr = jOpen(jBuf(), 'w')
call oSetTypePara m.m.catWr, oGetTypePara(m)
end
call jWrite m.m.catWr, line
return
endProcedure catWrite
/*--- write contents of a reader to cat
or keep it for later reading -------------------------------*/
catWriteAll: procedure expose m.
parse arg m
if m.m.catIx >= 0 then
call err 'catWriteAll('m',' arg(2)',' arg(3)') but opened,',
'catIx='m.m.catIx
bx = m.m.RWs.0
if m.m.catWr ^== '' then do
call jClose m.m.catWr
bx=bx+1
m.m.opts.bx = ""
m.m.RWs.bx = m.m.catWr
m.m.catWr = ''
end
do ax=2 by 2 to arg()
bx=bx+1
m.m.opts.bx = catOpt(arg(ax))
m.m.RWs.bx = catMake(arg(ax), arg(ax+1))
call oSetTypePara m, oGetTypePara(m.m.RWs.bx)
end
m.m.RWs.0 = bx
return
endProcedure catWriteAll
/*--- store the list toClose to close them when closing cat ----------*/
catLazyClose: procedure expose m.
parse arg m, toClose
if m.m.catIx <> -7 then
call err 'catLazyClose with catIx' m.m.catIx
if m.m.RWs.0 = 0 then
return 0
if m.m.catToClose ^== '' then
call err 'catLazyClose with catToClose' m.m.catToClose
if m.m.catIx <> -7 | m.m.catToClose ^== '' then
m.m.catToClose = toClose
return 1
endProcedure catLazyClose
catSetTypePara: procedure expose m.
parse arg m, type
do ix=1 to m.m.RWs.0
call oSetTypePara m.m.RWs.ix, type
end
return
endProcedure catSetTypePara
/*--- create a reader/writer for a dsn -------------------------------*/
catDsn: procedure expose m.
parse arg spec
m = oNew('CatDsn')
m.m.readIx = 'c'
ix = mInc('CAT.BUF')
m.m.defDD = 'CAT'ix
m.m.buf = 'CAT.BUF'ix
call catDsnReset m, spec
return m
endProcedure catDsn
catDsnReset: procedure expose m.
parse arg m, sp
if symbol('m.m.defDD') ^== 'VAR' then
m.m.defDD = 'CDD' mInc('CAT.DEFDD')
m.m.spec = sp
return m
endProcedure catDsnReset
catDsnOpen: procedure expose m.
parse arg m, opt
call jClose m
buf = m.m.buf
if opt == 'r' 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 == 'w' then
aa = dsnAlloc(m.m.spec, 'OLD', m.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.m.spec, 'MOD', m.m.defDD)
else
call err 'catDsnOpen('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 catDsnOpen
catDsnClose:
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 catDsnClose
catDsnRead: 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
return 1
endProcedure catDsnRead
catDsnWrite: procedure expose m.
parse arg m, var
buf = m.m.buf
ix = m.buf.0 + 1
m.buf.0 = ix
m.buf.ix = var
if ix > 99 then do
call writeDD m.m.dd, 'M.'buf'.'
m.buf.0 = 0
end
return
endProcedure catDsnWrite
catIni: procedure expose m.
if m.cat.ini == 1 then
return
m.cat.ini = 1
m.cat.buf = 0
call jIni
call oDecMethods oNewClass("Cat", "JRW"),
, "jOpen return catOpen(m, arg)",
, "jReset return catReset(m, '', arg)",
, "jClose call catClose m",
, "jWriteAll call err 'jWriteAll not opened w",
, "oSetTypePara call catSetTypePara m, type",
, "jRead return catRead(m, var)",
, "jWrite call catWrite m, line; return",
, "jWriteAll call catWriteAll m, opt, rdr; return"
call oDecMethods oNewClass("CatDsn", "JRW"),
, "jOpen return catDsnOpen(m, arg)",
, "jReset return catDsnReset(m, arg)",
, "jClose call catDsnClose m",
, "jRead return catDsnRead(m, var)",
, "jWrite call catDsnWrite m, line"
return
endProcedure catIni
/* copy cat 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 jOut 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 jOut 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 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
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.dsn 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.dsn = ''
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.dsn = substr(m.m.work, px+2, 44)
flag = substr(m.m.work, px, 1)
/* say 'eType' eType m.o.dsn '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.dsn
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.dsn,
'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.dsn
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
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)'
al = al "DSORG("sysDSorg") MGMTCLAS("sysMgmtClass")",
"RECFM("sysREcFM") LRECL("SYSLRECL")",
"blksize("sysBLkSIZE")",
"SPACE("sysPrimary"," sysSeconds")" sysUnits
call adrCsm "allocate" al
end
call adrTso 'free dd(copyTo)'
end
c = "'COPY" sysFr"/''"dsnFr"'' TO" ,
sysTo"/''"dsnSetMbr(dsnTo)"'' REPLACE'"
return adrTso("exec 'CSM.DIV.P0.EXEC(CSRXUTIL)'" c , ggRet)
return
endProcedure csmCopy
csmAlloc: procedure expose m.
parse upper arg dd, disp, dsn, rest, nn, retRc
sys = ''
al = ''
parse value csmSysDsn(dsn) with sys '/' dsn
if disp = '' then
disp = 'shr'
al = "SYSTEM("sys") DDNAME("dd")"
if abbrev(disp, 'SYSOUT(') then
al = al disp
else
al = al "DISP("disp")"
if dsn <> '' then do
al = al "DATASET('"dsnSetMbr(dsn)"')"
mbr = dsnGetMbr(dsn)
if mbr <> '' then
al = al 'MEMBER('mbr')'
end
if retRc <> '' | nn = '' then do
alRc = adrCsm('allocate' al rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 to 1
alRc = adrCsm(al rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if nn = '' | wordPos(disp, 'OLD SHR') < 1 then,
leave
say 'csmAlloc rc' alRc 'for' al rest '...trying to create'
call adrCsm 'allocate' left(al, length(al)-4)'CAT)' ,
dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
call err 'cmsAlloc rc' alRc 'for' al rest
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 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 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.
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 arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
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 arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- 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, disp, dd, retRc
ds = ''
m.dsnAlloc.dsn = ds
if left(spec, 1) = '-' then
return strip(substr(spec, 2))
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
disp = w
else if w = 'CATALOG' then
disp = disp w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
ds = strip(substr(w, 5, length(w)-5))
else if ds = '' then
ds = dsn2jcl(w)
else
leave
end
rest = subword(spec, wx)
if abbrev(rest, '.') then
rest = substr(rest, 2)
parse var rest rest ':' nn
if dd <> '' & ds = '' & rest = '' & ^ abbrev(disp, 'SYSO') then
call err "'return" dd"' no longer supported please use -"dd
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 disp = '' then
disp = 'SHR'
else if pos('(', ds) < 1 then
nop
else if disp = 'MOD' then
call err 'disp mod for' ds
else
disp = 'SHR'
m.dsnAlloc.dsn = ds
if pos('/', ds) > 0 then
return csmAlloc(dd, disp, ds, rest, nn, retRc)
else
return tsoAlloc(dd, disp, ds, rest, nn, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg dd, disp, dsn, rest, nn, retRc
c = 'alloc dd('dd')' disp
if dsn <> '' then
c = c "DSN('"dsn"')"
if retRc <> '' | nn = '' then do
alRc = adrTso(c rest, retRc)
if alRc <> 0 then
return alRc
return dd 'call adrTso "free dd('dd')";'
end
do retry=0 by 1
alRc = adrTso(c rest, '*')
if alRc = 0 then
return dd 'call adrTso "free dd('dd')";'
if retry > 0 | nn = '' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for' c rest
say 'tsoAlloc rc' alRc 'for' c rest '...trying to create'
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(dsn, nn)
call adrTso 'free dd('dd')'
end
endProcedure tsoAlloc
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(s005y000) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(s005y000) 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 j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jRead: procedure expose m.
parse arg m, var
if m.m.jReading then
interpret oObjMethod(m, 'jRead')
else
call err 'jRead('m',' var') but not opened r'
endProcedure jRead
jWrite: procedure expose m.
parse arg m, line
if m.m.jWriting then
interpret oObjMethod(m, 'jWrite')
else
call err 'jWrite('m',' line') but not opened w'
return
endProcedure jWrite
jWriteAll: procedure expose m.
parse arg m, opt, rdr
interpret oObjMethod(m, 'jWriteAll')
return
endProcedure jWriteAll
jWriteAllImpl: procedure expose m.
parse arg m, opt, rdr
if pos('-', opt) < 1 then
call jOpen rdr, catOpt(opt)
do while jRead(rdr, line)
call jWrite m, m.line
end
if pos('-', opt) < 1 then
call jClose rdr
return
endProcedure jWriteAll
jReset: procedure expose m.
parse arg m, arg
call jClose m
interpret oObjMethod(m, 'jReset')
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret oObjMethod(m, 'jOpen')
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
if m.m.jReading = 1 | m.m.jWriting = 1 then
interpret oObjMethod(m, 'jClose')
m.m.jReading = 0
m.m.jWriting = 0
return m
endProcedure jClose
/*--- analyze an option in oOpt and oVal -----------------------------*/
jOpt: procedure expose m.
parse arg src, alone, val
m.j.oOpt = ''
if left(src, 1) ^== '-' then do
m.j.oVal = src
return 0
end
sx = 2
if alone ^== '' then do
sx = verify(src, alone, 'n', sx)
if sx = 0 then
sx = length(src)+1
end
if length(src) < sx then
m.j.oVal = ''
else if val == '' then
call err 'bad opt "'src'" should contain only "'alone'"'
else if pos(substr(src, sx, 1), val) < 1 then
call err 'bad opt "'src'" should contain only "'alone'"' ,
'and/or 1 of "'val'" with value'
else do
sx = sx + 1
m.j.oVal = substr(src, sx)
end
m.j.oOpt = substr(src, 2, sx-2)
return 1
endProcedure jOpt
jIni: procedure expose m.
if m.j.ini == 1 then
return
m.j.ini = 1
call oIni
call oDecMethods oNewClass("JRW"),
, "jRead call err 'jRead('m',' var') but not opened r'",
, "jWrite call err 'jWrite('m',' line') but not opened w'",
, "jWriteAll call jWriteAllImpl m, opt, rdr",
, "jRead drop m.arg; return 0",
, "jWrite say 'jOut:' line",
, "jReset ;",
, "jOpen ;",
, "jClose ;"
x = oNew("JRW")
m.j.jIn = x
m.x.jReading = 1
m.x.jWriting = 0
x = oNew("JRW")
m.j.jOut = x
m.x.jReading = 0
m.x.jWriting = 1
call oDecMethods oNewClass("Jbuf", "JRW"),
, "jOpen return jBufOpen(m, arg)",
, "jReset return jBufReset(m, arg)",
, "oSetTypePara call jBufSetTypePara m, type",
, "jRead return jBufRead(m, var)",
, "jWrite call jBufWrite m, line"
return
endProcedure jInit
jIn: procedure expose m.
parse arg arg
return jRead(m.j.jIn, arg)
endProcedur jIn
jOut: procedure expose m.
parse arg arg
call jWrite m.j.jOut, arg
return
endProcedure jOut
/*--- jBuf: buffer read or write (supports datataypes) ---------------*/
jBuf: procedure expose m.
m = oNew('Jbuf')
call jBufReset m
do ax=1 to arg()
m.m.buf.ax = arg(ax)
end
m.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
m.m.stem = m'.BUF'
m.m.buf.0 = 0
call oSetTypePara m
do ax=1 to arg() - 1
m.m.buf.ax = arg(ax+1)
m.m.buf.0 = ax
end
return m
endProcedure jBufReset
jBufSetTypePara: procedure expose m.
parse arg m, type
if m.m.buf.0 <> 0 then
call err 'jBufSetTypePara but not empty'
return
endProcedure jBufSetTypePara
jBufOpen: procedure expose m.
parse arg m, opt
call jClose m
if opt == 'r' then do
m.m.readIx = 0
m.m.jReading = 1
return m
end
if opt == 'w' then
m.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
m.m.jWriting = 1
return m
endProcedure jBufOpen
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
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.var = m.m.buf.nx
else
call oTyCopy ty, var, m'.BUF.'nx
return 1
endProcedure jBufRead
jBufWrite: procedure expose m.
parse arg m, line
nx = mInc(m'.BUF.0')
ty = oGetTypePara(m)
if abbrev(ty, '=') then
m.m.buf.nx = line
else
call oTyCopy ty, m'.BUF.'nx, line
return 1
endProcedure jBufRead
/* copy j end *********************************************************/
/* copy oFld begin *****************************************************
defines classes with field names
is the base for the oo layer in copy o
***********************************************************************/
/*--- initialize the module ------------------------------------------*/
oFldIni: procedure expose m.
if m.oFld.ini = 1 then
return
m.oFld.ini = 1
call mapIni
m.o.fldOnly = mapNew() /* map fields -> class */
m.o.cla.0 = 0 /* the stem for classes */
call oFldNew 'Class', '=', , , /* MetaClass definieren */
'INST = MET .<>= FLD .<>=Class STEM =Class'
return
endProcedure oFldIni
/*--- create a new class
name: name of new class, a star will be replaced by a number
va: type of value
st: type of stem
flds: pairs of field names and types
dup: duplicate resolver -----------------------------------*/
oFldNew: procedure expose m.
parse arg name, va, st, flds, dup
if pos('*', name) > 0 then
name = oPut('O.CLA', name, , '*')
else
call oPut 'O.CLA', name, , 'n'
m.o.cla.name.inst = 0
m.o.cla.name.val = va
m.o.cla.name.stem = st
m.o.cla.name.FLD.0 = 0
m.o.cla.name.MET.0 = 0
return oFldAdd(name, flds, dup)
endProcedure oFldNew
/*--- create or find a class with only simple fields fs --------------*/
oFldOnly: procedure expose m.
parse arg fs, dup
kk = space(fs '?'dup, 1)
if mapHasKey(m.o.fldOnly, kk) then
return mapGet(m.o.fldOnly, kk)
if dup ^== 'e' then do
ll = space(fs, 1)
end
else do
ll = ''
do wx=1 to words(fs)
w = word(fs, wx)
v = w
do x=2 while wordPos(v, ff) > 0
v = w || x
end
ll = space(ll v, 1)
end
end
if mapHasKey(m.o.fldOnly, ll) then do
nn = mapGet(m.o.fldOnly, ll)
end
else do
nn = oFldNew('FldType*')
st = 'O.CLA.'nn'.FLD'
do lx=1 to words(ll)
call oPut st, word(ll, lx), '=', dup
end
call mapPut m.o.fldOnly, ll, nn
end
call mapPut m.o.fldOnly, kk, nn
return nn
endProcedure oFldOnly
/*--- return the stem of flds of class type --------------------------*/
oFlds: procedure expose m.
parse arg type
return 'O.CLA.'type'.FLD'
/*--- return the concatenation of the fields of type ty in stem st
formated by fmt -------------------------------------------*/
oFldCat: procedure expose m.
parse arg ty, st, fmt
flds = oFlds(ty)
res = ''
do ix=1 to m.flds.0
f = m.flds.ix
if fmt == '' then
res = res m.st.f
else
res = res fmt(m.st.f, m.fmt.ix)
end
return substr(res, 2)
endProcedure oFldCat
/*--- add fields to class cl given as name type pairs in fs ----------*/
oFldAdd: procedure expose m.
parse arg cla, fs, dup
st = 'O.CLA.'cla'.FLD'
do ix=1 by 2 to words(fs)
call oPut st, word(fs, ix), word(fs, ix+1), dup
end
return cla
endProcedure oFldAdd
/*--- add/put key k with value v to stem st
duplicate handling dup:
* replace * in k by a number until it is new
e add a number in it is not new
o replace old value at existing key
= add a new key, fail if key exists and value is different
------------------------------------------------------------*/
oPut: procedure expose m.
parse arg st, k, v, dup
if dup = '*' then do
cx = pos('*', k)
if cx < 1 then
call err 'no * in key' k
k = oPutDupResolve(st, left(k, cx-1), 1)
end
else if symbol('m.st.k') = 'VAR' then do
if dup = '' | dup = 'o' then do
m.st.k = v
return k
end
if dup = '=' then do
if v <> m.st.k | ^ (v = '' & datatype(m.st.k, 'n')) then
call err 'not =: m.'st'.'k '=>' m.st.k '<>' v
return k
end
if dup = 'e' then
k = oPutDupResolve(st, k, 2)
else
call err 'key' k 'exists in' st 'but dup' dup
end
else if dup = 'o' then
call err 'old key' k 'does not exist in' st
if datatype(k, 'n') | words(k) <> 1 | pos('.', k) > 0 then
call err 'illegal name' k
x = m.st.0 + 1
m.st.0 = x
m.st.x = k
if v == '' then
m.st.k = x
else
m.st.k = v
return k
endProcedure oPut
oPutDupResolve: procedure expose m.
parse arg st, k, b
do ix=b
a = k || ix
if symbol('m.st.a') <> 'VAR' then
return a
end
endProcedure oPutDupResolve
/*--- parameterized types --------------------------------------------*/
oGetTypePara: procedure expose m.
parse arg m
if symbol('m.o.tyPa.m') == 'VAR' then
return m.o.tyPa.m
else
return '='
endProcedure oGetTypePara
oSetTypePara: procedure expose m.
parse arg m, type, noCall
if type = '' then
type = '='
if oGetTypePara(m) == type then
return
if noCall ^== 'noCall' then
interpret oObjMethod(m, 'oSetTypePara')
m.o.tyPa.m = type
return
endProcedure oSetTypePara
/* copy oFld end ***************************************************/
/* copy o begin ********************************************************
object layer has three freatures
* an object may have a class which has methods
* an object may have a parmeterized type
* a class may contain field descriptions
***********************************************************************/
oClaMethod: procedure expose m.
parse arg cl, me
if symbol('m.o.cla.cl.met.me') = 'VAR' then
return m.o.cla.cl.met.me
else
call err 'no method' me 'in class' cl
endProcedure oClaMethod
oHasMethod: procedure expose m.
parse arg obj, me
cla = oGetClass(obj)
return symbol('m.o.cla.cl.met.me') = 'VAR'
endProcedure oHasMethod
oGetClass: procedure expose m.
parse arg Obj
if symbol('m.o.obj2cla.Obj') = 'VAR' then
return m.o.obj2cla.Obj
call err 'no class found for object' obj
endProcedure oGetClass
oObjMethod: procedure expose m.
parse arg obj, me
if symbol('m.o.obj2cla.obj') = 'VAR' then
return oClaMethod(m.o.obj2cla.obj, me)
if abbrev(obj, 'oCast:') then do
cx = pos(':', obj, 7)
return 'M="'substr(obj, cx+1)'";' ,
oClaMethod(substr(obj, 7,cx-7), me)
end
call err 'no class found for object' obj
endProcedure oObjMethod
oCast: procedure
parse arg obj, cl
if abbrev(obj, 'oCast:') then
obj = substr(obj, 1 + pos(':', obj, 7))
return 'oCast:'cl':'obj
endProcedure oCast
oNewClass: procedure expose m.
parse arg name, super
/* call oIni */
name = oFldNew(name)
neMe = 'O.CLA.'name'.MET'
neFi = 'O.CLA.'name'.FLD'
do sx=1 to words(super)
sup = word(super, sx)
if symbol('m.o.cla.sup') ^== 'VAR' then
call err 'superclass' sup 'is not defined'
if m.o.cla.sup.val ^== '' then
m.o.cla.name.val = m.o.cla.sup.val
if m.o.cla.sup.stem ^== '' then
m.o.cla.name.stem = m.o.cla.sup.stem
st = 'O.CLA.'sup'.MET'
do x=1 to m.st.0
olMe = m.st.x
call oPut neMe, olMe, m.st.olMe
end
st = 'O.CLA.'sup'.FLD'
do x=1 to m.st.0
olFi = m.st.x
call oPut neFi, olFi, m.st.olFi
end
end
call oMutate 'O.CLA.'name, 'Class'
return name
endProcedure oNewClass
oValStemFldsWKOLD: procedure expose m.
parse arg cl, m.o.cla.cl.val, m.o.cla.cl.stem, flds
st = 'O.CLA.'cl'.FLD'
do wx=1 by 2 to words(flds)
call oPut st, word(flds, wx), word(flds, wx+1)
end
return cl
endProcedure oValStemFlds
oNewTypeWKOLD: procedure expose m.
parse arg cl, va, st, flds
return oValStemFlds(oNewClass(cl), va, st, flds)
/*--- a field type has only fields of type '='
finds or creates a field Type with the fields of types tps
and the field list aFl.
if dup = 'e' duplicate field names are resolved ------------*/
oFiTypeWKOLD: procedure expose m.
parse arg tps, aFl, dup
if symbol('m.o.cla.fiType.tps.aFl.dup') = 'VAR' then
return m.o.cla.fiType.tps.aFl.dup
fs = ''
do wx=1 to words(tps)
t1 = oFlds(word(tps, wx))
do fx=1 to m.t1.0
fs = fs m.t1.fx
end
end
fs = fs aFl
fd = ''
do wx=1 to words(fs)
f1 = word(fs, wx)
if wordPos(f1, fd) < 1 then do
fd = fd f1
end
else if dup == 'e' then do
do dx=2 by 1 while wordPos(f1 || dx, fn fs) > 0
end
fd = fd f1 || dx
end
end
fd = space(fd aFl)
if symbol('m.o.cla.fiType.fd') = 'VAR' then do
res = m.o.cla.fiType.fd
end
else do
res = oNewClass("FiType*")
m.o.cla.fiType.fd = res
st = 'O.CLA.'res'.FLD'
do wx=1 to words(fd)
call oPut st, word(fd, wx), '='
end
end
m.o.cla.fiType.tps.aFl = res
return res
endProcedure oFiType
oDecMethods: procedure expose m.
parse arg cla
st = 'O.CLA.'cla'.MET'
do ax=2 to arg()
call oPut st, word(arg(ax), 1), subWord(arg(ax), 2)
end
return
endProcedure oDecMethods
oNew: procedure expose m.
parse arg cla
st = 'O.CLA.'cla
if symbol('M.st') ^== 'VAR' then
call err 'class' cla 'is not initialized'
nn = m.st.inst + 1
m.st.inst = nn
nn = 'O.C' || m.st || 'I' || nn
if symbol('m.o.obj2cla.nn') == 'VAR' then
call err 'oNew already defined:' nn
m.o.obj2cla.nn = cla
return nn
endProcedure oNew
oMutate: procedure expose m.
parse arg obj, class
if obj == 'O.C13I12' then do
end
if symbol('M.O.CLA.class') ^== 'VAR' then
call err 'class' class 'is not initialized'
m.o.obj2cla.obj = class
return obj
endProcedure oMutate
oSay: procedure expose m.
parse arg type, a, aPr, mPr
ty = 'O.CLA.'type
msg = mPr || substr(a, length(aPr)+1)
redir = 0
do forever
if type == '=' then do
say msg '=' m.a
return
end
else if abbrev(type, '=') then do
a = m.a
msg = msg '==>' a
redir = 1
type = substr(type, 2)
end
else if left(type, 2) = '<>' then do
k = m.a
a = left(a, lastPos('.', a))k
msg = msg '=<>' k
redir = 1
type = substr(type, 3)
end
else if left(type, 1) = '.' then do
if ^ datatype(m.a.0, 'n') then
call err 'type' type 'not stem but m.'a'.0 is' m.a.0
type = substr(type, 2)
if redir then do
say msg 'stem 1..'m.a.0':' type
end
else do
do y=1 to m.a.0
call oSay type, a'.'y, a'.', mPr' '
end
end
return
end
else if redir then do
say msg':' type
return
end
else do
leave
end
end
if m.ty.val = '=' then
say msg '=' m.a
else
say msg '=' m.a':' m.ty.val
/* call oSay m.ty.val, a,==>' m.a '(to' m.ty.val')' */
do y=1 to m.ty.fld.0
f = m.ty.fld.y
call oSay m.ty.fld.f , a'.'f, a'.', mPr' '
end
if m.ty.stem ^== '' then
call oSay '.'m.ty.stem, a, a, mPr
return
endProcedure oSay
oClear: procedure expose m.
parse arg type, a, val
if abbrev(type, '.') then do
m.a.0 = 0
end
else if abbrev(type, '<>') then do
m.a = val
call oClear substr(type, 3), left(a, lastPos('.', a))val, val
end
else if abbrev(type, '=') then do
m.a = ''
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.a = val
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oClear m.ty.fld.k, a'.'k, val
end
if m.ty.stem ^== '' then
call m.a.0 = 0
end
return a
endProcedure oClear
oCopy: procedure expose m.
parse arg t, f
if symbol('m.o.obj2cla.f') ^== 'VAR' then
call err f 'has no class'
cl = m.o.obj2cla.f
m.o.obj2cla.t = m.o.obj2cla.f
return oTyCopy(cl, t, f)
endProcedure oCopy
oTyCopy: procedure expose m.
parse arg type, t, f
if abbrev(type, '.') then do
do y=1 to m.f.0
call oTyCopy substr(type, 2), t'.'y, f'.'y
end
m.t.0 = m.f.0
end
else if abbrev(type, '<>') then do
k = m.f
m.t = k
call oTyCopy substr(type, 3), left(t, lastPos('.', t))k,
, left(f, lastPos('.', f))k
end
else if abbrev(type, '=') then do
m.t = m.f
end
else do
ty = 'O.CLA.'type
if m.ty.val ^== '' then
m.t = m.f
do x = 1 to m.ty.fld.0
k = m.ty.fld.x
call oTyCopy m.ty.fld.k, t'.'k, f'.'k
end
if m.ty.stem ^== '' then
call oTyCopy '.'m.ty.stem, t, f
end
return t
endProcedure oTyCopy
/*--- Run ------------------------------------------------------------*/
oRunner: procedure expose m.
parse arg code
return oRunnerReset(oNew('ORunner'), code)
oRunnerReset: procedure expose m.
parse arg m, pCode
m.m.code = pCode
return m
endProcedure oRunnerReset
oRun: procedure expose m.
parse arg m
interpret m.m.code
return
endProcedure oRun
oIni: procedure expose m.
if m.o.ini = 1 then
return
m.o.ini = 1
call oFldIni
call mapIni
m.o.paTy.0 = 0
call oFldNew '=', '='
call oDecMethods oNewClass('ORunner'), 'oRun call oRun m'
return
endProcedure oIni
/* copy o 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.tok = ''
m.m.val = ''
m.m.key = ''
m.m.read = ''
return scanOpts(m, n1, np, co)
endProcedure scanReset
scanOpts: procedure expose m.
parse arg m, m.m.scanName1, namePlus, m.m.scanComment
call scanIni
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 scanReset
/*--- begin scanning a single line -----------------------------------*/
scanSrc: procedure expose m.
parse arg m, m.m.src
m.m.atEnd = 1
m.m.pos = 1
return m
endProcedure scanSrc
/*--- 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
if vOpt == '' then /* empty string does not take default| */
nx = verify(m.m.src, alpha, , m.m.pos)
else
nx = verify(m.m.src, alpha, vOpt, m.m.pos)
if nx = 0 then
nx = length(m.m.src) + 1
m.m.tok = substr(m.m.src, m.m.pos, nx - m.m.pos)
m.m.pos = nx
return m.m.tok ^== ''
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
scanNat: procedure expose m.
parse arg m, chEn
if ^ scanVerify(m, '0123456789') then
return 0
if chEn^==0 & pos(substr(m.m.src, m.m.pos,1), m.m.scanNameR)>0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
scanInt: procedure expose m.
parse arg m, chEn
if scanNat(m, chEn) then
return 1
ox = m.scan.m.pos
if pos(substr(m.scan.m.src, ox, 1) , '+-') < 1 then
return 0
m.scan.m.pos = ox + 1
if | scanNat(m) then do
m.scan.m.pos = ox
return 0
end
m.tok =substr(m.scan.m.src, ox, 1)|| m.tok
return 1
endProcedure scanInt
/*--- 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
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
call scanErr(m, 'word expected after' m.m.key '=')
return 1
endProcedure scanKeyValue
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.read ^== '' then
interpret 'res = ' oObjMethod(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.read ^== '' then
interpret 'return' oObjMethod(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.read == '' then
return msg'\npos' m.m.Pos 'in string' strip(m.m.src, 't')
else
interpret 'return msg"\n" ||' oObjMethod(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 then
call scanIni
call jIni
call oDecMethods oNewClass('ScanRead'),
, 'scanReadNl return scanReadNlImpl(m, unCond)',
, 'scanSpaceNl scanReadSpaceNl(m)',
, 'scanClose call scanReadClose 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 scanReadReset(oNew('ScanRead'), rdr , n1, np, co)
scanReadReset: procedure expose m.
parse arg m, rdr, n1, np, co
call scanReset m, n1, np, co
m.m.atEnd = 0
m.m.lineX = 0
m.m.read = rdr
call jOpen rdr, 'r'
call scanReadNl m, 1
return m
endProcedure scanRead
scanClose: procedure expose m.
parse arg m
interpret oObjMethod(m, 'scanClose')
return
scanReadClose: procedure expose m.
parse arg m
call jClose m.m.read
return
scanReadNl: procedure expose m.
parse arg m, unCond
interpret oObjMethod(m, 'scanReadNl')
endProcedure scanReadNl
/*--- return true/false whether we are at the end of line / reader ---*/
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.read, 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 oDecMethods oNewClass('ScanWin'),
, 'scanReadNl return scanWinNl(m, unCond)',
, 'scanSpaceNl scanWinSpaceNl(m)',
, 'scanClose call scanWinClose 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 scanWinReset(oNew('ScanWin'), rdr, wiSz, wiBa, cuPo, cuLe)
/*--- set the attributes of window scanner m, open rdr and start read*/
scanWinReset: procedure expose m.
parse arg m, rdr, wiSz, wiGa, cuPo, cuLe
call scanReset m
m.m.read = rdr
m.m.atEnd = 'still closed'
return scanWinOpts(m, wiSz, wiGa, cuPo, cuLe)
endProcedure scanWinReset
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 scanWinOpen(m)
endProcedure scanWinReset
scanWinOpen: procedure expose m.
parse arg m, lx
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.read, 'r'
call scanWinRead m
return m
endProcedure scanWinOpen
scanWinClose: procedure expose m.
m.m.atEnd = 'still closed'
call jClose m.m.read
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.read, 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 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, rdr, scanWin
if scanWin ^== 0 then
call scanWinReset m, rdr, 5, 2, 1, 72
else
m.m.read = rdr
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.read, fx
call scanWinOpen es, fx
do while word(scanPos(m), 1) <= fx & scanSqlType(m)
if m.m.sqlType = 'i' & m.m.val == cmd then
return fx
end
end
return -1
endProcedure scanSqlSeekId
/*--- scan a sql token put type in m.sqltype:
'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
's': string e.g. 'abc''ef'
'' : at end
: any other character e.g. ;
----------------------------------------------------------------*/
scanSqlType: procedure expose m.
parse arg m, retSpace
m.m.val = ''
if scanSpaceNl(m) & retSpace = 1 then do
m.m.sqlType = 'b'
return 1
end
c2 = scanLook(m ,2)
if scanString(m, "' x' X'") then do
m.m.sqlType = '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.sqlType = 'q'
else if abbrev(m.m.tok, '"') then
m.m.sqlType = 'd'
else
m.m.sqlType = 'i'
end
else if scanSqlNum(m, 0, 1) then
m.m.sqlType = 'n'
else if scanChar(m, 1) then
m.m.sqlType = m.m.tok
else if scanAtEnd(m) then do
m.m.sqlType = ''
return 0
end
else
call scanErr m, 'cannot scan sql'
return 1
endProcedure scanSqlType
scanSqlSkipBrackets: procedure expose m.
parse arg m, br
if br ^== '' then
nop
else if scanLit(m, '(') then
br = 1
else
return 0
do while scanSqlType(m) & m.m.sqlType ^== ';'
if m.m.sqlType = '(' then br = br + 1
else if m.m.sqlType ^== ')' 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
n = ''
if scanLit(m, '+', '-') then do
n = m.m.tok
if noSp <> 1 then
call scanSpaceNl m
end
if scanLit(m, '.') then
n = n'.'
if scanVerify(m, '0123456789') then
n = n || m.m.tok
else if n == '' then
return 0
else if noSp = 1 then do
call scanBack m, n
return 0
end
else
call scanErr m, 'scanSqlNum bad number: no digits after' n
if pos('.', n) < 1 then
if scanLit(m, '.') then do
if scanVerify(m, '0123456789') then
n = n'.'m.m.tok
end
if scanLit(m, 'E', 'e') then do
n = n'E'
if scanLit(m, '+', '-') then
n = n || m.m.tok
if ^ scanVerify(m, '0123456789') then
call scanErr m, 'scanSqlNum bad number: no digits after' n
n = n || m.m.tok
end
if checkEnd ^= 0 then
if pos(scanLook(m, 1), m.m.scanNameR) > 0 then
call scanErr m, 'scanSqlNum number' n 'bad end' ,
scanLook(m, 1)
m.m.val = n
return 1
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 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
***********************************************************************/
/*--- create a new map ----------------------------------------------*/
mapNew: procedure expose m.
parse arg opt
return mapReset('MAP.'mInc('MAP.0') , opt)
endProcedure mapNew
/*--- make an empty map, opt=K means maintain a stem of keys ---------*/
mapReset: procedure expose m.
parse arg a, opt
if symbol('m.map.keys.a') == 'VAR' then
call mapClear a
upper opt
if opt = '=' then
st = a
else if opt = 'K' then
st = 'MAP.KEYS.'a
else
st = opt
m.map.keys.a = st
if st ^== '' then
m.st.0 = 0
if abbrev(a, 'MAP.') then
m.map.loKy.a.0 = 0
return a
endProcedure
/*--- remove all entries ---------------------------------------------*/
mapClear: procedure expose m.
parse arg a
st = mapKeys(a)
do kx=1 to m.st.0
k = m.st.kx
if length(k) > 200 then do
k = left(k, 201)
if symbol('m.a.k') == 'VAR' then/* ist noch hier */
call mapClear m.a.k
end
drop m.a.k m.st.kx
end
m.st.0 = 0
return a
endProcedure mapClear
/*--- return a stem of all keys (including removed ones) -------------*/
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
/*--- 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 the value pointer for a key, '' if non existang ---------*/
mapValAdr: procedure expose m.
parse arg pA, pKy, fun
a = pA
ky = pKy
do forever
if length(ky) <= 200 then do
if symbol('m.a.ky') ^== 'VAR' then
leave
if fun == 'a' then
call err 'duplicate key' pKy 'in map' pA
return a'.'ky
end
k1 = left(ky, 201)
if symbol('m.a.k1') ^== 'VAR' then
leave
a = m.a.k1
ky = substr(ky, 202)
end
if fun == '' then
return ''
opt = left('K', m.map.keys.pA ^== '')
if opt == 'K' then
call mAdd m.map.Keys.pA, pKy
do while length(ky) > 200
k1 = left(ky, 201)
n = mapNew(opt)
m.a.k1 = n
if a ^== pA & opt == 'K' then
call mAdd m.map.keys.a, ky
a = n
ky = substr(ky, 202)
end
return a'.'ky
endProcedure mapValAdr
/*--- 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 ^ abbrev(vv, aa) | m.map,keys ^== '' then
call err 'not implemented mapRemove('a',' ky')'
val = m.a.vv
drop m.a.ky
return val
endProcedure mapRemove
/*--- 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 arg() > 2 then
return arg(2)
else
call err 'missing key in mapGet('a',' ky')'
endProcedure mapGet
/*--- initialize the module ------------------------------------------*/
mapIni: procedure expose m.
if m.map.ini = 1 then
return
m.map.ini = 1
call mIni
m.map.0 = 0
return
endProcedure mapIni
/* copy map end *******************************************************/
/* copy mapExp begin **************************************************/
mapVia: procedure expose m.
parse arg a, ky
sx = pos('*', ky)
if sx < 1 then
return mapGet(a, ky)
via = mapGet(a, left(ky, sx-1))
do while sx <= length(ky)
fx = sx+1
sx = pos('*', ky, fx)
if sx < 1 then
sx = length(ky) + 1
if sx = fx then do
if symbol('m.via') ^== 'VAR' then
call err 'missing m.'via 'at' sx 'in mapVia('a',' ky')'
via = m.via
end
else do
f = substr(ky, fx, sx - fx)
if symbol('m.via.f') ^== 'VAR' then
call err 'missing m.'via'.'f ,
'at' sx 'in mapVia('a',' ky')'
via = m.via.f
end
end
return via
endProcedure mapVia
mapExpAt: procedure expose m.
parse arg a, src, sx
m.map.ExpAt = 0
cx = pos('$', src, sx)
if cx < 1 then
return substr(src, sx)
res = substr(src, sx, cx-sx)
do forever
if substr(src, cx+1, 1) = '{' then do
ex = pos('}', src, cx+2)
if ex < 1 then
call err 'missing } after' substr(src, cx) 'in' src
res = res || mapVia(a, strip(substr(src, cx+2, ex-cx-2)))
ex = ex + 1
end
else do
ex = verify(src, m.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 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
/*--- 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 mAddAt
/*--- 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
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 err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
parse arg oo, ha
if pos('I', translate(oo)) > 0 then
call adrIsp 'control errors return'
m.err.opt = translate(oo, 'h', 'H')
if ha == '' then
drop m.err.handler
else
m.err.handler = ha
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
drop err handler opt
if ggOpt == '' & symbol('m.err.handler') == 'VAR' then
interpret m.err.handler
call errSay ggTxt
parse source . . ggS3 . /* current rexx */
if ggOpt == '' | ggOpt == '*' then
ggOpt = translate(value('m.err.opt'), 'ht', 'HT')
if pos('h', ggOpt) > 0 then do
say 'fatal error in' ggS3': divide by zero to show stackHistory'
x = 1 / 0
end
say 'fatal error in' ggS3': exit(12)'
exit errSetRc(12)
endSubroutine err
/*--- 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
/*--- say an errorMessage msg with pref pref
split message in lines at '/n'
say addition message in stem st ---------------------------*/
errSay: procedure expose m.
parse arg msg, st, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' | (pref == '' & st == '') then
msg = 'fatal error:' msg
else if pref == 'w' then
msgf = 'warning:' msg
else if pref == 0 then
nop
else if right(pref, 1) ^== ' ' then
msg = pref':' msg
else
msg = pref || msg
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
if st == '' then do
say substr(msg, bx+2, ex-bx-2)
end
else do
sx = sx+1
m.st.sx = substr(msg, bx+2, ex-bx-2)
m.st.0 = sx
end
bx = ex
end
return
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
say 'fatal error:' msg
call help
call err msg, op
endProcedure errHelp
/*--- 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 sysVar('sysISPF') = 'ACTIVE' then do
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.trace is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
say 'trc:' msg
return
endProcedure trc
/*--- 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
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
say 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure expose m.
parse source . . s3 .
say right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
say '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
say li
end
say right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/* copy err end *****************************************************/