zOs/REXX.O08/JTESTER
m.jTest.act = ''
call jTestCat
call jTestEnv
call jTestBar
call jTestEnv
call jTestBar
call jTestCat
call jTestJ
call jTestJTest
call jTestDsn
call jTestJ 0
call jTestJTest
call jTestScan
call jTestScanWin
call jTestDsn
call jTestTotal
call jTestJ 0
call jTestJTest
call jTestScan
call jTestScanWin
call jTestTotal
exit
jTestJ: procedure expose m.
parse arg fail
say 'jTestJ test J and implicitely M without jTest with fail' fail
call envInit
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'
b = jOpen(jBuf(), 'w')
call jWrite b, 'buf line one'
call mAdd jBufStem(b), '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 jClose b
c = jBuf()
call envPush env('<£', b, '>£', c)
call jOut 'before readWrite 1 b --> c'
call utReadWrite
call jOut 'nach readWrite 1 b --> c'
call envPop
if fail = 1 then
call jWrite c, 'write nach pop'
call mAdd jBufStem(c), 'add nach pop'
call envPush env('<£', c)
call jOut 'before readWrite 2 c --> std'
call utReadWrite
call jOut 'nach readWrite 2 c --> std'
call envPop
if fail = 2 then
call jClose m.j.jOut
return
endProcedure jTestJ
jTestJTest: procedure expose m.
call jInit
jt = jNew()
c = jBuf()
call jTest jt, 'jTestJ',
, "jOut: out eins",
, "jIn 1: jTest in line 1 eins ,",
, "jOut: 1 jIn() jTest in line 1 eins ,",
, "jIn 2: jTest in line 2 zwei ; ",
, "jOut: 2 jIn() jTest in line 2 zwei ; ",
, "jIn 3: jTest in line 3 drei |",
, "jOut: 3 jIn() jTest in line 3 drei |",
, "jIn eof 4",
, "jOut: jIn() 3 reads",
, "jOut: line buf line one",
, "jOut: line buf line two",
, "jOut: line buf line three",
, "jOut: line buf line four",
, "jErr: write("c") when closed"
stdOut = m.env.env.1
stdOut = m.env.stdOut.out
call jTestAdd jT, ,
, "jOut: before readWrite 2 c --> std",
, "jOut: before readWrite 1 b --> c",
, "jOut: buf line one",
, "jOut: buf line two",
, "jOut: buf line three",
, "jOut: buf line four",
, "jOut: nach readWrite 1 b --> c",
, "jOut: add nach pop",
, "jOut: nach readWrite 2 c --> std",
, "jErr: do not jCLOSE("stdOut", ) base stdIn/stdOut"
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'
b = jOpen(jBuf(), 'w')
call jWrite b, 'buf line one'
call mAdd jBufStem(b), '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 jClose b
call envPush env('<£', b, '>£', c)
call jOut 'before readWrite 1 b --> c'
call utReadWrite
call jOut 'nach readWrite 1 b --> c'
call envPop
say 'jWrite' c
call jWrite c, 'write nach pop'
call mAdd jBufStem(c), 'add nach pop'
call envPush env('<£', c)
call jOut 'before readWrite 2 c --> std'
call utReadWrite
call jOut 'nach readWrite 2 c --> std'
call envPop
call jClose stdOut
call jTestEnd jt
return
endProcedure jTestJTest
jTestScan: procedure expose m.
call jInit
t = jNew()
call jTest t, 'jTestScan.1',
, "jOut: scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo'",
|| "'s' ",
, "jOut: scan name tok a034 key val ",
, "jOut: scan char tok , key val ",
, "jOut: scan name tok Und key val ",
, "jOut: scan space 1 tok key val ",
, "jOut: scan name tok hr123sdfER key val ",
, "jOut: scan string quo tok ""st1"" key val st1",
, "jOut: scan space 1 tok key val ",
, "jOut: scan string apo tok 'str2''mit''apo''s' key val str",
|| "2'mit'apo's",
, "jOut: scan space 4 tok key val "
call jSc1 ,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call jTestEnd t
call jTest t, 'jTestScan.2',
, "jOut: scan src litEinsefr 23 sdfER'str1'litZwei ""str2""""",
|| "mit quo""s ",
, "jOut: scan literal tok litEins key val ",
, "jOut: scan name tok efr key val ",
, "jOut: scan space 1 tok key val ",
, "jOut: scan number tok 23 key val ",
, "jOut: scan space 1 tok key val ",
, "jOut: scan name tok sdfER key val ",
, "jOut: scan string apo tok 'str1' key val str1",
, "jOut: scan literal tok litZwei key val str1",
, "jOut: scan space 1 tok key val ",
, "jOut: scan string quo tok ""str2""""mit quo"" key val str",
|| "2""mit quo",
, "jOut: scan name tok s key val str2""mit quo",
, "jOut: scan space 1 tok key val "
call jSc1 ,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call jTestEnd t
call jTest t, 'jTestScan.3',
, "jOut: scan src aha;+-=f ab=cdEf eF='strIng' ",
, "jOut: scan keyValue tok no= key aha val def",
, "jOut: scan char tok ; key aha val ",
, "jOut: scan char tok + key aha val ",
, "jOut: scan char tok - key aha val ",
, "jOut: scan char tok = key aha val ",
, "jOut: scan keyValue tok no= key f val def",
, "jOut: scan keyValue tok cdEf key ab val cdEf",
, "jOut: scan keyValue tok 'strIng' key eF val strIng"
call jSc1 'kv def'," aha;+-=f ab=cdEf eF='strIng' "
call jTestEnd t
call jTest t, 'jTestScanReader',
, "jOut: name erste",
, "jOut: space",
, "jOut: name Zeile",
, "jOut: space",
, "jOut: nextLine",
, "jOut: nextLine",
, "jOut: space",
, "jOut: name dritte",
, "jOut: space",
, "jOut: name Zeile",
, "jOut: space",
, "jOut: name schluss",
, "jOut: space"
b = jBuf('erste Zeile ',,' dritte Zeile schluss ')
call jOpen b, 'r'
call scanReader s, b
do while ^scanAtEnd(s)
if scanName(s) then call jOut 'name' m.tok
else if scanVerify(s, ' ') then call jOut 'space'
else if scanNL(s) then call jOut 'nextLine'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
end
call jTestEnd t
call jTest t, 'jTestScanReader mit spaceLn',
, "jOut: name erste",
, "jOut: spaceLn",
, "jOut: name Zeile",
, "jOut: spaceLn",
, "jOut: name dritte",
, "jOut: spaceLn",
, "jOut: name Zeile",
, "jOut: spaceLn",
, "jOut: name schluss",
, "jOut: spaceLn"
call jOpen b, 'r'
call scanReader s, b
do forever
if scanName(s) then call jOut 'name' m.tok
else if scanSpaceNL(s) then call jOut 'spaceLn'
else if ^scanAtEnd(s) then call scanErr s, 'cannot scan'
else leave
end
call jTestEnd t
return
endProcedure jTestScan
/*--- one single test scan with lines to scan in stem ln -------------*/
jSc1:
parse arg fun def, ln
call jOut 'scan src' ln
call scanLine s, ln
do while ^scanAtEnd(s)
o = ''
if fun == 'kv' then do
if scanKeyValue(scanSkip(s), def) then o = 'keyValue '
else if scanAtEnd(s) then leave
end
else do
if scanLit(s, 'litEins') then o = 'literal '
else if scanLit(s, 'litZwei') then o = 'literal '
else if scanName(s) then o = 'name '
end
if o ^== '' then nop
else if scanString(s) then o = 'string apo'
else if scanString(s, '"') then o = 'string quo'
else if scanNat(s) then o = 'number '
else if scanVerify(s, ' ') then o = 'space' length(m.tok)
else if scanChar(s,1) then o = 'char '
else call scanErr s, 'not scanned'
call jOut 'scan' o 'tok' m.tok 'key' m.key ,
'val' m.val
end
return
endProcedure jSc1
jTestScanWin: procedure expose m.
call jInit
t = jNew()
call mAdd t'.'comp, 'eins', 'zwei', 'dreiVierFuenfSechsn',
, 'sieben', 'acht'
call jTest t, 'jTestScanWin',
, "jOut: scanWindwow cut 1 lines 41",
, "jOut: scanWindwow cut 2 lines 22",
, "jOut: scanWindwow cut 3 lines 15",
, "jOut: scanWindwow cut 4 lines 12",
, "jOut: scanWindwow cut 5 lines 10",
, "jOut: scanWindwow cut 6 lines 8",
, "jOut: scanWindwow cut 7 lines 8",
, "jOut: scanWindwow cut 8 lines 7",
, "jOut: scanWindwow cut 9 lines 7",
, "jOut: scanWindwow cut 10 lines 6",
, "jOut: scanWindwow cut 11 lines 5",
, "jOut: scanWindwow cut 12 lines 5"
do cc=1 to 12
call jScWi t, cc, "eins zwei dreiVierFuenfSechsn",
, ,"sieben acht"
end
call jTestEnd t
call jTest t, 'jTestScanWinCom' ,
, "jOut: scanWindwow cut 15 lines 5"
call jScWi t, 15,"eins %% 012345zwei dreiVierFuenfSechsn%%234",
"sieben %% 789 acht %% 234"
call jTestEnd t
return
endProcedure jTestScanWin
jScWi: procedure expose m.
parse arg t, cc
b = jOpen(jBuf(), 'r')
do ax=3 to arg()
aa = arg(ax)
if aa == '' then
aa = ' '
do cx=1 by cc to length(aa)
call mAdd jBufStem(b), substr(aa, cx, cc)
end
end
call scanWindow s, b, cc, (20%cc)+1
call scanOptions s, , , '%%'
call jOut 'scanWindwow cut' cc 'lines' mSize(jBufStem(b))
qx = 0
do forever
call scanSpaceNl s
if scanName(s) then do
qx = qx + 1
if m.tok ^== m.t.comp.qx then
call jOut 'scanned' m.tok 'but expected' m.t.comp.qx
end
else do
if ^ scanAtEnd(s) then
call scanErr s, 'could not scan'
if qx <> m.t.comp.0 then
call jOut 'scanned' qx 'name, but expected' m.t.comp.0
leave
end
end
call scanInit s
return
endProcedure jScWi
jTestDsn: procedure expose m.
call jInit
t = jNew()
call jTest t, 'jTestDsn',
, "jOut: ok write read 1 lines",
, "jOut: ok write read 2 lines",
, "jOut: ok write read 0 lines",
, "jOut: ok write read 55 lines",
, "jOut: ok write read 99 lines",
, "jOut: ok write read 100 lines",
, "jOut: ok write read 101 lines",
, "jOut: ok write read 201 lines",
, "jOut: ok write read 399 lines",
, "jOut: ok write read 300 lines",
, "jOut: ok write read 2000 lines",
, "jOut: ok write read 999 lines",
, "jOut: ok write read 3001 lines",
, "jOut: ok write read 0 lines"
d = jDsn('~TMP.TEXT(TTTEINS)')
call jTestWriteRead d, 1
call jTestWriteRead d, 2
call jTestWriteRead d, 0
call jTestWriteRead d, 55
call jTestWriteRead d, 99
call jTestWriteRead d, 100
call jTestWriteRead d, 101
call jTestWriteRead d, 201
call jTestWriteRead d, 399
call jTestWriteRead d, 300
call jTestWriteRead d,2000
call jTestWriteRead d, 999
call jTestWriteRead d,3001
call jTestWriteRead d, 0
call jTestEnd t
return
endProcedure jTestDsn
jTestWriteRead: procedure expose m.
parse arg f, cnt
call jOpen f, 'w'
pre = 'jTEstReadWrite' date() time(l) 'line'
do x=1 to cnt
call jWrite f, pre x
end
call jOpen f, 'r'
do y=1 while jRead(f, var)
if m.var <> pre y then
call jOut 'read mismatch line' y':' m.var
end
call jClose f
y = y - 1
if cnt = y then
call jOut 'ok write read' cnt 'lines'
else
call jOut 'mismatch written' cnt 'but read' y 'lines'
return
endProcedure jTestWriteRead
jTestBar: procedure expose m.
call envInit
t = jNew()
call jTest t, 'jTestBar',
, "jOut: +0 vor envBarBegin",
, "jIn 1: jTest in line 1 eins ,",
, "jIn 2: jTest in line 2 zwei ; ",
, "jIn 3: jTest in line 3 drei |",
, "jIn eof 4",
, "jOut: +7 nach envBarLast",
, "jOut: [7 +6 nach envBar 7]",
, "jOut: [7 +2 nach envBar 7]",
, "jOut: [7 +4 nach nested envBarLast 7]",
, "jOut: [7 (4 +3 nach nested envBarBegin 4) 7]",
, "jOut: [7 (4 (3 +1 nach envBarBegin 3) 4) 7]",
, "jOut: [7 (4 (3 jTest in line 1 eins , 3) 4) 7]",
, "jOut: [7 (4 (3 jTest in line 2 zwei ; 3) 4) 7]",
, "jOut: [7 (4 (3 jTest in line 3 drei | 3) 4) 7]",
, "jOut: [7 (4 (3 +1 nach readWrite vor envBar 3) 4) 7]",
, "jOut: [7 (4 +3 nach preSuf vor nested envBarLast 4) 7]",
, "jOut: [7 +4 nach preSuf vor nested envBarEnd 7]"
call jTestAdd t, ,
, "jOut: [7 +5 nach nested envBarEnd vor envBar 7]",
, "jOut: [7 +6 nach readWrite vor envBarLast 7]",
, "jOut: +7 nach readWrite vor envBarEnd",
, "jOut: +8 nach envBarEnd"
call jOut '+0 vor envBarBegin'
call envBarBegin
call jOut '+1 nach envBarBegin'
call utReadWrite
call jOut '+1 nach readWrite vor envBar'
call envBar
call jOut '+2 nach envBar'
call envBarBegin
call jOut '+3 nach nested envBarBegin'
call utPreSuf '(3 ', ' 3)'
call jOut '+3 nach preSuf vor nested envBarLast'
call envBarLast
call jOut '+4 nach nested envBarLast'
call utPreSuf '(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'
call utReadWrite
call jOut '+6 nach readWrite vor envBarLast'
call envBarLast
call jOut '+7 nach envBarLast'
call utPreSuf '[7 ', ' 7]'
call jOut '+7 nach readWrite vor envBarEnd'
call envBarEnd
call jOut '+8 nach envBarEnd'
call jTestEnd t
return
endProcedure jTestBar
jTestEnv: procedure
call envInit
t = jNew()
call jTest t, 'jTestEnv',
, "jOut: 1. test out",
, "jOut: 2. test write",
, "jIn 1: input einsA",
, "jOut: test read r1 1 : input einsA",
, "jIn eof 2",
, "jOut: test read r2 0 : M.R2",
, "jOut: envIsDefined(v1) false",
, "jOut: envIsDefined(v1) value of variable ""v1""",
, "jOut: 3. normaler Schluss"
call jTestAdd t, 'i0', "input einsA"
call jTestWrite t, "1. test out"
call jOut "2. test write"
call jOut "test read r1 " jIn(r1) ":" m.r1
call jOut "test read r2 " jIn(r2) ":" m.r2
if envIsDefined('v1') then
call jOut "envIsDefined(v1)" envGet('v1')
else
call jOut "envIsDefined(v1) false"
call envPut 'v1', 'value of variable "v1"'
if envIsDefined('v1') then
call jOut "envIsDefined(v1)" envGet('v1')
else
call jOut "envIsDefined(v1) false"
call jTestWrite t, "3. normaler Schluss"
call jTestEnd t
return
endProcedure jTestEnv
jTestCat: procedure
call envInit
tst = date('o') time()
t = jNew()
fn = '~test.shell'
call jTest t, 'jTestCat',
, "jOut: read aa 1 <zeile eins" tst " ",
|| " >",
, "jOut: read aa 2 <zeile zwei" tst " ",
|| " >",
, "jOut: read #buf 0 M.BLI",
, "jOut: read #buf b 1 <#buf eins" tst">",
, "jOut: read #buf b 2 <#buf zwei" tst">",
, "jOut: read bb 1 <zeile eins" tst " ",
|| " >",
, "jOut: read bb 2 <zeile zwei" tst " ",
|| " >",
, "jOut: read bb 3 <buffer 1. Zeile>",
, "jOut: read bb 4 <buffer 2.>",
, "jOut: read bb 5 <zeile eins" tst " ",
|| " >",
, "jOut: read bb 6 <zeile zwei" tst " ",
|| " >",
, "jOut: read bb 7 <#buf eins" tst">",
, "jOut: read bb 8 <#buf zwei" tst">",
, "jOut: read bb 8 lines"
c1 = cat(fn'(eins)')
call jOpen c1, 'w'
call jWrite c1, 'zeile eins' tst
call jWrite c1, 'zeile zwei' tst
call jClose c1, 'zeile drei' tst 'schluss'
call jOpen c1, 'r'
do lx=1 while jRead(c1, li)
call jOut 'read aa' lx '<'m.li'>'
end
call jClose c1
c2 = cat('#buf')
call jOpen c2, 'r'
call jOut 'read #buf' jRead(c2, bli) m.bli
call jOpen c2, 'w'
call jWrite c2, '#buf eins' tst
call jWrite c2, '#buf zwei' tst
call jOpen c2, 'r'
do lx=1 while jRead(c2, li)
call jOut 'read #buf b' lx '<'m.li'>'
end
call catReset c2, fn'(eins)'
call catAdd c2, "-£", jBuf("buffer 1. Zeile", "buffer 2.")
call catAdd c2, "-£", c1, "-", "#buf"
call jOpen c2, 'r'
do lx=1 while jRead(c2, li)
call jOut 'read bb' lx '<'m.li'>'
end
call jClose c2
call jOut 'read bb' (lx-1) 'lines'
call jTestEnd t
return
endProcedure jTestCat
err:
if m.jTest.act == '' then
call errA arg(1), 1
else
call jTestOut m.jTest.act, 'jErr:' arg(1)
return
endSubroutine err
/* copy ut begin ****************************************************
***********************************************************************/
utReadWrite: procedure expose m.
parse arg i, o
if i == '' then
i = m.j.jIn
if o == '' then
o = m.j.jOut
do while (jRead(i, line))
call jWrite o, m.line
end
return
endProcedure utReadWrite
utPreSuf: procedure expose m.
parse arg pre, suf
do while (jIn(line))
call jOut pre || m.line || suf
end
return
endProcedure utReadWrite
/* copy ut end ****************************************************/
/* copy cat begin ****************************************************
***********************************************************************/
catMakeOpen: procedure expose m.
parse arg opt, spec, defDsn
if right(opt, 1) = "£" then do
rw = spec
opt = left(opt, length(opt)-1)
end
else if left(spec, 1) == '#' then do
if envIsDefined(spec) then
rw = envGet(spec)
else
rw = envPut(spec, jBuf())
end
else if defDsn == '' then do
rw = jDsn(spec)
end
else do
rw = jReset(defDsn, spec)
end
if pos('-', opt) < 1 then
call jOpen rw, opt
return rw
endProcedure catMakeOpen
cat: procedure expose m.
m = jNew()
call catClose m
call jDefine m, "cat"
m.cat.m.defDsn = jDsn()
do ax=1 to arg()
m.cat.m.ax = arg(ax)
end
m.cat.m.0 = ax-1
return m
endProcedure cat
catReset: procedure expose m.
parse arg m
call catClose m
do ax=2 to arg()
bx=ax-1
m.cat.m.bx = arg(ax)
end
m.cat.m.0 = bx
return m
endProcedure catReset
catAdd: procedure expose m.
parse arg m
if m.cat.m.rdr ^== '' | m.cat.m.wrtr ^== '' then
call err 'catAdd but opened'
bx = m.cat.m.0
do ax=2 to arg()
bx=bx+1
m.cat.m.bx = arg(ax)
end
m.cat.m.0 = bx
return
endProcedure catAdd
catClose: procedure expose m.
parse arg m
if m.cat.m.rdr ^== '' & pos('-', m.cat.m.opt) < 1 then
if symbol('m.cat.m.rdr') == 'VAR' then
call jClose m.cat.m.rdr
m.cat.m.rdr = ''
m.cat.m.rdrIx = 'closed'
m.cat.m.opt = ''
if m.cat.m.wrtr ^== '' & pos('-', m.cat.m.opt) < 1 then
if symbol('m.cat.m.wrtr') == 'VAR' then
call jClose m.cat.m.wrtr
m.cat.m.wrtr = ''
return
endProcedure catClose
catOpen: procedure expose m.
parse arg m, oo
call catClose m
m.cat.m.opt = oo
m.cat.m.rdrIx = 0
if oo = 'r' then do
m.cat.m.rdr = catNextRW(m)
call jDefRead m, "res = catRead(m , arg)"
end
else if oo ^== 'w' & oo ^== 'a' then do
call err 'catOpen bad opt' opt
end
else do
m.cat.m.wrtr = catNextRW(m)
if m.cat.m.wrtr == '' then
call err 'catOpen no writer found'
m.cat.m.rdrIx = 'writing'
call jDefWrite m, "call catWrite m , arg"
end
return
endProcedure catOpen
catNextRW: procedure expose m.
parse arg m
cx = m.cat.m.rdrIx
oo = m.cat.m.opt
do cx=cx+1 to m.cat.m.0
if jOpt(m.cat.m.cx, 'rwa-£') then do
if pos(left(m.j.oOpt, 1), 'rwa') > 0 then
oo = left(oo, 1)substr(m.j.oOpt, 2)
else
oo = left(oo, 1)m.j.oOpt
end
else do
m.cat.m.rdrIx = cx
m.cat.m.opt = oo
return catMakeOpen(oo, m.cat.m.cx, m.cat.m.defDsn)
end
end
m.cat.m.rdrIx = cx
return ''
endProcedure catNextRw
catRead: procedure expose m.
parse arg m, arg
do while m.cat.m.rdr ^== ''
if jRead(m.cat.m.rdr, arg) then
return 1
call jClose m.cat.m.rdr
m.cat.m.rdr = catNextRW(m)
end
if ^ dataType(m.cat.m.rdrIx, 'n') then
call err 'catRead but' m.cat.m.rdrIx
return 0
endProcedure catRead
catWrite: procedure expose m.
parse arg m, arg
if m.cat.m.wrtr == '' then
call err 'catWrite without open for write'
call jWrite m.cat.m.wrtr, arg
return
endProcedure catWrite
/* copy cat end ****************************************************/
/* copy env begin ******************************************************
***********************************************************************/
env: procedure expose m.
nn = envReset(jNew())
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.env.m.in = ''
m.env.m.out = ''
m.env.m.doClose = ''
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
if symbol('m.env.m.doClose') == 'VAR' then
interpret m.env.m.doClose
m.env.m.doClose = ''
m.env.m.lastCat = ''
m.env.m.lastExt = ''
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
end
if left(opt, 1) == '&' then do
if m.env.m.lastCat ^== '' then
call err 'envAddIO('opt',' spec') external within cat'
if m.env.m.lastExt ^== '' then
call err 'envAddIO('opt',' spec') external within ext'
m.env.m.lastExt = opt || spec
end
else if (contX | m.env.m.lastCat ^== '') then do
if left(opt, 1) ^== '<' then
call err 'envAddIO('opt',' spec') concat but not input'
if m.env.m.lastCat == '' then
m.env.m.lastCat = catNew(mNew())
call catAdd m.env.m.lastCat m, opt, spec
end
if ^ contX then do
if m.env.m.lastCat ^== '' then do
v = 'ro'
spec = m.env.m.lastCat
m.env.m.lastCat = ''
end
else do
v = env2opt(opt)
end
if m.env.m.lastExt ^== '' then do
nn = extFdNew(jNew(), m.env.m.lastExt, v, spec)
m.env.m.lastExt = ''
end
else do
nn = catMakeOpen(v, spec)
if left(v, 1) == 'r' then do
if m.env.m.in ^== '' then
call err 'addIo('opt',' spec') duplicate stdIn'
m.env.m.in = nn
end
else do
if m.env.m.out ^== '' then
call err 'addIo('opt',' spec') duplicate stdOut'
m.env.m.out = nn
end
end
m.env.m.doClose = m.env.m.doClose '; call jClose "'nn'"'
end
return m
endProcedure envAddIO
envLink: procedure expose m.
parse arg m, old
if m.env.m.lastCat ^== '' then
call err 'envLink with open cat'
if m.env.m.in == '' then
m.env.m.in = m.env.old.in
if m.env.m.out == '' then
m.env.m.out = m.env.old.out
return m
endProcedure envLink
envPut: procedure expose m.
parse arg na, va
m.env.var.na = va
return va
endProcedure envPut
envIsDefined: procedure expose m.
parse arg na
return symbol('m.env.var.na') == 'VAR'
endProcedure envIsDefined
envGet: procedure expose m.
parse arg na
if symbol('m.env.var.na') ^== 'VAR' then
call err 'envGet('na') undefined name'
return m.env.var.na
endProcedure envGet
envRemove: procedure expose m.
parse arg na
drop m.env.var.na
return
endProcedure envRemove
env2opt: procedure
parse arg o1 2 oR
if o1 == '<' then
return 'r' || oR
else if o1 ^== '>' then
return o1 || oR
else if left(oR, 1) == '>' then
return 'a' || substr(oR, 2)
else
return 'w' || oR
endProcedure env2opt
envInit: procedure expose m.
call jInit
m.env.env.0 = 1
ex = env()
m.env.env.1 = ex
m.env.ex.in = m.j.jIn
m.env.ex.out = m.j.jOut
m.env.val.0 = 0
return
endProcedure
envPush: procedure expose m.
parse arg e
ex = m.env.env.0
call envLink e, m.env.env.ex
ex = ex + 1
m.env.env.0 = ex
m.env.env.ex = e
m.j.jIn = m.env.e.in
m.j.jOut = m.env.e.out
return e
endProcedure envPush
envPop: procedure expose m.
ox = m.env.env.0
if ox <= 1 then
call err 'envPop on empty stack' ox
call envClose m.env.env.ox
ex = ox - 1
m.env.env.0 = ex
e = m.env.env.ex
m.j.jIn = m.env.e.in
m.j.jOut = m.env.e.out
return m.env.env.ox
endProcedure envPop
envBarBegin: procedure expose m.
call envPush env('>£', jBuf())
return
endProcedure envBarBegin
envBar: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.env.oldEnv.out, '>£', jBuf())
return
endProcedure envBar
envBarLast: procedure expose m.
oldEnv = envPop()
call envPush env('<£', m.env.oldEnv.out)
return
endProcedure envBarLast
envBarEnd: procedure expose m.
oldEnv = envPop()
return
endProcedure envBarEnd
/* copy env end *******************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanLine(m,ln) : begin scanning a single line (string)
scanReader(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.tok ==> last token
m.val ==> last value for scanString/Word/KeyValue
m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line -----------------------------------*/
scanLine: procedure expose m.
parse arg m, m.scan.m.src
m.scan.m.pos = 1
if symbol('m.scan.m.name') ^== 'VAR' then
call scanInit m
return m
endProcedure scanLine
/*--- switch to next line if atEnd of line or unCond=1 ---------------*/
scanNL: procedure expose m.
parse arg m, unCond
if m.scan.m.reading then do
interpret m.scan.m.scanNl
end
else do
np = 1 + length(m.scan.m.src)
if np <= m.scan.m.pos then
return 0
if unCond == 1 then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
m.scan.m.pos = np
return 1
end
endProcedure scanNL
scanAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.reading then
interpret m.scan.m.scanAtEnd
else
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEnd
/*--- initialize scanner for m --------------------------------------*/
scanInit: procedure expose m.
parse arg m, rdng
m.scan.m.reading = rdng == 1
m.tok = ''
m.val = ''
m.key = ''
m.scan.LC = 'abcdefghijklmnopqurstuvwxyz'
m.scan.UC = 'ABCDEFGHIJKLMNOPQURSTUVWXYZ'
m.scan.Alpha = m.scan.LC || m.scan.UC
m.scan.AlNum = '0123456789' || m.scan.ALPHA
m.scan.m.Name1 = m.scan.ALPHA
m.scan.m.Name = m.scan.ALNUM
m.scan.m.comment = ''
return
endProcedure scanInit
/*--- set options name characters, comment characters ----------------*/
scanOptions: procedure expose m.
parse arg m, nameOne, namePlus, m.scan.m.comment
if symbol('m.scan.m.Name') ^== 'VAR' then
call scanInit m
if nameOne ^== '' then do
m.scan.m.Name1 = nameOne
m.scan.m.name = m.scan.m.name1 || '0123456789'
end
if namePlus ^== '' then
m.scan.m.name = m.scan.m.name1 || namePlus
return
endProcedure scanOptions
/*--- return the next len characters ---------------------------------*/
scanLook: procedure expose m.
parse arg m, len
nx = 1 + length(m.scan.m.src)
if len ^== '' then
if nx > m.scan.m.pos + len then
nx = m.scan.m.pos + len
return substr(m.scan.m.src, m.scan.m.pos, nx - m.scan.m.pos)
endProcedure scanLit
/*--- scan the next len characters -----------------------------------*/
scanChar: procedure expose m.
parse arg m, len
m.tok = scanLook(m, len)
m.scan.m.pos = m.scan.m.pos + length(m.tok)
return length(m.tok) > 0
endProcedure scanChar
/*--- scan the literal lit ------------------------------------------*/
scanLit: procedure expose m.
parse arg m, lit
if ^ abbrev(substr(m.scan.m.src, m.scan.m.pos), lit) then
return 0
m.scan.m.pos = m.scan.m.pos + length(lit)
m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.val = ''
if qu = '' then
qu = "'"
if substr(m.scan.m.src, m.scan.m.pos, 1) ^== qu then
return 0
bx = m.scan.m.pos
qx = m.scan.m.pos + 1
do forever
px = pos(qu, m.scan.m.src, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.val = m.val || substr(m.scan.m.src, qx, px-qx)
if px >= length(m.scan.m.src) then
leave
else if substr(m.scan.m.src, px+1, 1) <> qu then
leave
qx = px+2
m.val = m.val || qu
end
m.tok = substr(m.scan.m.src, bx, px+1-bx)
m.scan.m.pos = px+1
return 1
endProcedure scanString
/*--- scan a Name, first char in *.name1, rest in *.name -------------*/
scanName: procedure expose m.
parse arg m
if pos(substr(m.scan.m.src, m.scan.m.pos, 1),
, m.scan.m.Name1) <= 0 then
return 0
bx = m.scan.m.pos
m.scan.m.pos = bx + 1
call scanVerify m, m.scan.m.Name
m.tok = substr(m.scan.m.src, bx, m.scan.m.pos - bx)
return 1
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.scan.m.src, alpha, , m.scan.m.pos)
else
nx = verify(m.scan.m.src, alpha, vOpt, m.scan.m.pos)
if nx = 0 then
nx = length(m.scan.m.src) + 1
m.tok = substr(m.scan.m.src, m.scan.m.Pos, nx - m.scan.m.Pos)
if nx <= m.scan.m.pos then
return 0
m.scan.m.pos = nx
return 1
endProcedure scanVerify
/*--- scan a natural number (no sign, decpoint ...) ------------------*/
ScanNat: procedure expose m.
parse arg m
if ^ scanVerify(m, '0123456789') then
return 0
else if pos(substr(m.scan.m.src, m.scan.m.pos, 1), m.scan.m.name1) ,
> 0 then
call scanErr m, 'illegal number end'
return 1
endProcedure ScanNat
/*--- 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 scanString(m, """") then return 1
if ^scanVerify(m, ' 'stopper, 'm') then return 0
m.val = m.tok
return 1
endProcedure scanWord
scanBack: procedure expose m.
parse arg m, tok
if m.scan.m.pos <= length(tok) then
call scanErr sc, 'cannot back "'tok'" length'
cx = m.scan.m.pos - length(tok)
if substr(m.scan.m.src, cx, length(tok)) ^== tok then
call scanErr sc, 'cannot back "'tok'" value'
m.scan.m.pos = cx
return
endProcedure scanBack
/*--- scan a key = word phrase
put key into m.key and word into m.val -------*/
scanKeyValue: procedure expose m.
parse arg m, def
if ^ scanName(m) then
return 0
m.key = m.tok
if ^ scanLit(scanSkip(m), '=') then do
m.val = def
m.tok = ' no='
end
else if ^scanWord(scanSkip(m)) then
call scanErr(m, 'word expected after' m.key '=')
return 1
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.tok 'scanPosition' ,
strip(left(substr(m.scan.m.src, m.scan.m.pos), 40), 't')
if m.scan.m.reading then
interpret 'say " "' m.scan.m.scanLinePos
else
say ' pos' m.scan.m.Pos 'in string' strip(m.scan.m.src, 't')
call err 'scanErr' txt
return
endProcedure scanErr
/*--- skip over spaces, nl and comments (if option set) --------------*/
scanSpaceNL: procedure expose m.
parse arg m
lastTok = m.tok
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then leave
res = 1
end
m.tok = lastTok
return res
endProcedure scanSpaceNL
/*--- skip over space, nl and comments and return m -----------------*/
scanSkip: procedure expose m.
parse arg m
call scanSpaceNl m
return m
endProcedure scanSkip
/*--- begin scanning the lines of a reader ---------------------------*/
scanReader: procedure expose m.
parse arg m, m.scan.m.rdr
call scanInit m, 1
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanReaderNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanReaderAtEnd(m, what)'
m.scan.m.scanLinePos = "scanReaderLinePos(m)"
call scanReaderNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanReaderAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos <= length(m.scan.m.src) then
return 0
if what == 'l' then
return 1
return m.scan.m.atEnd
endProcedure scanReaderAtEnd
scanReaderNL: procedure expose m.
parse arg m, unCond
if unCond == 1 then nop
else if unCond ^= 2 & m.scan.m.pos > length(m.scan.m.src) then nop
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& abbrev(m.scan.m.src, m.scan.m.comment) then nop
else
return 0
if m.scan.m.atEnd then
return 0
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, 'SCAN.'m'.SRC')
if m.scan.m.atEnd then do
m.scan.m.pos = 1 + length(m.scan.m.src)
end
else do
m.scan.m.pos = 1
m.scan.m.lineX = m.scan.m.lineX + 1
end
return ^ m.scan.m.atEnd
endProcedure scanReaderNL
scanReaderLinePos: procedure expose m.
parse arg m
if m.scan.m.atEnd then
qq = 'atEnd after'
else
qq = 'pos' m.scan.m.pos 'in'
return qq 'line' m.scan.m.lineX':' strip(m.scan.m.src, 't')
endProcedure scanReaderLinePos
/* copy scan 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
***********************************************************************/
/*--- begin scanning the lines of a reader
by concatenating them together in window -----------------------*/
scanWindow: procedure expose m.
parse arg m, m.scan.m.rdr, m.scan.m.winCut, m.scan.m.winSz
call scanInit m, 1
m.scan.m.winML = (2 * m.scan.m.winSz + 1) * m.scan.m.winCut
m.scan.m.atEnd = 0
m.scan.m.lineX = 0
m.scan.m.scanNl = 'return scanWinNl(m, unCond)'
m.scan.m.scanAtEnd = 'return scanWinAtEnd(m, what)'
m.scan.m.scanLinePos = "scanWinLinePos(m)"
call scanLine m, ''
call scanWinNl m, 1
return m
endProcedure scanReader
/*--- return true/false whether we are at the end of line / reader ---*/
scanWinAtEnd: procedure expose m.
parse arg m, what
if m.scan.m.pos > length(m.scan.m.src) then do
if m.scan.m.atEnd then
return 1
else
call scanErr m, 'out of window'
end
return 0
endProcedure scanReaderAtEnd
scanWinNL: procedure expose m.
parse arg m, unCond
ps = m.scan.m.pos
cut = m.scan.m.winCut
res = 0
if ps > length(m.scan.m.src) then do
if m.scan.m.atEnd then
return 0
if m.scan.m.src ^== '' then
call scanErr m, 'out of window'
end
else do
nl = ps + cut - ((ps-1) // cut)
if unCond == 1 then
res = 1
else if unCond ^= 0 & m.scan.m.comment ^== '' ,
& length(m.scan.m.comment) <= nl - ps then
res = abbrev(substr(m.scan.m.src, ps), m.scan.m.comment)
if res then
ps = nl
end
if m.scan.m.atEnd then do
m.scan.m.pos = ps
return res
end
if ps > cut * m.scan.m.winSz then do
ll = (ps-1) % cut
m.scan.m.src = substr(m.scan.m.src, 1 + ll * cut)
ps = ps - (ll * cut)
m.scan.m.lineX = m.scan.m.lineX + ll
end
do while length(m.scan.m.src) < m.scan.m.winML
m.scan.m.atEnd = ^ jRead(m.scan.m.rdr, r1)
if m.scan.m.atEnd then
leave
m.scan.m.src = m.scan.m.src || left(m.r1, cut)
end
m.scan.m.pos = ps
return res
endProcedure scanWinNL
scanWinLinePos: procedure expose m.
parse arg m
ps = m.scan.m.pos
cut = m.scan.m.winCut
if ps > length(m.scan.m.src) then do
lx = (length(m.scan.m.src) - 1) % cut
msg = 'after'
if m.scan.m.atEnd then
msg = 'atEnd' msg
end
else do
lx = (ps - 1) % cut
msg = 'pos' (ps - (lx*cut)) 'at'
end
return msg 'line' (m.scan.m.lineX+lx+1)':' ,
strip(substr(m.scan.m.src, lx*cut+1, cut), 't')
endProcedure scanWinLinePos
/* copy scanWin end *************************************************/
/* copy jTest begin ****************************************************
test infrastructure
***********************************************************************/
/*--- return stems ---------------------------------------------------*/
jTestAdd: procedure expose m.
parse arg m, wh
st = 'JTEST.'m
if pos('i', wh) > 0 then
st = st'.IN'
if pos('0', wh) > 0 then
sx = 0
else
sx = m.st.0
do ax=3 to arg()
sx = sx+1
m.st.sx = arg(ax)
end
m.st.0 = sx
return st
endProcedure jTestAdd
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
jTest: procedure expose m.
parse arg m, name
m.jTest.m = name
m.jTest.act = m
ox = 1
m.jTest.m.ox = left('****** start jTest' name '', 79, '*')
do ax=3 to arg()
ox = ox + 1
m.jTest.m.ox = arg(ax)
end
m.jTest.m.0 = ox
m.jTest.m.in.0 = 0
call mAdd jTest'.'m'.IN', 'jTest in line 1 eins ,' ,
, 'jTest in line 2 zwei ; ',
, 'jTest in line 3 drei |'
call jDefine m, 'jTest'
call jDefine m'jIn', 'jTest'
if m.env.env.0 <> 1 then
call jTestErr m, 'm.env.env.0' m.env.env.0 '<> 1'
call envPush env( '<£', m'jIn', '>£', m)
call jTestOut m, m.jTest.m.1
return 'JTEST.'m
endProcedure jTest
jTestOpen: procedure expose m.
parse arg m, opt
if opt = 'r' then do
if right(m, 3) ^== 'jIn' then
call err 'jTestOpen' m',' opt
mw = left(m, length(m)-3)
call jDefRead m, 'res = jTestRead("'mw'", arg)'
m.jTest.mw.inIx = 0
end
else if opt = 'w' then do
call jDefWrite m, 'call jTestWrite m, arg'
m.jTest.m.out.0 = 0
m.jTest.m.err = 0
if symbol("m.jTest.err") ^= 'VAR' then
m.jTest.err = 0
end
else
call err 'bad opt jTestOpen('m',' opt')'
return m
endProcedure jTestOpen
jTestClose:
return arg(1)
endProcedure jTestClose
jTestEnd: procedure expose m.
parse arg m, opt
call envPop
m.jTest.act = ''
if m.env.env.0 <> 1 then
call jTestErr m, 'm.env.env.0' m.env.env.0 '<> 1'
if m.jTest.m.out.0 ^= m.jTest.m.0 then do
call jTestErr m, 'old' m.jTest.m.0 'lines ^= new' ,
m.jTest.m.out.0
do nx = m.jTest.m.out.0 + 1 to ,
min(m.jTest.m.out.0+10, m.jTest.m.0)
say 'old - ' m.jTest.m.nx
end
end
if m.jTest.m.err > 0 then do
say 'new lines:' m.jTest.m.out.0
len = 60
do nx=2 to m.jTest.m.out.0
str = quote(m.jTest.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.jTest.m.out.0)
end
end
say left('******' m.jTest.m 'end with' m.jTest.m.err 'errors ', 79,
, '*')
return
endProcedure jTestClose
/*--- write to test: say lines and compare them ----------------------*/
jTestWrite: procedure expose m.
parse arg m, arg
call jTestOut m, 'jOut:' arg
return
endProcedure jTestWrite
jTestOut: procedure expose m.
parse arg m, arg
nx = m.jTest.m.out.0 + 1
m.jTest.m.out.0 = nx
m.jTest.m.out.nx = arg
if nx > m.jTest.m.0 then do
if nx = m.jTest.m.0+1 then
call jTestErr m, 'more new Lines' nx
end
else if m.jTest.m.nx ^== arg then do
call jTestErr m, 'next line old' nx '^^^ new overnext'
say m.jTest.m.nx
end
say arg
return
endProcedure jTestOut
jTestRead: procedure expose m.
parse arg m, arg
ix = m.jTest.m.inIx + 1
m.jTest.m.inIx = ix
if ix <= m.jTest.m.in.0 then do
m.arg = m.jTest.m.in.ix
call jTestOut m, 'jIn' ix':' m.arg
return 1
end
call jTestOut m, 'jIn eof' ix
return 0
endProcedure jTestRead
/*--- say total errors and fail if not zero --------------------------*/
jTestTotal: procedure expose m.
if m.jTest.err = 0 then
say m.jTest.err 'errors total'
else
call err m.jTest.err 'errors total'
return
endProcedure jTestTotal
/*--- test err: message, count it and continue -----------------------*/
jTestErr: procedure expose m.
parse arg m, msg
say '*** error' msg
m.jTest.m.err = m.jTest.m.err + 1
m.jTest.err = m.jTest.err + 1
return
endProcedure jTestErr
/*--- 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
/* copy jTest end **************************************************/
/* copy j begin *******************************************************
the j framework
jReset
jOpen
jClose
jRead
jWrite
***********************************************************************/
jNew: procedure expose m.
return 'J.'mIncD(j.0)
endProcedure jNew
jFree: procedure expose m.
parse arg m
return
endProcedure jFree
jRead: procedure expose m.
parse arg m, arg
res = '?'
interpret m.j.m.read
return res
endProcedure jRead
jWrite: procedure expose m.
parse arg m, arg
interpret m.j.m.write
return
endProcedure jWrite
jReset: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Reset m, arg'
return m
endProcedure jOpen
jOpen: procedure expose m.
parse arg m, arg
interpret 'call' m.j.m.pref'Open m, arg'
return m
endProcedure jOpen
jClose: procedure expose m.
parse arg m
interpret 'call' m.j.m.pref'Close m'
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jClose
jDefine: procedure expose m.
parse arg m, m.j.m.pref
m.j.m.read = 'call err "read('m') when closed"'
m.j.m.write = 'call err "write('m') when closed"'
return m
endProcedure jDefine
jDefRead: procedure expose m.
parse arg m, m.j.m.read
m.j.m.write = 'call err "write('m') when reading"'
return m
endProcedure jDeRead
jDefWrite: procedure expose m.
parse arg m, m.j.m.write
m.j.m.read = 'call err "read('m') when writing"'
return m
endProcedure jDeWrite
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
jInit: procedure expose m.
m.j.jIn = jNew()
m.j.jOut = jNew()
call jDefine m.j.jIn, "jStdIOError "
call jDefRead m.j.jIn, "res = 0"
call jDefine m.j.jOut, "jStdIOError "
call jDefWrite m.j.jOut, "say arg"
return
endProcedure jInit
jStdIOError: procedure expose m.
parse arg fun m, arg
call err 'do not j'fun'('m',' arg') base stdIn/stdOut'
return
endSubroutine
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: procedure expose m.
m = jNew()
call jDefine m, "jBuf"
do ax=1 to arg()
m.j.m.buf.ax = arg(ax)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBuf
jBufReset: procedure expose m.
parse arg m
do ax=1 to arg() - 1
m.j.m.buf.ax = arg(ax+1)
end
m.j.m.buf.0 = ax-1
return m
endProcedure jBufReset
jBufOpen: procedure expose m.
parse arg m, opt
if opt == 'r' then do
call jDefRead m, "res = jBufRead(m , arg)"
m.j.m.bufIx = 0
return m
end
if opt == 'w' then
m.j.m.buf.0 = 0
else if opt ^== 'a' then
call err 'jBufOpen('m',' opt') with bad opt'
call jDefWrite m, "call mAdd 'J.'m'.BUF', arg"
return m
endProcedure jBufOpen
jBufClose:
return arg(1)
endProcedure jBufClose
jBufStem: procedure expose m.
parse arg m
return 'J.'m'.BUF'
endProcedure jBufStem
jBufRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then
return 0
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jBufRead
jDsn: procedure expose m.
parse arg spec
m = jNew()
m.j.m.state = ''
call jDefine m, "jDsn"
m.j.m.defDD = 'J'mIncD('J.DEFDD')
call jDsnReset m, spec
return m
endProcedure jDsn
jDsnReset: procedure expose m.
parse arg m, spec
call jClose m
m.j.m.dsnSpec = spec
return m
endProcedure jDsnReset
jDsnOpen: procedure expose m.
parse arg m, opt
call jDsnClose m
if opt == 'r' then do
aa = dsnAlloc(m.j.m.dsnSpec, 'SHR', m.j.m.defDD)
call readDDBegin word(aa, 1)
call jDefRead m, "res = jDsnRead(m , arg)"
end
else do
if opt == 'w' then
aa = dsnAlloc(m.j.m.dsnSpec, 'OLD', m.j.m.defDD)
else if opt == 'a' then
aa = dsnAlloc(m.j.m.dsnSpec, 'MOD', m.j.m.defDD)
else
call err 'jBufOpen('m',' opt') with bad opt'
call writeDDbegin word(aa, 1)
call jDefWrite m, "call jDsnWrite m , arg"
end
m.j.m.state = opt
m.j.m.dd = word(aa, 1)
m.j.m.free = subword(aa, 2)
return m
endProcedure jBufOpen
jDsnClose:
parse arg m
if m.j.m.state ^== '' then do
if m.j.m.state == 'r' then do
call readDDend m.j.m.dd
end
else do
if m.j.m.buf.0 > 0 then
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
call writeDDend m.j.m.dd
end
interpret m.j.m.free
end
m.j.m.buf.0 = 0
m.j.m.bufIx = 0
m.j.m.state = ''
m.j.m.free = ''
m.j.m.dd = ''
return m
endProcedure jDsnClose
jDsnRead: procedure expose m.
parse arg m, var
ix = m.j.m.bufIx + 1
if ix > m.j.m.buf.0 then do
res = readDD(m.j.m.dd, 'M.J.'m'.BUF.')
if ^ res then
return 0
ix = 1
end
m.j.m.bufIx = ix
m.var = m.j.m.buf.ix
return 1
endProcedure jDsnRead
jDsnWrite: procedure expose m.
parse arg m, var
ix = m.j.m.buf.0 + 1
m.j.m.buf.0 = ix
m.j.m.buf.ix = var
if ix > 99 then do
call writeDD m.j.m.dd, 'M.J.'m'.BUF.'
m.j.m.buf.0 = 0
end
return
endProcedure jDsnWrite
/* copy j end *********************************************************/
/* copy m begin ********************************************************
stem and tree handling
***********************************************************************/
/*--- increase m.a and return it (fail if undefined) -----------------*/
mInc: procedure expose m.
parse arg a, delta
if delta = '' then
m.a = m.a + 1
else
m.a = m.a + delta
return m.a
endProcedure mInc
/*--- increase m.m and return it (also if undefined) -----------------*/
mIncD: procedure expose m.
parse arg a, delta
if symbol('m.a') <> 'VAR' then
m.a = 0
return mInc(a)
endProcedure mIncD
/*--- return Ky of m ------------------------------------------------*/
mKy: procedure expose m.
parse arg a
return m.m.key.a
endProcedure mKy
/*--- return number of children of node m or 0 -----------------------*/
mSize: procedure expose m.
parse arg a
if symbol('m.a.0') == 'VAR' then
return m.a.0
else
return 0
endProcedure mSize
/*--- return parent of node m or '' ----------------------------------*/
mPar: procedure expose m.
parse arg a
dx = lastPos('.', a)
if dx <= 1 then
return ''
else
return left(a, dx - 1)
endProcedure mPar
/*--- create a new tree root -----------------------------------------*/
mRoot: procedure expose m.
parse arg a, Ky, val
if a == '' then
a = 'm.root.' || mIncD('m.root.0')
m.a = val
m.m.key.a = Ky
m.a.0 = 0
return a
endProcedure mRoot
/*--- add one or several values to stem m.a --------------------------*/
mAdd: procedure expose m.
parse arg a
ix = mSize(a)
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.* ----------------------*/
mAddSeq: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
dx = mSize(dst)
do sx = begX to endX
dx = dx + 1
m.dst.dx = m.src.sx
end
m.dst.0 = dx
return dst
endProcedure mAddSeq
/*--- add one value to the stem m.m ----------------------------------*/
mAddNd: procedure expose m.
parse arg a
ix = mSize(a)
do ax = 2 to arg()
ix = ix + 1
m.a.ix = arg(ax)
m.a.ix.0 = 0
end
m.a.0 = ix
return a'.'ix
endProcedure mAddNd
/*--- add one Ky value pair to stem m.a -----------------------------*/
mAddKy: procedure expose m.
parse arg a, Ky, val
nn = mAddNd(a, val)
m.m.key.nn = Ky
return nn
endProcedure mAddKy
/*--- add one indexable Ky value pair to stem m.m -------------------*/
mAddK1: procedure expose m.
parse arg a, ky, val
if symbol('m.m.index.a.key.ky') == 'VAR' then
call err 'duplicate Ky' ky 'for node' m
nn = mAddNd(m, val)
m.m.key.nn = ky
m.m.index.a.key.ky = nn
return nn
endProcedure mAddK1
/*--- put value at Ky if it exists otherwise add the node -----------*/
mPut: procedure expose m.
parse arg a, Ky, val
if symbol('m.m.index.a.key.Ky') == 'VAR' then do
ch = m.m.index.a.key.Ky
m.ch = val
return ch
end
else do
return mAddK1(a, Ky, val)
end
return
endProcedure mPut
/*--- return the child of m at the given Ky, '' if not exists -------*/
mAtK1: procedure expose m.
parse arg a, ky
if symbol('m.m.index.a.key.ky') == 'VAR' then
return m.m.index.a.key.ky
else
return ''
endProcedure mAtK1
/*--- return the value of the child at Ky, fail if not exists -------*/
mVaAtK1: procedure expose m.
parse arg a, Ky
if symbol('m.m.index.a.key.Ky') ^== 'VAR' then
call err 'no Ky' Ky 'at node' a
ch = m.m.index.a.key.Ky
return m.ch
endProcedure mVaAtK1
/*--- return the value of the first defined ky in the list of nodes
def if ky isn't defined ---------------------------------------*/
mFirst: procedure expose m.
parse arg Ky, def
do ax=3 to arg()
a = arg(ax)
if symbol('m.m.index.a.key.Ky') == 'VAR' then do
ch = m.m.index.a.key.Ky
return m.ch
end
end
return def
endProcedure mFirst
/*--- return the child at sequenceNo seq of node m -------------------*/
mAtSq: procedure expose m.
parse arg a, seq
if symbol('m.a.seq') ^== 'VAR' then
return ''
else
return m'.'seq
endProcedure mAtSq
/*--- remove all or all after nwSz children --------------------------*/
mRemCh: procedure expose m.
parse arg pa, nwSz
if nwSz = '' then
nwSz = 0
do cx=nwSz+1 to mSize(pa)
ch = pa'.'cx
call mRemCh ch
ky = m.m.key.ch
drop m.m.index.pa.key.ky m.key.ch m.ch m.ch.0
end
m.pa.0 = nwSz
return pa
endProcedure mRemCh
/*--- add to m.dst a (sub)tree of m.src.* ----------------------------*/
mAddTree: procedure expose m.
parse arg dst, src, begX, endX
if begX = '' then
begX = 1
if endX = '' then
endX = mSize(src)
do sx=begX to endX
sCh = src'.'sx
if symbol('m.m.key.sCh') ^= 'VAR' then do
dCh = mAddNd(dst, m.sCh)
end
else do
ky = m.m.key.sCh
if symbol('m.m.index.src.key.ky') ^= 'VAR' then
dCh = mAddKy(dst, ky, m.sCh)
else
dCh = mAddK1(dst, ky, m.sCh)
end
call mAddTree dCh, sCh
end
return dst
endProcedure mAddTree
/*--- show from one node everything that is defined ------------------*/
mShowNd: procedure expose m.
parse arg a
pa = mPar(a)
t = 'node' a 'pa='pa
if symbol('m.a') == 'VAR' then
t = t 'va='m.a
if symbol('m.a.0') == 'VAR' then
t = t 'size='m.a.0
if symbol('m.m.key.a') == 'VAR' then do
ky = m.m.key.a
t = t 'ky='ky
if symbol('m.m.index.pa.key.ky') == 'VAR' then
t = t 'index='m.m.index.pa.key.ky
end
say t
return
endProcedure mShowNd
/*--- show the tree at m recursively ---------------------------------*/
mShow: procedure expose m.
parse arg a, lv
if lv = '' then
lv = 0
t = left('', lv)a
if symbol('m.m.key.m') == 'VAR' then do
ky = m.m.key.m
pa = mPar(m)
if symbol('m.m.index.pa.key.ky') == 'VAR' then
t= t ky '>'
else
t= t ky '='
end
say t strip(m.a, 't')
do cx=1 to mSize(a)
call mShow mAtSq(a, cx), lv+1
end
return
endProcedure treeShow
/* copy m 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
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
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure
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
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
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
parse arg ggDD
call adrTso 'execio 0 diskr' ggDD '(finis)'
return /* end readDDEnd */
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure
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
parse arg ggDD
call adrTso 'execio 0 diskw' ggDD '(finis)'
return /* end writeDDEnd */
/*--- alloc a dsn or a dd -------------------------------------------*/
dsnAlloc: procedure expose m.
parse upper arg spec, disp, dd
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))
rest = ''
do wx=1 by 1
w = word(spec, wx)
if w = '' then
leave
if abbrev(w, '.') then do
rest = substr(subword(spec, wx), 2)
leave
end
if abbrev(w, ':') then do
nn = substr(subword(spec, wx), 2)
leave
end
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 ds = '' then
ds = dsn2jcl(w)
else
leave
end
if dd = '' then
dd = 'DD' || ooNew()
if disp = '' | (disp = 'OLD' & pos('(', dsn) > 0) then
disp = 'SHR'
m.dsnAlloc.dsn = ds
if ds <> '' then
ds = "DSN('"ds"')"
alRc = adrTso('alloc dd('dd')' disp ds rest, '*')
if alRc ^== 0 then do
if nn = 'NN' | wordPos(disp, 'OLD SHR') < 1 ,
| sysDsn("'"m.dsnAlloc.dsn"'") ^== 'DATASET NOT FOUND' then
call err 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest
say 'tsoAlloc rc' alRc 'for alloc dd('dd')' disp ds rest ,
'...trying to create'
call dsnAllocCreate m.dsnAlloc.dsn, nn
call adrTso 'alloc dd('dd')' disp ds rest
end
return dd 'call adrTso "free dd('dd')";'
endProcedure dsnAlloc
dsnAllocCreate: procedure expose m.
parse arg dsn, atts
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
atts = 'recfm(f b) lrecl('rl')' ,
'block(' (32760 - 32760 // rl)')'
end
else do
if rl = '' then
rl = 32756
atts = 'recfm('substr(atts, 2, 1) 'b) lrecl('rl')' ,
'block(32760)'
end
if pos('(', dsn) > 0 then
atts = atts 'dsntype(library) dsorg(po)' ,
"dsn('"dsnSetMbr(dsn)"')"
else
atts = atts "dsn('"dsn"')"
atts = 'new catalog' atts 'mgmtclas(s005y000) space(10, 1000)'
call adrTso 'alloc dd(dsnAlloc)' atts
call adrTso 'free dd(dsnAlloc)'
return
endProcedure dsnAllocCreate
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
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 'finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
call errA arg(1), 1
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt, ggHist
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
if ggHist ^== 1 then
exit setRc(12)
say 'divide by zero to show stack history'
x = 1 / 0
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggMsg
call help
call err ggMsg
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
----------------------------------------------------------------------*/
setRc: procedure
parse arg zIspfRc
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
/*--- 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
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
/*--- return current time and cpu usage ------------------------------*/
showtime: procedure
return time() time('E') sysvar('syscpu') /* sysvar('syssrv') */
/--- display the first comment block of the source as help -----------*/
help: procedure
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 *****************************************************/