zOs/REXX.O13/PVSCOUNT
/* REXX ***************************************************************/
parse arg num
say num
call wrIni
ABC = 'ab'num
wx = wr2DS(wrNew(), 'disp=shr dsn=wk.text(cnt'num')')
call outPush wx
call lmdBegin ABC, 'PVR.*.*.W*.D2005'num'*'
yy = 0
do while lmdNEXT(ABC, l.)
yy = yy + l.0
do y=1 to l.0
call afpCount word(l.y, 1)
end
end
say yy 'files found'
call lmdEnd ABC
call outPop
call wrClose wx
exit
afpCount: procedure expose m.
parse arg dsn
/* afp constants */
afp = '5A'x
bpg = 'D3A8AF'x
epg = 'D3A9AF'x
nop = 'D3EEEE'x
dat = date('s',substr(dsnGetLev(dsn, +5), 4), 'j')
/* get file name */
call adrTso "alloc dd(afpDD) shr dsn('"dsn"')"
recs = 0
qW = ''
do while readDD(afpDD, r.)
recs = recs + r.0
do x=1 to r.0
if left(r.x, 1) ^== afp then do
if left(r.x, 4) == '@#H0' then do
id = substr(r.x, 6, 4)
q = wordPos(id, qW)
if q = 0 then do
qW = qW id
q = wordPos(id, qW)
q.q.hd = 0
q.q.tr = 0
q.q.pb = 0
q.q.pe = 0
end
q.q.hd = q.q.hd + 1
end
else if left(r.x, 4) == '@#T0' then do
q.q.tr = q.q.tr + 1
end
end
else do
if substr(r.x, 4, 3) == bpg then
q.q.pb = q.q.pb + 1
else if substr(r.x, 4, 3) == epg then
q.q.pe = q.q.pe + 1
end
end
end
call readDDend afpDD
call adrTso 'free dd(afpDD)'
ht = 0
pt = 0
do q=1 to words(qW)
call outLn left(word(qW, q),5) right(q.q.hd, 8) ,
right(q.q.pb,8) dat dsn
if q.q.hd ^= q.q.tr then
call err 'trailer' q.q.tr 'mismatch'
if q.q.pb ^= q.q.pe then
call err 'ePG' q.q.pe 'mismatch'
ht = ht + q.q.hd
pt = pt + q.q.pb
end
call outLn left('*', 5) right(ht, 8) right(pt, 8) dat dsn recs
return
endProcedure pvsCount
/* rexx ***************************************************************
test infrastructure plus tests für wr, scan (ohne adr)
***********************************************************************/
m.trace = 0
call wrIni
call vsTestAll
exit
call vsTestAll
exit
/* copy vsT begin ******************************************************
test vs: data, seq, expression, redirection, heredata
***********************************************************************/
/*--- all wr and vs tests --------------------------------------------*/
vsTestAll: procedure expose m.
call wrTestAll
call vsTest
call wrTestTotal
return
endProcedure vsTestAll
/*--- all vs tests ---------------------------------------------------*/
vsTest: procedure expose m.
call vsTestBase
call vsTestSeq
call vsTestData
call vsTestEins
return
endProcedure vsTest
/*--- initialize for a vsTest ----------------------------------------*/
vsTestIni:
call wrIni
pT = wrNew()
pR = wrNew(pT)
pC = wrNew()
return
endSubroutine vsTestIni
/*--- execute a vs Test, stem st contains source to compile ---------*/
vsTest1:
parse arg typ, st
call wrTestOut pT, 'vsTest1' typ '==>' m.st.0 'lines' m.st.1
code = vsCompile(pC, st, left(typ, 1))
say code
call outPush pT
call vsRun code
call wrClose pT
call outPop
return
endProcedure vsTest1
vsTestBase: procedure expose m.
call vsTestIni
call wrTest pT,
, "var eins Wert von Eins.",
, "$=eins=Wert von Eins",
, " line eins 1",
, " line eins 2",
, "$=zwei=defZwei /* default */",
, " line zwei",
, "$=zwei=defZwei",
, " line zwei",
, "var eins Wert von Eins, zwei defZwei, drei defDrei."
call outPush pT
call vsPut 'eins', 'Wert von Eins'
call outLn 'var eins' vsGet('eins')'.'
call vsDis 'eins', 'defEins', 'line eins 1' , 'line eins 2'
call vsDis 'zwei', 'defZwei', 'line zwei'
call vsDis 'zwei', 'defZwei', 'line zwei'
call vsDef 'drei', 'defDrei'
call outLn 'var eins' vsGet('eins')', zwei' vsGet('zwei'),
|| ', drei' vsGet('drei')'.'
call outPop
call wrClose pT
return
endProcedure vsTestBase
vsTestSeq: procedure expose m.
call vsTestIni
/* assignments with stripped trailing blanks */
call wrTest pT,
, "--- vsTest1 s seqAssS ==> 8 lines $=a1=value of variable",
|| " a1.",
, "a1=<<value of variable a1.>> ",
, "a2=<<value of variable a2.>> ",
, "a3=<<value of variable a3.>> ",
, "a4=<<value of variable a4.>> ",
, "a5=<<value of variable a.5>> ",
, "a6=<<value of variable a6.>> "
call vsTest1 's seqAssS', wrArgs(t1, 0,
, '$=a1=value of variable a1.', '$$a1=<<$a1>> ',
, '$=a2= value of variable a2. ', '$$a2=<<${a2}>> ',
, '$=a3=value of variable a3.$$a3=<<$a3>> ',
, '$=a4= value of variable a4. $$a4=<<${a4}>> ',
, '$=a5=value of variable $"a.5"$$a5=<<$a5>> ',
, '$=a6= value of variable $"a6." $$a6=<<${a6}>> ')
/* rexx assingment $= | */
/* seq: pipes separated by $; */
call wrTest pT,
, "--- vsTest1 s seqAssR ==> 10 lines $=w1=warEins$=w2=warZ",
|| "wo$|$'$w1='$w1 $""""""$w1""""=""${w2}",
, "$w1=warEins ""$w1""=warZwo",
, "> st w1=warEins",
, "stem=abc aus block",
, "in Block x vX",
, "in Block x vY"
call vsTest1 's seqAssR', wrArgs(t1, 0,
, '$=w1=warEins$=w2=warZwo$|$''$w1=''$w1 $"""$w1""="${w2}',
, '', '', ' $; ', '$;$;$; ',
, '$|$"> st w1=$w1"',' $>stem=st $;$;$<$stem=st$;',
, ' $:{x="vX" $| "in Block x" x',
, ' x="vY" $| "in Block x" x $:} $>stem=abc $;',
, ' $| "stem=abc aus block" $; $<stem=abc')
/* rExpr */
call wrTest pT,
, "--- vsTest1 s seqRExpr ==> 5 lines $| ""eins"" , ",
, "eins zwei drei",
, "vier",
, "6abc4d5 13"
call vsTest1 's seqRExpr', wrArgs(t1, 0,
, '$| "eins" , ', ' "zwei" , ', '"drei" ',
, 'call outLn "vier"',
, '$| 1+2+3$"a"$"b"$''c''4''d''5 $"7"+6')
return
endProcedure vsTestSeq
vsTestData: procedure expose m.
call vsTestIni
/* data: sExpr ! block with partial line semantics */
call wrTest pT,
, "--- vsTest1 d dataSExpr ==> 5 lines und wie 4*5=$(4*5$),",
, "und wie 4*5=20,",
, "v1=",
, "vEins ",
, " v2=vZwei und leerZeile",
, " ",
, "und SchlussvEinsvZwei."
call vsTest1 'd dataSExpr', wrArgs(t1, 0,
, 'und wie 4*5=$(4*5$),',
, 'v1=$:{ $=v1=vEins$:}$v1 ',
, ' $:{ $=v2=vZwei$:} ',
'v2=${v2} und leerZeile', ' ', 'und Schluss$v1$v2.')
/* pipe with input redirection */
call wrTest pT,
, "--- vsTest1 d dataInp ==> 9 lines $:{ m.a.1=""a.1 eins"";m",
|| ".a.2=""a.2 zwei"";m.a.0=2 $;",
, "out O",
, "a.1 eins",
, "a.2 zwei",
, "drei out O",
, "out P",
, "a.1 eins",
, "a.2 zwei",
, "sechs out P"
call vsTest1 'd dataInp', wrArgs(t1, 0,
, '$:{ m.a.1="a.1 eins";m.a.2="a.2 zwei";m.a.0=2 $;',
, '$>stem=O $<stem=A $; $>>stem=O $| "drei out O"$;',
, '$>stem=P $<stem=A $| "sechs out P"$;',
, '$<<eof1 ', 'out O', 'eof1 $<stem=O ',
, '$<<eof2 ', 'out P', 'eof2 $<stem=P $:}')
/* input redirection with $ ==> interpret as data */
call wrTest pT,
, "--- vsTest1 d dataInpS ==> 17 lines $:{ $=v1=varEins$=v2=v",
|| "arZwei",
, "hereData ohne $",
, "v1=$v1",
, "v2=${v2} Punkt1.",
, "hereData mit $",
, "v1=varEins",
, "v2=varZwei Punkt2.",
, "ohne Dolllar",
, "v1=$v1",
, "v2=${v2} Punkt3.",
, "mit Dolllar",
, "v1=varEins",
, "v2=varZwei Punkt3."
call vsTest1 'd dataInpS', wrArgs(t1, 0,
, '$:{ $=v1=varEins$=v2=varZwei',
, '$|$"hereData ohne $"$;',
, '$<<eof1 ', 'v1=$v1', 'v2=${v2} Punkt1.', 'eof1$;',
, '$|$"hereData mit $"$;',
, '$<<$eof2 ', 'v1=$v1', 'v2=${v2} Punkt2.', 'eof2$;' ,
, '$>stem=a$<<eof1 ', 'v1=$v1' , 'v2=${v2} Punkt3.' , 'eof1' ,
, '$;$| "ohne Dolllar"$; $<stem=a $; ',
, '$| "mit Dolllar"$; $<$stem=a$:}')
/* hereData may be nested */
call wrTest pT,
, "--- vsTest1 d dataHere ==> 14 lines $:{ $=v1=1$=v2=0$=v3=0",
|| "$;",
, "hereData1 begin v1=1 v2=0 v3=0",
, "hereData2 begin v1=1 v2=1 v3=0",
, "hereData3 only v1=1 v2=1 v3=1",
, "hereData3 only v1=1 v2=1 v3=2",
, "hereData3 only v1=1 v2=1 v3=3",
, "hereData2 end v1=1 v2=1 v3=3",
, "hereData2 begin v1=1 v2=2 v3=3",
, "hereData3 only v1=1 v2=2 v3=4",
, "hereData3 only v1=1 v2=2 v3=5",
, "hereData3 only v1=1 v2=2 v3=6",
, "hereData2 end v1=1 v2=2 v3=6",
, "hereData1 end v1=1 v2=2 v3=6"
call vsTest1 'd dataHere', wrArgs(t1, 0,
, '$:{ $=v1=1$=v2=0$=v3=0$;',
, '$<<$data1 ', 'hereData1 begin v1=$v1 v2=$v2 v3=$v3',
, '$:{do ii=1 to 2; $=v2=$($v2+1$)$;',
, '$<<$data2 ', 'hereData2 begin v1=$v1 v2=$v2 v3=$v3',
, ' $:{do jj=1 to 3; $=v3=$($v3 + 1 $) $; ',
, '$<<$data3 ',
, 'hereData3 only v1=$v1 v2=$v2 v3=$v3',
, 'data3 $; end $:} ',
, 'hereData2 end v1=$v1 v2=$v2 v3=$v3',
, 'data2 $; end $:} ',
, 'hereData1 end v1=$v1 v2=$v2 v3=$v3',
, 'data1 $:} ')
m.wrTest.pT.new.0 = 0 /* same test via stem */
call vsTest1 'd dataHere', wrArgs(t1, 0,
, '$:{ $=v1=1$=v2=0$=v3=0$;',
, '$<<data1 ', 'hereData1 begin v1=$v1 v2=$v2 v3=$v3',
, '$:{do ii=1 to 2; $=v2=$($v2+1$)$;',
, '$<<$data2 ', 'hereData2 begin v1=$v1 v2=$v2 v3=$v3',
, ' $:{do jj=1 to 3; $=v3=$($v3 + 1 $) $; ',
, '$<<$data3 ',
, 'hereData3 only v1=$v1 v2=$v2 v3=$v3',
, 'data3 $; end $:} ',
, 'hereData2 end v1=$v1 v2=$v2 v3=$v3',
, 'data2 $; end $:} ',
, 'hereData1 end v1=$v1 v2=$v2 v3=$v3',
, 'data1 $>stem=a$; $<$stem=a $:}')
return
endProcedure vsTestData
vsTestEins: procedure expose m.
call vsTestIni
call wrTest pT,
, "--- vsTest1 d eins11 ==> 3 lines $:{$=v1='eins' ",
, "v1 'eins' 12 12"
call vsTest1 'd eins11', wrArgs('cc',0, "$:{$=v1='eins' ",
, " $| 'v1' $v1 ,", " 3*4 $(3*4$) $:}")
call wrTest pT,
, "--- vsTest1 d eins12 ==> 2 lines erste Zeile $'$v1='$v1",
, " erste Zeile $v1='eins'",
, "und 2."
call vsTest1 'd eins12' ,
, wrArgs('cc',0, " erste Zeile $'$v1='$v1","und 2.")
call wrTest pT,
, "--- vsTest1 d eins13 ==> 4 lines und wie ,",
, "und wie ,",
, "und wie ""geht's"" dir$? 1+1=2| v1 war 'eins' ",
, "v1 vNeuEins v2 vZwei "
call vsTest1 'd eins13', wrArgs(t1, 0,
, 'und wie ,',
, 'und wie $"""geht''s""" dir$''$?'' 1+1=$(1+ ,', ' 1 $)| ',
'v1 war $v1 $:{$=v1=vNeuEins $=v2=vZwei$:} ' ,
, 'v1 $v1 v2 ${v2} ')
return
endProcedure vsTestEins
/* copy vsT end *****************************************************/
/* copy wrTest begin ***************************************************
test infrastructure plus tests for wr, wr io and scan
***********************************************************************/
/*--- all tests ------------------------------------------------------*/
wrTestAll: procedure
call wrTestWr
call wrTestWrFore
call wrTestIO
call wrTestScan
call wrTestTotal
return
endProcedure wrTestAll
/*--- test wr writerDescriptor nur mit stems -------------------------*/
wrTestWr: procedure expose m.
call wrIni
pT = wrNew()
call wrTest pT,
, "--- wrTestWr ==> wrIni",
, "--- writeLn eins",
, "text eins", "text eins.2", "text eins.3",
, "--- write a",
, "m.a.1: elf",
, "m.a.2: zwoelf",
, "--- writeLn 20",
, "text 20",
, "--- closing buffer"
call wrTestOut pT, 'wrTestWr ==> wrIni'
call wrTestOut pT, 'writeLn eins'
call writeLn pT, 'text eins', 'text eins.2', 'text eins.3'
m.a.1 = 'm.a.1: elf'
m.a.2 = 'm.a.2: zwoelf'
m.a.0 = 2
call wrTestOut pT, 'write a'
call write pT, a
call wrTestOut pT, 'writeLn 20'
call writeLn pT, 'text 20'
call wrTestOut pT, 'closing buffer'
call wrClose pT
call wrTest pT,
, "--- stem A ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A ==> B ==> test",
, "a.1 eins ",
, "a.2 zwei ",
, "--- stem A,A==> B strip ==> test",
, "a.1 eins",
, "a.2 zwei",
, "a.1 eins",
, "a.2 zwei"
pX = wrNew()
m.a.1 = 'a.1 eins '
m.a.2 = 'a.2 zwei '
m.a.0 = 2
call wrTestOut pt, 'stem A ==> test'
call wrFromDS pT, 'stem=A'
call wrDSFromDS pX, 'stem=B', 'stem=A'
call wrTestOut pt, 'stem A ==> B ==> test'
call wrFromDS pT, 'stem=B'
call wr2DS pX, 'stem=B strip=1'
call wrFromDS pX, 'stem=A'
call wrFromDS pX, 'stem=A'
call wrClose pX
call wrTestOut pt, 'stem A,A==> B strip ==> test'
call wrFromDS pT, 'stem=B'
call wrClose pT
return
endProcedure wrTestWr
/*--- foreground test, schreibt nur auf Bildschirm ohne Vergleich ----*/
wrTestWrFore: procedure expose m.
call wrIni
say '--- wrTestWr Foreground wr2DS dsn=*'
t = wrNew()
call wr2DS t, 'dsn=*'
call writeLn t, 'first writeln to dsn=*'
say '--- write ABC to dsn=*'
call write t, wrArgs('ABC', 0, 'ABC.1 eins', 'ABC.2','ABC.3 .')
call writeLn t, 'after write a', 'last writeln to dsn=*'
call wrClose t
say '--- wrTestWr Foreground end'
return
endProcedure wrTestWrFore
/*--- test io Funktionen auf Datasets --------------------------------*/
wrTestIO: procedure expose m.
call wrIni
pO = wrNew()
pT = wrNew()
dsnPr = 'test.out'
tst = date('s') time()
do i=0 by 1
if i>5 then
call err 'no nonExisting dataset found in' dsnPr'0..'dsn
dsn = dsnPr||i
if sysDsn(dsn) == 'DATASET NOT FOUND' then
leave
end
call wrTest pT,
, "--- allocating "dsn,
, "--- writing to "dsn,
, "--- appending to "dsn,
, "--- reading "dsn,
, "zeile eins ln "tst" ",
, "zeile zwei a.1 "tst" ",
, "zeile zwei a.2 "tst" ",
, "zeile vier ln "tst" ",
, "zeile funf app "tst" ",
, "zeile sech a.1 "tst" ",
, "zeile sieb a.2 "tst" ",
, "zeile acht app "tst" ",
, "--- sysdsn("dsn") = DATASET NOT FOUND"
call wrTestOut pT, 'allocating' dsn
call wr2DS pO, 'disp=new,catalog lrecl=35 dsn='dsn
call wrTestOut pT, 'writing to' dsn
call writeLn pO, 'zeile eins ln ' tst
call write pO, wrArgs(a, 0, 'zeile zwei a.1' tst,
, 'zeile zwei a.2' tst)
call writeLn pO, 'zeile vier ln' tst
call wrClose pO
call wrTestOut pT, 'appending to' dsn
call wr2DS pO, 'dsn='dsn 'strip=1', 'a'
call writeLn pO, 'zeile funf app' tst ' '
call write pO, wrArgs(a, 0, 'zeile sech a.1' tst ' ',
, 'zeile sieb a.2' tst)
call writeLn pO, 'zeile acht app' tst ' '
call wrClose pO
call wrTestOut pT, 'reading' dsn
call wrFromDs pT, 'dsn='dsn 'disp=old,delete'
call wrTestOut pT, 'sysdsn('dsn') =' sysdsn(dsn)
call wrClose pT
return
endProcedure wrTestIO
/*--- test scan ------------------------------------------------------*/
wrTestScan: procedure
call wrIni
t = wrNew()
call wrTest t,
, "--- scan src a034,Und hr123sdfER""st1"" 'str2''mit''apo''s",
|| "' ",
, "scan name tok a034 key M.S.KEY val M.S.VAL",
, "scan char tok , key M.S.KEY val ",
, "scan name tok Und key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan name tok hr123sdfER key M.S.KEY val ",
, "scan string quo tok ""st1"" key M.S.KEY val st1",
, "scan space 1 tok key M.S.KEY val ",
, "scan string apo tok 'str2''mit''apo''s' key M.S.KEY val st",
|| "r2'mit'apo's",
, "scan space 4 tok key M.S.KEY val "
call wrSc1 ,"a034,Und hr123sdfER""st1"" 'str2''mit''apo''s' "
call wrClose t
call wrTest t,
, "--- scan src litEinsefr 23 sdfER'str1'litZwei ""str2""""mi",
|| "t quo""s ",
, "scan literal tok litEins key M.S.KEY val ",
, "scan name tok efr key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan number tok 23 key M.S.KEY val ",
, "scan space 1 tok key M.S.KEY val ",
, "scan name tok sdfER key M.S.KEY val ",
, "scan string apo tok 'str1' key M.S.KEY val str1",
, "scan literal tok litZwei key M.S.KEY val str1",
, "scan space 1 tok key M.S.KEY val ",
, "scan string quo tok ""str2""""mit quo"" key M.S.KEY val st",
|| "r2""mit quo",
, "scan name tok s key M.S.KEY val str2""mit quo",
, "scan space 1 tok key M.S.KEY val "
call wrSc1 ,"litEinsefr 23 sdfER'str1'litZwei ""str2""""mit quo""s "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key aha val aha;+-=f",
, "scan keyValue tok cdEf key ab val cdEf",
, "scan keyValue tok 'strIng' key eF val strIng",
, "scan no word tok key eF val "
call wrSc1 w 0 0," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key AHA val AHA;+-=F",
, "scan keyValue tok cdEf key AB val cdEf",
, "scan keyValue tok 'strIng' key EF val strIng",
, "scan no word tok key EF val "
call wrSc1 w 1 0," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan src aha;+-=f ab=cdEf eF='strIng' ",
, "scan word tok aha;+-=f key aha val aha;+-=f",
, "scan keyValue tok cdEf key ab val CDEF",
, "scan keyValue tok 'strIng' key eF val strIng",
, "scan no word tok key eF val "
call wrSc1 w 0 1," aha;+-=f ab=cdEf eF='strIng' "
call wrClose t
call wrTest t,
, "--- scan 3 Zeilen mit nextLine",
, "name erste",
, "space",
, "name Zeile",
, "space",
, "nextLine",
, "nextLine",
, "space",
, "name dritte",
, "space",
, "name Zeile",
, "space",
, "name schluss",
, "space"
call wrArgs a, 0, 'erste Zeile ',,' dritte Zeile schluss '
call scanStem s, a
call wrTestOut t, 'scan 3 Zeilen mit nextLine'
do forever
if scanName(s) then call writeLn t, 'name' m.s.tok
else if scanVerify(s, ' ') then call writeLn t, 'space'
else if scanNL(s) then call writeLn t, 'nextLine'
else leave
end
call wrClose t
call wrTest t,
, "--- scan 3 Zeilen mit spaceLn",
, "name erste",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name dritte",
, "spaceLn",
, "name Zeile",
, "spaceLn",
, "name schluss",
, "spaceLn"
call scanStem s, a
call wrTestOut t, 'scan 3 Zeilen mit spaceLn'
do forever
if scanName(s) then call writeLn t, 'name' m.s.tok
else if scanSpaceLn(s) then call writeLn t, 'spaceLn'
else leave
end
call wrClose t
return
endProcedure wrTestScan
/*--- one single test scan with lines to scan in stem ln -------------*/
wrSc1:
parse arg fun o1 o2, ln
call wrTestOut t, 'scan src' ln
call scanBegin s, ln
do while ^scanAtEnd(s)
if fun = w then do
if scanKeyValue(s, o1, o2) then o = 'keyValue '
else if scanword(s, o1) then o = 'word '
else o = 'no word '
end
else if scanLit(s, 'litEins') then o = 'literal '
else if scanLit(s, 'litZwei') then o = 'literal '
else if scanName(s) then o = 'name '
else if scanString(s) then o = 'string apo'
else if scanString(s, '"') then o = 'string quo'
else if scanNum(s) then o = 'number '
else if scanVerify(s, ' ') then o = 'space' length(m.s.tok)
else if scanChar(s,1) then o = 'char '
else call scanErr s 'not scanned'
call writeLn t, 'scan' o 'tok' m.s.tok 'key' m.s.key ,
'val' m.s.val
end
return
endProcedure wrSc1
/***********************************************************************
test writer infrastructure
***********************************************************************/
/*--- make writerDescriptor m a testWriter
--- and use remaining lines as compare values -----------------*/
wrTest: procedure expose m.
parse arg m
call wriClo m, 'call wrTestWrite' m ', stem', 'call wrTestClose' m
ox = 0
do ax=2 to arg()
ox = ox + 1
m.wrTest.m.ox = arg(ax)
end
m.wrTest.m.0 = ox
m.wrTest.m.new.0 = 0
m.wrTest.m.err = 0
if symbol("m.wrTest.err") ^= 'VAR' then
m.wrTest.err = 0
return
endProcedure wrTest
/*--- write to test: say lines and compare them ----------------------*/
wrTestWrite: procedure expose m.
parse arg m, stem
nx = m.wrTest.m.new.0
do ix=1 to m.stem.0
nx = nx + 1
m.wrTest.m.new.nx = m.stem.ix
say 'testOut' m.stem.ix
if nx > m.wrTest.m.0 then do
if nx = m.wrTest.m.0 + 1 then
call wrTestErr m, 'more new Lines' nx
end
else if m.wrTest.m.nx ^== m.stem.ix then do
say 'old ^^^' m.wrTest.m.nx
call wrTestErr m, 'line' nx 'difference'
end
end
m.wrTest.m.new.0 = nx
return
endProcedure wrTestWrite
/*--- close test: check differences and say compare strings ----------*/
wrTestClose: procedure expose m.
parse arg m, stem
if m.wrTest.m.new.0 ^= m.wrTest.m.0 then do
call wrTestErr m, 'old' m.wrTest.m.0 'lines ^= new' ,
m.wrTest.m.new.0
do nx = m.wrTest.m.new.0 + 1 to ,
min(m.wrTest.m.new.0+10, m.wrTest.m.0)
say 'old - ' m.wrTest.m.nx
end
end
say '***' m.wrTest.m.err 'errors'
if m.wrTest.m.err > 0 then do
say 'new lines:' m.wrTest.m.new.0
len = 60
do nx=1 to m.wrTest.m.new.0
str = quote(m.wrTest.m.new.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.wrTest.m.new.0)
end
end
return
endProcedure wrTestClose
/*--- write a single test message ------------------------------------*/
wrTestOut: procedure expose m.
parse arg m, msg
call writeLn m, '---' msg
return
endProcedure wrTestOut
/*--- say total errors and fail if not zero --------------------------*/
wrTestTotal: procedure expose m.
if m.wrTest.err = 0 then
say m.wrTest.err 'errors total'
else
call err m.wrTest.err 'errors total'
return
endProcedure wrTestTotal
/*--- test err: message, count it and continue -----------------------*/
wrTestErr: procedure expose m.
parse arg m, msg
say '*** error' msg
m.wrTest.m.err = m.wrTest.m.err + 1
m.wrTest.err = m.wrTest.err + 1
return
endProcedure wrTestErr
/* copy wrTest end **************************************************/
/* rexx ***************************************************************
test infrastructure plus tests für wr, scan (ohne adr)
***********************************************************************/
parse arg args
call wrIni
call outLn '--- begin VS with' args
call vsKeyValue args, 1, 1
call outPush wr2DS(wrNew(), 'dd=vsOut')
call vsRun vsCompile(wrNew(), 'dd=vsIn')
call outPop
call outLn '--- end VS with' args
exit 0
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
/* copy vs begin ****************************************************/
/*--- get the value of a $-variable, fail if undefined ---------------*/
vsGet: procedure expose m.
parse arg name, s
if symbol('m.var.name') == 'VAR' then
return m.var.name
else
call err 'var' name 'not defined'
endProcedure vsGet
/*--- put (store) the value of a $-variable --------------------------*/
vsPut: procedure expose m.
parse arg name, value
m.var.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure vsPut
/*--- set variable name to default def if undefined ------------------*/
vsDef: procedure expose m.
parse arg name, def
if symbol('m.var.name') == 'VAR' then
return 0
m.var.name = def
return 1
endProcedure vsDef
/*--- set variable name to defau def if undefined
display value and arguments 3.. ------------------------------*/
vsDis: procedure expose m.
parse arg name, def
msg = ''
if def ^== '++' then
if vsDef(name, def) then
msg = ' /* default */'
call outLn '$='name'='vsGet(name)msg
do i=3 to arg()
call outLn ' ' arg(i)
end
return
endProcedure vsDis
/*--- set variables from string with key=value pairs -----------------*/
vsKeyValue: procedure expose m.
parse arg src, uk, uv
sc = 'VS.KEYVALUE'
call scanBegin sc, src
do while scanKeyValue(sc, uk==1, uv==1)
call vsPut m.sc.key, m.sc.val
end
if ^ scanAtEOL(sc) then
call scanErr sc, 'hier sollte key=value stehen'
return
endProcedure vsKeyValue
/*--- run the code created by vsCompile ------------------------------*/
parse arg rexx
if m.wr.trace then
say 'interpreting' rexx
interpret rexx
if m.wr.trace then
say 'interpreted'
return
endProcedure vsRun
/*--- work in writerDescriptor m to compile the vs-Source in aStem
as typ d=data or s=sequence and return rexx code
aStem is either a stem or a dss ---------------------------*/
vsCompile: procedure expose m.
parse arg m, aStem, typ
st = aStem
if pos('=', aStem) > 0 then do
st = 'VS.COMPILE.'m
call wrDSFromDS m, 'stem='st, aStem
end
if m.wr.trace == 1 then
call wrFromDS m.wr.sysout, 'stem='st
call scanStem m, st
m.rs.m.rExprCont = m.scan.alnum || """'@#$.?"
if typ == 's' then
code = vscSeq(m, st)
else
code = vscData(m, st)
if scanAtEnd(m) then
return code
else if typ == 's' then
call scanErr m, 'sequence (statement or "$;") expected'
else
call scanErr m, 'data (sExpression or block) expected'
endProcedure vsCompile
/*--- data = (sExpr ! block ! nl)* with partial line semantics -------*/
vscData: procedure expose m.
parse arg m, stem
code = ''
do forever
bx = m.scan.m.pos
ex = vscSExpr(m,,0)
eol = scanAtEol(m)
if ex ^== '' then do
if (bx = 1 & eol) then
code = code'; call outLn' ex /* complete line */
else if substr(m.scan.m.src, bx, m.scan.m.pos-1) ^= '' then
code = code'; call outLn' ex /* not space */
end
else if eol then do
if ^ scanNL(m) then
return vscStrip(code)
end
else do
bl = vscBlock(m)
if bl == '' then
return vscStrip(code)
code = code';' bl
end
end
endProcedure vscData
/*--- strip generated code of leading semicolons ---------------------*/
vscStrip: procedure
parse arg orig
vx = verify(orig, '; ')
if vx > 0 then
return substr(orig, vx)
else /* Achtung '' und ' ' nicht vermischen | */
return left(' ', length(orig) > 0)
endProcedure vscStrip
/*--- run the code created by vsCompile ------------------------------*/
vsRun: procedure expose m.
parse arg rexx
if m.wr.trace then
say 'interpreting' rexx
interpret rexx
if m.wr.trace then
say 'interpreted'
return
endProcedure vsRun
/*--- compile a block = '$:{' seq '$:}' ------------------------------*/
vscBlock: procedure expose m.
parse arg m, seqOnly
if ^ scanLit(m, '$:{') then
return ''
code = vscSeq(m)
if ^ scanLit(m, '$:}') then
call scanErr m, 'closing $:} missing'
return code' ' /* donot return '', we found a block | */
endProcedure vscBlock
/*--- compile a Sequence = '(stmt ! '$;')* ---------------------------*/
vscSeq: procedure expose m.
parse arg m
code = ''
call scanSpaceLn m
do forever
if scanLit(m, '$;') then do
call scanSpaceLn m
end
else do
one = vscStmt(m)
if one == '' then
return vscStrip(code)
code = code';' one
end
end
endProcedure vscSeq
/*--- compile a statement: (rExpr!ouput!input!ass!block)+ -----------*/
vscStmt: procedure expose m.
parse arg m
code = ''
out = ''
do forever
if scanLit(m, '$>') then do /* outputredirection */
if out ^== '' then
call scanErr m, 'duplicate output redirection'
app = scanLit(m, '>')
out = vscSExpr(m,,1)
if out == '' then
call scanErr m,
, "output redirection without sExpression"
wx = wrNew()
out = 'call wr2DS' wx',' out
if app then
out = out', "a"'
out = out '; call outPush' wx
end
else do /* other statements */
one = vscInput(m) /* input redirection */
if one = '' then one = vscAss(m) /* assignment */
if one = '' then one = vscBlock(m) /* block */
if one = '' then one = vscRExpr(m) /* rexx statements */
if one = '' then
leave
code = code';' one
end
call scanSpaceLn m
end
if out == '' then
return vscStrip(code)
else
return out';' vscStrip(code)'; call outPop'
endProcedure vscStmt
/*--- input: $$ sExprS ! $| rExpr ! $<... ! $<<... ----------------*/
vscInput: procedure expose m.
parse arg m
if scanLit(m, '$|') then /* input rexx expression */
return 'call outLn' vscRExpr(m)
else if scanLit(m, '$$') then /* input shell expression */
return 'call outLn' vscSExpr(m,,0)
else if ^ scanLit(m, '$<') then
return ''
hereData = scanLit(m, '<')
dol = scanLit(m, "$")
if ^ hereData then do /* $< DSS */
dss = vscSExpr(m,,1)
if dss == '' then
call scanErr m, "input redirection without sExpression"
if dol then /* compile dss */
return 'call vsRun vsCompile('wrNew()',' dss')'
else /* output dss */
return 'call outDS' dss
end
/* $<< hereData */
if ^ scanVerify(m, ' ', 'm') then
call scanErr m, '$<< delimiter expected'
delim = m.m.tok
call scanVerify m, ' '
if ^scanAtEol(m) then
call scanErr m, 'rest of line must be empty'
ox = 0
dx = wrNew()
stem = 'WR.DATA.'dx /* get data to stem */
do forever
if ^scanNextLine(m) then
call scanErr m, 'no matching delimiter for $<<'delim
if scanLit(m, delim) then
leave
ox = ox + 1
m.stem.ox = m.scan.m.src
end
m.stem.0 = ox
if dol then
return 'do;' vsCompile(dx, stem) '; end' /* compile stem */
else
return 'call outDS' quote('stem='stem) /* output stem */
endProcedure vscHereData
/*--- assignent statemt $=...=... ------------------------------------*/
vscAss: procedure expose m.
parse arg m
if ^ scanLit(m, '$=') then
return ''
nam = vscSExpr(m, '=|', 1)
if scanLit(m, '|') then
return 'call vsPut' nam',' vscRExpr(m)
else if scanLit(m, '=') then
return 'call vsPut' nam',' vscSExpr(m,,1)
else
call scanErr m, '= or | missing after $= in assignment'
endProcedure vscAss
/*--- shell expression (text ! sub)+ -------------------------------*/
vscSExpr: procedure expose m.
parse arg m, stp, strip
code = ''
if strip == 1 then
call scanVerify m, ' '
do forever
call scanVerify m, "$"stp, 'm'
str = m.m.tok
sub = vscSub(m)
if sub == '' then
leave
if str == '' then
code = code '||' sub
else
code = code '||' quote(str) '||' sub
end
if strip == 1 then do
str = strip(str, 't')
call scanVerify m, ' ' /* if stp contains a space */
end
if str ^== '' then
code = code '||' quote(str)
if code == '' then
return ''
else
return substr(code, 5) /* drop leading ' || ' */
endProcedure vscSExpr
/*--- rexx expression (text ! sub ! ',' ' '* nl rExpr)* -----------*/
vscRExpr: procedure expose m.
parse arg m, stp
code = ''
do forever
if scanAtEOL(m) then do
str = strip(code, 't')
if right(str, 1) ^== ',' then
return str
code = strip(left(str, length(str) - 1))' '
if ^ scanNL(m) then
return code
end
else do
if scanVerify(m, "$"stp, 'm') then do
nn = m.m.tok
end
else do
nn = vscSub(m)
if nn == '' then
return code
end
/* now the tricky stuff: */
if nn = '' then /* is a space or || needed */
code = code' ' /* between old and new code? */
else if right(nn, 1) == ' ' then
nn = strip(nn, 't')' '
if pos(left(nn, 1), m.rs.m.rExprCont) = 0 then
code = code || nn
else if pos(right(code, 1), m.rs.m.rExprCont) = 0 then
code = code || nn
else
code = code '||' nn
end
end
endProcedure vscRExpr
/*--- compile a substitution: '$'string ! '$('rExpr')'
! '$'name ! '${'sExpr'}' ---------------*/
vscSub: procedure expose m.
parse arg m
bx = m.scan.m.pos
if ^ scanLit(m, "$") then
return ''
else if scanLit(m, '{') then do
sub = vscSExpr(m, '}', 1)
if sub == '' then
call scanErr m, 'sExpr exptected'
if ^ scanLit(m, '}') then
call scanErr m, 'closing brace (}) missing'
return 'vsGet(' || sub || ')'
end
else if scanLit(m, '(') then do
sub = vscRExpr(m)
if ^scanLit(m, '$)') then
call scanErr m, 'closing $) missing'
return '(' || sub || ')'
end
else if scanString(m, "'") then do
return m.m.tok
end
else if scanString(m, '"') then do
return m.m.tok
end
else do
if ^ scanName(m) then do
m.scan.m.pos = bx
return ''
end
return 'vsGet(' || quote(m.m.tok) || ')'
end
endProcedure vscSub
/* copy vs end ****************************************************/
/* copy scan begin ****************************************************
Scan: scan an input:
scanBegin(m,ln): set scan Source to ln
scanAtEnd(m) : returns whether we reached end of line already
scanLit(m,lit) : scan Literal lit if present or return 0
scanChar(m,n) : scan next n characters
scanName(m) : scan a name
scanNum(m) : scan integer (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.m.key ==> key for scanKeyValue
m.scan.m.pos ==> scan position
m.scan.m.src ==> scan source
***********************************************************************/
/*--- begin scanning a single line aSrc ------------------------------*/
scanBegin: procedure expose m.
parse arg m, m.scan.m.src, m.scan.m.reader
m.scan.m.pos = 1
m.scan.m.tok = ''
m.scan.m.val = ''
if symbol('m.scan.m.Name') ^== 'VAR' then do
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
end
return
endProcedure scanBegin
/*--- return true/false whether we are at the end of the line --------*/
scanAtEOL: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src)
endProcedure scanAtEOL
/*--- return true/false whether we are at the end of the input -------*/
scanAtEnd: procedure expose m.
parse arg m
return m.scan.m.pos > length(m.scan.m.src) & m.scan.m.reader == ''
endProcedure scanAtEnd
/*--- scan len characters --------------------------------------------*/
scanChar: 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
m.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 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.m.tok = lit
return 1
endProcedure scanLit
/*--- scan a string with quote char qu -------------------------------*/
scanString: procedure expose m.
parse arg m, qu
m.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.m.val = m.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.m.val = m.m.val || qu
end
m.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.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.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 number --------------------------------------------------*/
scanNum: 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 scanNum
/*--- scan a word (space delimited or string)
put value into *.val, upercased if uc=1 and not string ---------*/
scanWord: procedure expose m.
parse arg m, uc
call scanVerify m, ' '
if scanString(m, "'") then return 1
else if scanString(m, """") then return 1
else
res = scanVerify(m, ' ', 'm')
m.m.val = m.m.tok
if uc ^== 0 then
upper m.m.val
return res
endProcedure scanWord
/*--- scan a key = word phrase
put key into *.key (uppercase if uk) and word into val -------*/
scanKeyValue: procedure expose m.
parse arg m, uk, uv
bx = m.scan.m.pos
call scanVerify m, ' '
if scanName(m) then do
m.m.key = m.m.tok
if uk ^== 0 then
upper m.m.key
call scanVerify m, ' '
if scanLit(m, '=') then do
call scanWord m, uv
return 1
end
end
m.scan.m.pos = bx
return 0
endProcedure scanKeyValue
/*--- emit an error with current scan pos ----------------------------*/
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
say ' last token' m.scan.m.tok
say ' charPos' m.scan.m.Pos':',
strip(substr(m.scan.m.src, m.scan.m.Pos), 't')
say ' in line:' strip(m.scan.m.src, 't')
if symbol('m.scan.m.lineinfo') == 'VAR' then
interpret 'say " lineinfo:" ('m.scan.m.lineinfo')'
call err 'scanErr' txt
endProcedure scanErr
/*--- begin to scan all lines of stem st -----------------------------*/
scanStem: procedure expose m.
parse arg m, st
m.scan.m.liSt = st
m.scan.m.liX = 0
m.scan.m.lineInfo = "'stem m.' ||" quote(st) "|| '.'m.scan.m.liX"
return scanNextLine(m)
endProcedure scanStem
/*--- if at NL start next Line if possible otherwise return false ----*/
scanNL: procedure expose m.
parse arg m
if m.scan.m.reader == '' | m.scan.m.pos <= length(m.scan.m.src) then
return 0
return scanNextLine(m)
endProcedure scanNL
/*--- start next line, return false if no more lines -----------------*/
scanNextLine: procedure expose m.
parse arg m
st = m.scan.m.liSt
lx = m.scan.m.liX + 1
if lx > m.st.0 then do /* avoid scan errors | */
call scanBegin m, '<end of file, m.'st'.0 =' m.st.0'>'
m.scan.m.pos = 1+length(m.scan.m.src) /* ensure we are at eof */
return 0
end
m.scan.m.liX = lx
call scanBegin m, m.st.lx, 1
return 1
endProcedure scanNL
/*--- skip over space and NL (NewLines) ------------------------------*/
scanSpaceLn: procedure expose m.
parse arg m
res = 0
do forever
if scanVerify(m, ' ') then nop
else if ^ scanNL(m) then return res
res = 1
end
endProcedure scanSpace Ln
/* copy scan end ****************************************************/
/* copy wr begin *****************************************************
out interface
define a current output destination (a writerDescriptor)
manage them in a stack
convenience function to write to current output
***********************************************************************/
/*--- write stem stem to current output ------------------------------*/
out: procedure expose m.
parse arg stem
call write m.wr.out, stem
return
endProcedure
/*--- write up to 3 strings to current output ------------------------*/
outLn: procedure expose m.
parse arg m.wr.outLn.1, m.wr.outLn.2, m.wr.outLn.3
m.wr.outLn.0 = arg()
call write m.wr.out, 'WR.OUTLN'
return
endProcedure
/*--- write to current output from datasetSpec dss -------------------*/
outDS: procedure expose m.
parse arg dss
call wrFromDS m.wr.out, dss
return
endProcedure outDS
/*--- redirect current output ----------------------------------------*/
outPush: procedure expose m.
parse arg o
x = m.wr.out.0 + 1
m.wr.out.0 = x
m.wr.out.x = m.wr.out
if o == '*' then
m.wr.out = m.wr.sysout
else
m.wr.out = o
return
endProcedure outPush
/*--- redirect current output to previous ----------------------------*/
outPop: procedure expose m.
parse arg o
x = m.wr.out.0
m.wr.out.0 = x - 1
m.wr.out = m.wr.out.x
return
endProcedure outPop
/**********************************************************************
writer interface
a writerDescriptor wx is allocated with wrNew
we can define the write and wrClose functionality arbitrarily
***********************************************************************/
/*--- create a new writeDescriptore ----------------------------------*/
wrNew: procedure expose m.
parse arg oo, atts
nn = m.wr.new + 1
m.wr.new = nn
return nn
endProcedure wrNew
/*--- for writeDescriptor m define write and close -------------------*/
wriClo: procedure expose m.
parse arg m, m.wr.write.m, m.wr.close.m, wr2
if wr2 ^== '' then
m.wr.write.m = "do ggLX=1 to m.stem.0; line = stem'.'ggLx;" ,
m.wr.write.m '; end;' wr2
return m
endProcedure wriClo
/*--- write stem m.stem. to writeDescriptor m ------------------------*/
write: procedure expose m.
parse arg m, stem
interpret m.wr.write.m
return
endProcedure write
/*--- write up to 3 strings to writeDescriptor m ---------------------*/
writeLn: procedure expose m.
parse arg m, m.wr.writeln.m.1, m.wr.writeln.m.2, m.wr.writeln.m.3
m.wr.writeln.m.0 = arg()-1
call write m, 'WR.WRITELN.'m
return
endProcedure writeLn
/*--- close writeDescriptor m ----------------------------------------*/
wrClose: procedure expose m.
parse arg m
interpret m.wr.close.m
return
endProcedure wrClose
/*--- initialisation writer and output -------------------------------*/
wrIni: procedure expose m.
parse arg tr
m.wr.trace = tr = 1
m.wr.new = 0
so = wrNew()
sy = 'say m.stem.ix'
if m.wr.trace then
sy = 'say "sysout:" quote(m.stem.ix)'
m.wr.sysOut = wriClo(wrNew(), 'do ix=1 to m.stem.0;' sy ';end')
m.wr.out = m.wr.sysOut
m.wr.out.0 = 0
return
endProcedure wrIni
/**** simple convience function for stems *****************************/
/*--- fill stem st from index dx with lines from stem src ------------*/
wrStem: procedure expose m.
parse arg dst, dx, src
if dx == '' then
dx = m.dst.0
do ix = 1 to m.src.0
dx = dx + 1
m.dst.dx = m.src.ix
end
m.dst.0 = dx
return dst
endProcedure wrStem
/*--- strip trailing spaces from stem dst ----------------------------*/
wrStrip: procedure expose m.
parse arg dst
do ix=1 to m.dst.0
m.dst.ix = strip(m.dst.ix, 't')
end
return dst
endProcedure wrStrip
/*--- fill stem dst from index dx with arguments ---------------------*/
wrArgs: procedure expose m.
parse arg dst, dx
if dx == '' then
dx = m.dst.0
do ix = 3 to arg()
dx = dx + 1
m.dst.dx = arg(ix)
end
m.dst.0 = dx
return dst
endProcedure wrArgs
/***********************************************************************
Input-Ouput
transfer data betweeen stems and datasets
these are specified using a DataSetSpec DSS see wrAlloc:
***********************************************************************/
/*--- define writeDescriptor m to write to the datasetSpec dss */
wr2DS: procedure expose m.
parse arg m, dss, opt
if opt == '' then
opt = 'o'
ty = wrAlloc(m, opt, dss)
stmt = ''
if m.wr.allocStrip.m then
stmt = 'call wrStrip stem;'
if ty == 's' then do
call wriClo m,
, stmt 'call wrStem' quote(m.wr.allocStem.m) ', , stem',
, m.wr.allocFree.m
end
else if ty == 'd' then do
dd = m.wr.allocDD.m
call writeDDBegin dd
call wriClo m,
, stmt 'call writeDD' quote(dd) ', "M."'stem'"."',
, 'call writeDDEnd' quote(dd)';' m.wr.allocFree.m
end
else
call err 'wr2Ds bad allocType' ty 'from' dss
return m
endProcedure
/*--- write to writeDescriptor m from datasetSpec dss ----------------*/
wrFromDS: procedure expose m.
parse arg m, dss
if dss = '' then
call err 'wrFromDS empty datasetSpecification'
oSt = 'WR.FROMDS.'m
iTyp = wrAlloc(m, 'i', 'dd=fds'm dss)
if iTyp == 's' then do
call write m, m.wr.allocStem.m
end
else if iTyp = 'd' then do
st = 'WR.WRFROMDS.'m
dd = m.wr.allocDD.m
call readDDBegin dd
do while readDD(dd, 'M.'st'.')
call write m, st
end
call readDDEnd dd
interpret m.wr.AllocFree.m
end
else
call err 'wrFromDS: bad allocTyp' iTyp 'from' dss
return
endProcedure wrFromDS
/*--- using m, write datasetSpec frSp to datasetSpec toSp ------------*/
wrDSFromDS: procedure expose m.
parse arg m, toSP
call wr2DS m, toSp
do ax=3 to arg()
frSp = arg(ax)
if ax ^= '' then
call wrFromDs m, frSp
end
call wrClose m
return
endProcedure wrFromDS
/*----------------------------------------------------------------------
wrAlloc: allocate a file or stem from datasetSpecification dss
opt in i, o or a (input, output or append)
dss in key=value syntax, either tso alloc attributes or
dss in key=value syntax, either tso alloc attributes or
disp=...,
dsj= DatasetName in Jcl format (dsn= for tso format)
stem=xyz to allocate a stem m.xyz.*
strip=1 to strip trailing blanks before writing
----------------------------------------------------------------------*/
wrAlloc: procedure expose m.
parse arg m, opt, dss
s = 'WR.ALLOC'
m.wr.allocDD.m = ''
stem = ''
at = ''
disp = ''
m.wr.allocStrip.m = 0
m.wr.allocFree.m = ''
call scanBegin s, dss
do while scanKeyValue(s, 1, 0)
k = m.s.key
if k == 'DD' then m.wr.allocDD.m = m.s.val
else if k == 'DSJ' then at = at "dsn('"m.s.val"')"
else if k == 'STEM' then stem = m.s.val
else if k == 'DISP' then disp = m.s.val
else if k == 'STRIP' then m.wr.allocStrip.m = m.s.val
else if k == 'INTER' then inter = m.s.val
else if left(m.s.val, 1) = '(' then
at = at m.s.key || m.s.val
else at = at m.s.key"("m.s.val")"
end
call scanVerify s, ' '
if ^scanAtEOL(s) then
call scanErr s, 'wrAlloc bad clause'
if stem ^= '' then do
m.wr.allocStem.m = stem
if opt == 'o' then /* overrite existing lines */
m.stem.0 = 0
m.wr.allocType.m = 's'
end
else if at = '' then do
if m.wr.allocDD.m = '' then
call err 'dd or attribute must be specified:' dss
m.wr.allocType.m = 'd'
end
else do
m.wr.allocType.m = 'd'
if m.wr.allocDD.m = '' then
m.wr.allocDD.m = 'ALL'm
if disp ^= '' then nop
else if opt == 'a' then disp = 'mod'
else if opt == 'o' then disp = 'old'
else disp = 'shr'
if m.wr.allocApp.m = 1 then do
d3 = translate(strip(left(disp, 3)))
if d3 == 'OLD' | d3 == 'SHR' then
disp = 'mod' || substr(strip(disp), 4)
end
call adrTso "alloc dd("m.wr.allocDD.m")" disp at
m.wr.allocFree.m = 'call adrTso' ,
quote('free dd('m.wr.allocDD.m')')
end
return m.wr.allocType.m
endProcedure wrAlloc
/* copy wr end ****************************************************/
/* copy pos begin *****************************************************
StringHandling
posRep: return the index of rep'th occurrence of needle
posLev: return n'th level (separated by needle)
posCnt: count the occurrences of needle
***********************************************************************/
/*--- return the index of rep'th occurrence of needle
negativ rep are counted from right -------------------------*/
posRep: procedure
parse arg needle, hayStack, rep, start
if rep > 0 then do
if start = '' then
start = 1
do cc = 1 to rep
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return sx
end
else if rep < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -rep
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return sx
end
else
return 0
endProcedure posRep
/*--- return n'th level (separated by needle, negative from right) ---*/
posLev: procedure
parse arg needle, hayStack, rep, start
if rep > 1 then do
sx = posRep(needle, hayStack, rep-1, start)
if sx < 1 then
return 0
return 1+sx
end
else if rep < -1 then do
sx = posRep(needle, hayStack, rep+1, start)
if sx < 1 then
return 0
return 1+lastPos(needle, hayStack, sx-1)
end
else if rep ^= -1 then
return rep /* for 0 and 1 */
else if start == '' then /* pos fails with empty start| */
return 1 + lastPos(needle, hayStack)
else
return 1 + lastPos(needle, hayStack, start)
endProcedure posLev
/*--- 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)
cnt = 0
do forever
start = pos(needle, haystack, start)
if start < 1 | start > fin then
return cnt
cnt = cnt + 1
start = start + length(needle)
end
endProcedure posCount
/*--- concatenate several parts to a dsn -----------------------------*/
dsnApp: procedure
parse arg parts
dsn = ''
do wx=1 by 1
w = word(parts, wx)
if w = '' then
leave
do while w <> ''
if pos(right(w, 1), "') ") <= 0 then
leave
w = left(w, length(w)-1)
end
dsn = dsn || w
end
if pos('(', dsn) > 0 then
dsn = dsn')'
if left(dsn,1) = "'" then
return "'"strip(dsn, 'b', "'")"'"
else
return dsn
endProcedure dsnApp
/*--- set the membername mbr into dsn --------------------------------*/
dsnSetMbr: procedure
parse arg dsn, mbr
mbr = strip(mbr)
bx = pos('(', dsn)
if mbr = '' then do
if bx < 1 then
return dsn
else if left(dsn, 1) = "'" then
return left(dsn,bx-1)"'"
else
return left(dsn,bx-1)
end
else do
if bx < 1 then
return dsnApp(dsn '('mbr)
else
return dsnApp(left(dsn, bx) mbr)
end
endProcedure dsnSetMbr
/*--- get the membername from dsn ------------------------------------*/
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), 't', "'")
endProcedure dsnGetMbr
/*--- get the index of the lx'd level of dsn -------------------------*/
dsnPosLev: procedure
parse arg dsn, lx
sx = posLev('.', dsn, lx)
if sx ^= 1 then
return sx
else
return 1 + (left(dsn, 1) == "'")
endProcedure dsnPosLev
/*--- get the the lx'd level of dsn ----------------------------------*/
dsnGetLev: procedure
parse arg dsn, lx
sx = dsnPosLev(dsn, lx)
if sx < 1 then
return ''
ex = pos('.', dsn, sx)
if ex < 1 then do
ex = pos('(', dsn, sx)
if ex < 1 then
return substr(dsn, sx)
end
return substr(dsn, sx, ex-sx)
endProcedure dsnGetLev
/* copy pos 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
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 showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') shr dsn('grp'.datasets)'
end
else do
call trc 'no datasets found' showTime() 'lmdlist save' grp lev
call adrTso 'alloc dd('grp') dummy'
end
call readDDBegin grp
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readDD(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readDDEnd grp
call adrTso 'free dd('grp')'
return /* end lmdEnd */
/**********************************************************************
member list of a pds:
call sequence x=lmmBegin(dsn) lmmNext(x) * lmmEnd(x)
***********************************************************************/
lmmTest: procedure
parse arg dsn
if dsn = '' then
dsn = 'wk.pli(*)'
say 'lmmTest for dsn' dsn
id = lmmBegin(dsn)
do ix=1 by 1
m = lmmNext(id)
if m = '' then
leave
say ix m
end
call lmmEnd id
say 'lmmTest end' (ix-1) 'members in' dsn
return
endProcedure lmmTest
lmmBegin: procedure
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')'
say 'lmmBegin returning' res
return res
endProcedure lmmBegin
lmmEnd: procedure
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
parse arg lmmId opt
if adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt, 4 8) = 0 then
return mbr
else
return ''
endProcedure lmmNext
/**********************************************************************
adrSql: execute sql thru the dsnRexx interface
***********************************************************************/
adrSqlRc: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if ggNo <> '1' then
ggSqlStmt = 'execSql' ggSqlStmt
address dsnRexx ggSqlStmt
if rc = 0 then
return 0 /* say "sql ok:" ggSqlStmt */
else if rc < 0 then
call err "sql rc" rc sqlmsg()
if sqlCode = 0 then
say 'warning' sqlMsg()
return sqlCode
endSubroutine adrSqlRc
adrSql: /* no procedure, to keep variables sql... */
parse arg ggSqlStmt, ggNo
if adrSqlRc(ggSqlStmt, ggNo) = 0 then
return
call err "sql rc" rc sqlmsg()
endSubroutine adrSql
adrSqlConnect: procedure
parse arg sys
if adrTSORc("SUBCOM DSNREXX") <> 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
call adrSql "connect" sys, 1
return
endProcedure adrSqlConnect
adrSqlDisconnect: procedure
call adrSql "disconnect ", 1
return
endProcedure adrSqlDisconnect
sqlMsg: /* no procedure, to keep variables sql... */
ggW = ''
do ggX=0 to 10
if sqlWarn.ggx <> '' then
ggw = ggw ggx'='sqlWarn.ggx
end
return 'sqlCode' sqlCode 'state' sqlState 'warn' ggW ,
'errMc' strip(translate(sqlerrmc, ',', 'FF'x))':' ggSqlStmt
endSubroutine sqlMsg
/**********************************************************************
adrDsn: send a command to db2 with the TSO dsn command
***********************************************************************/
adrDsn: procedure
parse arg sys, cmd, rcOk
call adrTso 'alloc dd(sysprint) new reuse'
push 'END'
push cmd
rr = adrTsoRc('DSN SYSTEM('sys')')
say 'rc' rr 'adrTso DSN SYSTEM('sys') cmd' cmd
if wordPos(rr, rcOk) < 1 then do
say 'error rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
call adrTso 'execio * diskr sysprint (finis stem pr.)'
say 'sysprint' pr.0 'lines'
do x=1 to pr.0
say strip(pr.x, 't')
end
call adrTso 'free dd(sysprint) '
call err 'rc' rr 'in adrTso DSN SYSTEM('sys') cmd' cmd
end
call adrTso 'free dd(sysprint)'
return rr
endProcedure adr Dsn
/**********************************************************************
adr*: address an environment
***********************************************************************/
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 'for' ggIspCmd
endSubroutine adrIsp
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 adr begin ****************************************************/
/**********************************************************************
dsn*: manipulate dataSetNames
dsn2Jcl: convert from tso to JCL format
dsnFromJcl: convert from jcl to TSO format
dsnPosLev: get the index of first char of level
(negativ levels are counted from the right)
dsnGetMbr: get the Member name from a dsn
dsnApp: cleanup and append dsn parts (preserve apos ...)
dsnSetMbr: set a Member name or remove it if mbr = ''
dsnTemp return the name of a temporary dataset
dsnGetLLQ ==> dsnGetLev(..., -1) depreciated
***********************************************************************/
dsn2jcl: procedure
parse arg dsn .
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
else if sysvar('SYSPREF') = '' then
return dsn
else
return sysvar('SYSPREF')'.'dsn
endProcedure dsn2Jcl
dsnFromJcl: procedure
parse arg dsn .
return "'"dsn"'"
endProcedure dsnFromJcl
/**********************************************************************
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 */
/*--- 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 */
/* copy adr end ****************************************************/
/* copy err begin *****************************************************
messages, errorhandling,help
***********************************************************************/
/* caller should define err as follows ---------------------------------
err:
parse arg ggMsg
call errA ggMsg
exit 12
endSubroutine err
end call should define err ----------------------------------------*/
/*--- error routine: abend with message ------------------------------*/
errA:
parse arg ggTxt
parse source . . ggS3 . /* current rexx */
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine errA
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure
parse arg ggMsg
say 'fatal error:' 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 zIspfRc
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
parse arg showmsg
return time() sysvar('syscpu') /* sysvar('syssrv') */ showmsg
/--- display the first comment block of the source as help -----------*/
help: procedure
parse source . . s3 .
say 'help for rexx' s3
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
return 4
endProcedure help
/* copy err end ****************************************************/