zOs/REXX.O13/PVSRWGRJ
/* REXX ****************************************************************
PVSRWGRJ JES-Output WGR project PRIMO
synopsis: PVSRWGRJ [-?] [-T] [env oldDsn]
-? this help
-T with trace
env Environment (TEST or PROD used in Skeleton Expansion)
oldDsn DSN of original Dataset
Function: analyse input AFP file (DD AFP),
write a variMember, a Mail text and a log Message
from skeletons and
write an IMM Record (if variable COPYGROUP is not empty)
Test: In foreground if oldDsn is empty,
the necessary files are allocated
Files (must be preallocated)
DD AFP AFP Input file (if analyseAFP is called from skeleton)
DD VARIIN input Skeleton for VariMember
DD VARI output VariMember
DD MAILIN input Skeleton for Mail
DD MAIL output Mail
DD LOGIN input Skeleton for Log
DD LOG output Log
DD IMM output file for IMM-AFP-Record
The skeletons are processed by shellDataDD, see description there.
The first Skeleton VARIIN should contain a statement
analyseAFP('afp', ....)
to call the following procedure
procedure analyseAFP(afpDD, firstKey, firstVal, keys)
the datasetname allocated to dd afpDD is put to variable DSNNEW
the variable EMPTY is set to whether afpDD is empty
the first record of apfDD must be an AFP nop record with
key=value pairs in the data part
the first pair must be firstKey=firstVal
the following keys must be contained in keys (uppercased) and
the values are put to the corresponding variable
at the end all variable names in keys must be defined
the ddAfp file is read and pages, records and characters are
counted and put to the variables of these names (uppercased)
history
03.05.05 W.Keller, KPCO 4, created
***********************************************************************/
parse upper arg args
say 'pvsrWgrJ begin' args
env = ''
oldDsn = ''
m.opt.trace = 0
do i=1 to words(args)
w = word(args, i)
if w = '?' | w= '-?' then
call help
else if left(w, 1) <> '-' then do
if env == '' then
env = w
else if oldDsn == '' then
oldDsn = w
else
call err 'oldDSN' w 'specified twice in args' args
end
else if w = '-T' then
m.opt.trace = 1
else
call err 'bad option' w 'in args' args
end
if oldDsn ^== '' then
call createList env, oldDsn
else if sysvar(sysenv) = 'FORE' then
call forgroundWork env, 'WGR.ORIG.DSN.D234.T789'
else
call err 'oldDsn not specified in args' args
say 'pvsrWgrJ end ' args
exit
forgroundWork: procedure expose m.
parse arg env, oldDsn
if env = '' then
env = 'TEST'
say 'forgroundWork test begin' env oldDsn
afpDsn = 'TEST.JESOUT.T9empty'
variIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140VA)'"
mailIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140MA)'"
logIn = "'WGR.RZ1.T0.AKT.PARMLIB(PVS140LG)'"
call adrTso 'alloc dd(afp) shr dsn('afpDsn')'
if env = 1 then do
call analyseAfp afp, 'WGR2CSLST', 01
end
else do
call adrTso 'alloc dd(variIn) shr dsn('variIn')'
call adrTso 'alloc dd(mailIn) shr dsn('mailIn')'
call adrTso 'alloc dd(logIn) shr dsn('logIn')'
call adrTso 'alloc dd(vari) dsn(*)'
call adrTso 'alloc dd(mail) dsn(*)'
call adrTso 'alloc dd(log) dsn(wk.out(log))'
call adrTso 'alloc dd(imm) dsn(*)'
call createList env, oldDsn
call adrTso 'free dd(vari variIn mail mailIn log logIn imm)'
end
call adrTso 'free dd(afp)'
say 'forgroundWork test end'
return
endProcedure forgroundWork
createList: procedure expose m.
parse arg env, oldDsn
say 'createList env' env 'oldDsn' oldDsn
call shellPut 'ENV', env
call shellPut dsn, oldDsn
/* write vari Member */
call shellDataDD 'variIn', 'vari'
/* write mail */
call shellDataDD 'mailIn', 'mail'
say 'write imm begin' /* write imm */
call writeDDBegin 'imm'
xx = 0
if shellGet(copyGroup) <> '' then do
xx = xx + 1
x.xx = makeAfp('D3ABCC'x, /* imm identifier for afp */
, left(shellGet(copyGroup), 8))
call trc 'imm' length(x.xx) "'"c2x(x.xx)"'x" x.xx
end
/* x.xx = makeAfp('D3AF5F'x, ips = invoke page segment
, left(shellGet(pageSegment), 14, '00'x)) */
x.0 = xx
call writeNext 'imm', x.
call writeDDEnd 'imm'
call trc '*** imm end' x.0
/* write log */
call shellDataDD 'logIn', 'log'
return
endProcedure createList
analyseAfp: procedure expose m.
parse arg afpDD, firstKey, firstVal, keys
/* afp constants */
afp = '5A'x
bpg = 'D3A8AF'x
epg = 'D3A9AF'x
nop = 'D3EEEE'x
n.bpg = 'bpg BeginPaGe'
n.epg = 'epg EndPage'
n.nop = 'nop'
c='D3ABCC'x; n.c = 'imm InvokeMediumMap'
c='D3AF5F'x; n.c = 'ips IncludePageSegment'
c='D3A6AF'x; n.c = 'pgd PaGeDescriptor'
c='D3A69B'x; n.c = 'PTD-1 Presentation Text Descriptor Format-1'
c='D3A79B'x; n.c = 'ctc ComposeTextControl'
c='D3A8C9'x; n.c = 'bag BeginActiveEnvironment'
c='D3A89B'x; n.c = 'bpt BeginPresentationText object'
c='D3EE9B'x; n.c = 'ptx PresentationTextData'
/* get file name */
if 0 <> listDsi(afpDD 'FILE') then
call err 'bad rc in listDsi('afpDD 'FILE)'
call shellPut dsnNew, sysDsName
call readDDBegin afpDD
empty = ^ (readNext(afpDD, r.) & r.0 >= 1)
call shellPut 'EMPTY', empty
if ^ empty then do /* analyse first record */
if ^ (left(r.1, 1) == afp & substr(r.1, 4, 3) == nop) then
call err "record 1 does not start with x'"c2x(afp)"????",
|| c2x(nop)"'"
len = c2d(substr(r.1, 2, 2))
if len + 1 <> length(r.1) then
call err 'record 1 lengthField' len ,
'but record length' length(r.1)
data = substr(r.1, 10)
say 'nop data' length(data)':' data
call shellKeyValue data, firstKey, firstVal, keys
end
/* init counters */
ax = 0
recs = 0
chars = 0
cntLi = 0
cntAFP = 0
do forever /* count all lines */
recs = recs + r.0
do i = 1 to r.0
chars = chars + length(r.i)
id = left(r.i, 1)
if id == ']' then
id = substr(r.i, 4, 3)
if symbol('a.id') = 'VAR' then do
a.id = a.id + 1
end
else do
ax = ax + 1
ax.ax = id
a.id = 1
end
end
if ^ readNext(afpDD, r.) then
leave
end
call readDDEnd afpDD
do ix = 1 to ax /* cumulate counters */
c = ax.ix
IF length(c) = 1 then
cntLi = cntLi + a.c
else
cntAFP = cntAFP + a.c
call trc 'a.'c c2x(c) a.c n.c
end
/* zero undefined counters*/
if symbol('a.1') <> 'VAR' then a.1 = 0
if symbol('a.bpg') <> 'VAR' then a.bpg = 0
if symbol('a.epg') <> 'VAR' then a.epg = 0
if symbol('a.nop') <> 'VAR' then a.nop = 0
say 'afpDD' afpDD ',recs ' recs ', chars' chars
say ' linemode' cntLi 'Zeilen davon' a.1 'channel1'
if a.bpg <> a.epg then
say 'count bpg='a.bpg ' mismatches epg='a.epg
say ' afp' cntAfp 'Records, davon' a.bpg 'BPG und' a.nop 'nop'
call shellPut records, recs
call shellPut characters, chars
call shellPut pages, a.bpg + a.1
return
endProcedure analyseAFP
makeImm: procedure expose m.
parse arg imm .
return '5A'x || d2c(16, 2) || 'D3ABCC000000'x || left(imm, 8)
makeAfp: procedure expose m.
parse arg ident, data
return '5A'x || d2c(length(data)+8, 2) || left(ident, 6, '00'x) || data
return '5A'x || d2c(16, 2) || left(ident,'D3ABCC000000'x || left(imm, 8)
trc: procedure expose m.
parse arg msg
if m.opt.trace >= 1 then
say 'trc:' msg
return
endProcedure trc
err:
parse arg ggMsg;
call errA ggMsg;
exit 12;
/**********************************************************************
Shell: scan and do variable expansions etc.
shellBegin(m,..): set scan Source to a string, a stem or a dd
block = '{>' data '} ! '{;' stmts '}'
comment = '{*' ([^{}] ! block)* '}'
data = ([^{}$] !'$$' ! '$'name ! '{' name '}' ! block ! comment)*
stmts = stmt? ( ';' stmt? )*
stmt = name '=' expr ! name args ! if ! 'out' expr ! block
if = 'if' ets ('elif' ets)* ('else' stmts?)? 'endIf'
ets = expr ('then' stmts?)?
expr = ( num ! string ! name args? ! block ! '('expr')' ) (op expr)?
args = '(' expr? (',' expr?)* ')'
lexical tokens:
[^abc] any single character except 'a', 'b' or 'c'
'???' sinqle quoted strings designate constants, case insensitive
string string in single apostrophs, e.g. 'ab' 'a''b'"
name start with an alphabetic, consists of alphanums, case sensitive
num a number consisting only of digits
op most rexx operands are supported
in stmts spaces, newLines and comments are allowed around any token
***********************************************************************/
shellTest: procedure
parse arg op
if op = '' | pos('s', op) then do
m.q.1 = " abc = ('erstn''s' = 'ers' || 'tn' || '''s')"
m.q.2 = " * 2 "
m.q.3 = ";;;;; e123 = (abc * 3) + ('ab' = abc) ;;;;"
m.q.4 = "if abc = 1 then v='eins' elif abc = 2 then ;; v ='zwei';; "
m.q.5 = "else v ='??' || abc endIf; "
m.q.6 = "shellSay('abc='||abc,,'e123=' "
m.q.7 = " || e123,'v=' || v,,,'?') "
m.q.8 = ";; shellSay(shellSay(shellSay('shellSay**3')))"
m.q.9 = ";; endif ; ; "
m.q.0 = 8
say 'shellTest with' m.q.0 'stmts'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
call shellBegin c, s
call shellStmts(c)
call shellInterpret c
end
if op = '' | pos('d', op) then do
m.v.eins ='valEins'
m.v.zwei ='valZwei'
m.l.1='zeile eins geht unverändert'
m.l.2='$EINS auf zeile $ZWEI'
m.l.3='...$EINS?auf zeile {ZWEI}und a{EINS}b{ ZWEI }c'
m.l.4='{EINS}$ZWEI$EINS{ZWEI}'
m.l.5='...$EINS,uf zeile {ZWEI}und $EINS$$'
m.l.6="{;eins = 'neuEins hier'; zwei=neuZwei}und wei"
m.l.7='$EINS nach änderung $ZWEI'
m.l.0=7
say 'shellTest with' m.l.0 'data'
call scanBegin s, 'm', l
call shellBegin c, s
call shellData c
do y=1 to m.l.0
say 'old' y m.l.y
say 'new' y m.c.out.y
end
end
return
endProcedure shellTest
shellTestUfgh: procedure
parse arg a.1,a.2,a.3,a.4,a.5, a.6, a.7, a.8, a.9
s = 'call shellTestUfgh('
do x=1 to 9
if a.x <> '' then
s = s 'a.' || x || '=' || a.x
end
say s ')'
return 'shellTestUfgh('a.1')'
endProcedure shellTestUfgh
shellSay: procedure
parse arg a, b, c
say 'shellSay('a',' b',' c')'
return 'shellSay('a',' b',' c')'
shellBlockStart: procedure
parse arg st
return (left(st, 1) == '{' & length(st) == 2 ,
& pos(st, '{;{>{*') > 0)
endProcedure shellBlockStart
shellBlock: procedure expose m.
parse arg m
s = m.m.scan
if ^scanChar(s, 2) then
return 0
bl = m.s.tok
if bl = '{;' then do
rexxOld = m.m.rexx
m.m.rexx = ''
call shellStmts m
call shellInterpret m
m.m.rexx = rexxOld
end
else if bl = '{>' then do
call shellData m, 1
end
else if bl = '{*' then do
call shellComment m, 0
end
else do
call scanBack s
return 0
end
if ^ (scanChar(s, 1) & m.s.tok = '}') then
call scanErrBack s, 'closing brace (}) for' bl 'block missing'
return 1
end shellBlock
shellStmts: procedure expose m.
parse arg m
s = m.m.scan
semi = 1
do forever
do while scanChar(s, 1) & m.s.tok = ';'
semi = 1
end;
if m.s.eof then
return
call scanBack s
if ^ semi then
return
semi = 0
if shellBlock(m) then
nop
else if ^ scanName(s) then
return
else do
st = m.s.tok
stUp = translate(st)
if stUp = 'IF' then
call shellIf m
else if stUp = 'WHILE' then
call shellWhile m
else if stUp = 'OUT' then
call shellRexx m,
, "call shellOutLn '"m"'," shellExpr(m)";"
else if shellReserved(stUp) then do
call scanBack s
return
end
else if scanChar(s, 1) & m.s.tok = '=' then
call shellRexx m,
, "call shellPut '"st"'," shellExpr(m)";"
else if m.s.tok = '(' then
call shellRexx m, 'call' st shellGetArgs(m)';'
else
call scanErrBack s, 'stmt expected'
end
end /* do forever */
endProcedure shellStmts
shellBegin: procedure expose m.
parse arg m, s
m.m.scan = s
m.m.lv = 0
m.m.rexxNr = 0
m.m.rexx = ''
m.m.out.0 = 0
m.m.out.line = ''
return
endProcedure shellBegin
shellKeyValue: procedure expose m.
parse arg data, firstKey, firstVal, keys
upper firstKey keys
call scanBegin aNop, 's', data
firstTime = 1
do forever
if ^scanName(aNop) then do
if m.aNop.eof then
leave
else
call scanErr aNop, 'variableName expected'
end
name = translate(m.aNop.tok)
if ^scanChar(aNop, 1) | m.aNop.tok <> '=' then
call scanErr aNop, 'assignment operator (=) expected'
if scanName(aNop) then
value = translate(m.aNop.tok)
else if scanNum(aNop) then
value = m.aNop.tok
else if scanString(aNop) then
value = m.aNop.val
else
call scanErr aNop, "value (name or string '...') expected"
if scanRight(aNop, 1) <> '' then
call scanErr aNop, 'space expected'
if firstTime & firstKey <> '' then do
if name <> firstKey then
call scanErr aNop, 'first key is not' firstKey
if firstVal <> '' & value <> firstVal then
call scanErr aNop, 'first value is not' firstVal
end
else if wordPos(name, keys) < 1 then
call scanErr aNop, 'key' name 'not supported'
firstTime = 0
call shellPut name, value
end
all = firstKey keys
do ix=1 to words(all)
x = shellGet(word(all, ix), aNop)
end
call trc 'end analyseAfp loop'
return
endProcedure shellKeyValue
shellDataDD: procedure expose m.
parse arg readDD, writeDD
say 'shellDataDD begin' readDD writeDD
call scanBegin s, 'dd', readDD
call shellBegin c, s
call shellData c, 0
call trc 'shellData out.0' m.c.out.0
call writeDDBegin writeDD
call writeNext writeDD, 'm.c.out.'
call writeDDEnd writeDD
call scanEnd s
call trc '*** shellDataDD end' readDD writeDD
return
end shellDataDD
shellGet: procedure expose m.
parse arg name, s
if symbol('m.v.name') = 'VAR' then
return m.v.name
else if s ^== '' then
call scanErrBack s, 'var' name 'not defined'
else
call err 'var' name 'not defined'
endProcedure shellGet
shellPut: procedure expose m.
parse arg name, value
m.v.name = value
call trc 'assign' name '= <'value'>'
return
endProcedure shellPut
shellData: procedure expose m.
parse arg m, partial
s = m.m.scan
ol = ''
if partial = 1 then
if scanRight(s) = '' then
call scanNextLine s /* skip empty partial line */
do forever
call scanUntil s, '{}$'
call shellOut m, m.s.tok
stop = scanRight(s, 2)
if stop = '' then do
call shellOutLn m
if ^ scanNextLine(s) then
return
end
else if left(stop, 1) = '}' then do
if partial <> 1 then
call scanErr s, 'unpaired closing brace (})'
/* forget partial empty line */
call shellOutLn m, , ( scanLeft(s) = '')
return
end
else if shellBlockStart(stop) then do
call shellOutLn m, , (scanLeft(s) = '')
call shellBlock m
if scanRight(s) = '' then
if ^ scanNextLine(s) then /* skip empty partial line */
return
end
else if left(stop, 1) = '$' then do
call scanChar s, 1
if ri = '' then
call shellOut m, '$'
else if ^ scanName(s) then
call shellOut m, '$'
else
call shellOutVar m, m.s.tok
end
else do
call scanChar s, 1
call scanUntil s, '}'
if scanRight(s, 1) ^== '}' then
call scanErrBack s, 'closing } for {name missing'
call shellOutVar m, strip(m.s.tok), s
call scanChar s, 1
end
end;
endProcedure shellData
shellComment: procedure expose m.
parse arg m, strings
s = m.m.scan
do while ^ m.s.eof
if strings then
call scanUntil s, "{}'"
else
call scanUntil s, "{}"
st = scanRight(s, 2)
if st = '' then
call scanNextLine s
else if left(st, 1) = '}' then
return
else if left(st, 1) = "'" then
call scanString s
else do
call scanChar s, 1
call shellComment m, st = '{;'
if ^ (scanChar(s, 1) | m.s.tok ^== '}' then
call scanErrBack 'comment not terminated by }'
end
end
call scanErr s, 'non terminated comment'
endProcedure shellComment
shellOutLn: procedure expose m.
parse arg m, txt, forget
if forget <> 1 then do
ox = m.m.out.0 + 1
m.m.out.0 = ox
m.m.out.ox = strip(m.m.out.line || txt, 't')
call trc 'shellOutLn' ox':' m.m.out.ox
end
m.m.out.line = ''
return
endProcedure shellOut
shellOut: procedure expose m.
parse arg m, txt
m.m.out.line = m.m.out.line || txt
return
endProcedure shellOut
shellOutVar: procedure expose m.
parse arg m, name, scn
m.m.out.line = m.m.out.line || shellGet(name, scn)
return
endProcedure shellOutVar
shellRexx: procedure expose m.
parse arg m, line
m.m.rexxNr = m.m.rexxNr + 1
m.m.rexx = m.m.rexx line
call trc 'shellRexx'right(m.m.rexxNr, 4)':' left('', m.m.lv * 2)line
return
endProcedure shellRexx
shellInterpret: procedure expose m.
parse arg m
call trc 'shellInterpret' m 'src:' m.m.rexx
interpret m.m.rexx
call trc 'interpret rc' rc 'result' result
return
end shellInterpret
shellExpr: procedure expose m.
parse arg m
s = m.m.scan
if scanName(s) then do
nm = m.s.tok
if shellReserved(nm) then
call scanErrBack s, 'reserved word in expression'
else if scanChar(s, 1) & m.s.tok = '(' then
res = nm'('shellGetArgs(m)')'
else do
call scanBack s
res = "shellGet('"nm"')"
end
end
else if scanNum(s) then
res = m.s.tok
else if scanString(s) then
res = m.s.tok
else if scanChar(s, 1) & m.s.tok = '(' then do
res = shellExpr(m)
if ^ (scanChar(s, 1) & m.s.tok = ')') then
call scanErrBack s, "closing bracket ')' missing"
res = '('res')'
end
else
call scanErrBack s, "expression expected"
if ^ scanChar(s, 2) then
return res
op = strip(m.s.tok)
if ^ (length(op) = 2 & pos(op, '== || <> <= >=') > 0) then do
op = left(op, 1)
call scanBack s
if pos(op, '+-*/%=') = 0 then
return res
call scanChar s, 1
end
return res op shellExpr(m)
endProcedure shellExpr
shellGetArgs: procedure expose m.
parse arg m
s = m.m.scan
ex = ''
do forever
if scanChar(s, 1) & m.s.tok = ')' then
return ex
else if m.s.tok = ',' then
ex = ex ','
else do
call scanBack s
if ^( ex = '' | right(ex, 1) = ',') then
call scanErr s, ', or ) expected'
ex = ex shellExpr(m)
end
end
endProcedure getArgs
shellReserved: procedure expose m.
parse upper arg wrd, s
if wordPos(wrd, 'IF THEN ELIF ELSE ENDIF WHILE DO ENDWHILE OUT')< 1 then
return 0
else if s = '' then
return 1
else
call scanErr s, 'reservered word' wrd 'in bad place'
endProcedure shellReserved
shellIf: procedure expose m.
parse arg m
s = m.m.scan
st = 'if'
do forever
ex = shellExpr(m)
call scanName s
na = translate(m.s.tok)
if na = 'THEN' then do
call shellRexx m, st "1 = ("ex") then do;"
m.m.lv = m.m.lv + 1
call shellStmts(m)
call shellRexx m, 'end;'
m.m.lv = m.m.lv - 1
call scanName s
na = translate(m.s.tok)
end
else
call shellRexx m, st "1 = ("ex") then nop;"
if na <> 'ELIF' then
leave
st = 'else if'
end;
if na = 'ELSE' then do
call shellRexx m, 'else do;'
m.m.lv = m.m.lv + 1
call shellStmts m
call shellRexx m, 'end;'
m.m.lv = m.m.lv - 1
call scanName s
na = translate(m.s.tok)
end
if na <> 'ENDIF' then
call scanErrBack s, 'endif expected'
return
endProcedure shellIf
/**********************************************************************
Scan: scan an input:
scanBegin(m,..): set scan Source to a string, a stem or a dd
scanEnd (m) : end scan
scanBack(m) : 1 step backwards (only once)
scanChar(m,n) : scan next (nonSpace) n characters
scanName(m,al) : scan a name if al='' otherwise characters in al
scanNum(m) : scan integer (without sign)
scanString(m,q): scan a String with quote q. (with doubble = 1)
scanErr(m, txt): error with current scan location
***********************************************************************/
scanTest: procedure
m.q.1 = " 034uUnd hier123sdfER'string1' 'string2''mit''apo''s' "
m.q.2 = " "
m.q.3 = "'erstn''s' = ('ers' || 'tn' || '''s')"
m.q.4 = " drei;+HHhier123sdfER?? '''' "
m.q.0 = 4
say 'scanTest begin' m.q.0 'input Lines'
do i=1 to m.q.0
say 'm.q.'i m.q.i
end
call scanBegin s, 'm', q
do forever
if scanName(s) then
say 'scanned name' m.s.tok
else if scanNum(s) then
say 'scanned num' m.s.tok
else if scanString(s) then
say 'scanned string val' length(m.s.val)':' m.s.val ,
'tok' m.s.tok
else if scanChar(s,1) then
say 'scanned char' m.s.tok
else
leave
end
call scanEnd s
say 'scanTest end'
return
endProcedure scanTest
scanBegin: procedure expose m.
parse arg m, pTyp, pOpt
m.m.typ = pTyp
if pTyp = 'm' then do
m.m.lines = pOpt
end
else if pTyp = 's' then do
m.m.lines = m
m.m.0 = 1
m.m.1 = pOpt
end
else if pTyp = 'dd' then do
m.m.lines = m
m.m.0 = 0
m.m.dd = pOpt
call readDDBegin m.m.dd
end
else
call err 'bad scanBegin typ' pTyp
m.m.lx = 1
m.m.baseLx = 0
m.m.bx = 1
m.m.cx = 1
m.m.curLi = m.m.lines'.1'
m.m.eof = 0
if pTyp = 'dd' then
call scanNextLine m
return
endProcedure scanBegin
scanEnd: procedure expose m.
parse arg m
if m.m.typ = 'dd' then
call readDDEnd m.m.dd
return
endProcedure scanEnd
scanNextLine: procedure expose m.
parse arg m
l = m.m.lines
m.m.lx = m.m.lx + 1
if m.m.lx > m.l.0 then do
if m.m.typ <> 'dd' then do
m.m.eof = 1
return 0
end
m.m.baseLx = m.m.baseLx + m.m.0
if ^ readNext(m.m.dd, 'm.'m'.') then do
m.m.eof = 1
return 0
end
m.m.lx = 1
end
m.m.curLi = l'.'m.m.lx
m.m.cx = 1
m.m.bx = 1
return 1
endProcedure scanNextLine
scanRight: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if length(m.l) >= m.m.cx + len then
return substr(m.l, m.m.cx, len)
return substr(m.l, m.m.cx)
endProcedure scanRight
scanLeft: procedure expose m.
parse arg m, len
l = m.m.curLi
if len <> '' then
if len < m.m.bx then
return substr(m.l, m.m.bx - len, len)
return left(m.l, m.m.bx - 1)
endProcedure scanLeft
scanChar: procedure expose m.
parse arg m, len
do forever
l = m.m.curLi
vx = verify(m.l, ' ', 'n', m.m.cx)
if vx > 0 then
leave
if ^ scanNextLine(m) then do
m.m.tok = ''
return 0
end
end
if length(m.l) >= vx + len then
m.m.tok = substr(m.l, vx, len)
else
m.m.tok = substr(m.l, vx)
m.m.bx = vx
m.m.cx = vx + length(m.m.tok)
return 1
endProcedure scanChar
scanBack: procedure expose m.
parse arg m
if m.m.bx >= m.m.cx then
call scanErr m, 'scanBack works only once'
m.m.cx = m.m.bx
return 1
endProcedure scanBack
scanString: procedure expose m.
parse arg m, qu
m.m.tok = ''
m.m.val = ''
if qu = '' then
qu = "'"
if ^ scanChar(m, 1) then
return 0
qx = m.m.cx
m.m.cx = m.m.bx
if m.m.tok <> qu then
return 0
l = m.m.curLi
do forever
px = pos(qu, m.l, qx)
if px < 1 then
call scanErr m, 'ending Apostroph('qu') missing'
m.m.val = m.m.val || substr(m.l, qx, px-qx)
if px >= length(m.l) then
leave
else if substr(m.l, px+1, 1) <> qu then
leave
qx = px+2
m.m.val = m.m.val || qu
end
m.m.tok = substr(m.l, m.m.bx, px+1-m.m.bx)
m.m.cx = px+1
return 1
endProcedure scanString
scanName: procedure expose m.
parse arg m, alpha
m.m.tok = ''
if ^ scanChar(m, 1) then
return 0
m.m.cx = m.m.bx
if alpha = '' then do
alpha ,
= '0123456789abcdefghijklmnopqurstuvwxyzABCDEFGHIJKLMNOPQURSTUVWXYZ'
if pos(m.m.tok, alpha) <= 10 then
return 0
end
l = m.m.curLi
vx = verify(m.l, alpha, 'n', m.m.bx)
if vx = m.m.bx then
return 0
if vx < 1 then
m.m.tok = substr(m.l, m.m.bx)
else
m.m.tok = substr(m.l, m.m.bx, vx-m.m.bx)
m.m.cx = m.m.bx + length(m.m.tok)
return 1
endProcedure scanName
scanUntil: procedure expose m.
parse arg m, alpha
m.m.bx = m.m.cx
l = m.m.curLi
m.m.cx = verify(m.l, alpha, 'm', m.m.bx)
if m.m.cx = 0 then
m.m.cx = length(m.l) + 1
m.m.tok = substr(m.l, m.m.bx, m.m.cx - m.m.bx)
return 1
endProcedure scanUntil
scanNum: procedure expose m.
parse arg m
return scanName(m, '0123456789')
end scanNum
scanErr: procedure expose m.
parse arg m, txt
say 'scanErr' txt
l = m.m.curLi
say 'charPos' m.m.cx substr(m.l, m.m.cx)
whe = 'typ' m.m.typ
if m.m.typ = 'dd' then
whe = whe m.m.dd (m.m.baseLx + m.m.lx)
say whe 'line' l m.l
call err 'scanErr' txt
endProcedure scanErr
scanErrBack: procedure expose m.
parse arg m, txt
m.m.cx = m.m.bx /* avoid error by using errBack| */
call scanErr m, txt
endProcedure scanErrBack
/* 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
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
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
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
dsnPosLev: procedure
parse arg dsn, lx
if lx > 0 then do
if lx = 1 then do
sx = 1
end
else do
sx = posCnt('.', dsn, lx-1) + 1
if sx <= 1 then
return 0
end;
end
else if lx < 0 then do
if lx = -1 then do
ex = 1 + length(dsn)
end
else do
ex = posCnt('.', dsn, lx+1)
if ex < 1 then
return 0
end;
sx = lastPos('.', dsn, ex-1) + 1
end
else
return 0
if sx > 1 then
return sx
else if left(dsn, 1) = "'" then
return 2
else
return 1
endProcedure dsnPosLev
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
dsnTemp: procedure
parse upper arg suf
l = time(l);
d = 'tempFile.t'left(l,2)substr(l,4,2)substr(l,7,2)'.m'right(l,6)
call trc 'jobName' mvsVar('SYMDEF', 'JOBNAME')
d = 'tmpFile.'mvsVar('SYMDEF', 'JOBNAME')'.'suf
call trc 'tempFile' sub '=>' d
return d
endProcedure dsnTemp
/**********************************************************************
StringHandling
posCnt: return the index of cnt'th occurrence of needle
negativ cnt are counted from the right
***********************************************************************/
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
posCnt: procedure
parse arg needle, hayStack, cnt, start
if cnt > 0 then do
if start = '' then
start = 1
do cc = 1 to cnt
sx = pos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx + length(needle)
end
return start - length(needle)
end
else if cnt < 0 then do
if start = '' then
start = length(hayStack)
do cc = 1 to -cnt
sx = lastPos(needle, hayStack, start)
if sx < 1 then
return 0
start = sx - length(needle)
end
return start + length(needle)
end
else
return 0
endProcedure posCnt
/**********************************************************************
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
***********************************************************************/
lmdTest: procedure
parse arg lev
say showTime() 'lmdTest' lev
call lmdBegin 'test', lev
say showTime() 'lmdTest after begin' lev
z = 0
do while lmdNext('test', st.)
do y=1 to st.0
z=z+1
say z word(st.y, 1)
end
end
call lmdEnd 'test'
say showTime() 'lmdTest' z 'files in' lev
return /* readTest */
lmdBegin: procedure
parse arg grp, lev
call adrIsp 'lmdinit listid(lmdId) level('lev')'
call adrIsp 'lmdlist listid(&lmdId) option(save) group('grp')'
call adrIsp 'lmdfree listid(&lmdId)'
say showTime() 'lmdlist save' grp lev
call readBegin grp, grp'.datasets'
return /* end lmdBegin */
lmdNext:
parse arg ggGrp, ggSt
return readNext(ggGrp, ggSt)
lmdEnd: procedure
parse arg grp
call readEnd 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
if adrIspRc("LMMLIST DATAID("lmmId") option(free)") <> 0 then
if rc <> 8 then
call err "lmmEnd" id lmmId "rc" rc "for lmmList free"
call adrIsp "LMCLOSE DATAID("lmmId")"
call adrIsp "LMFREE DATAID("lmmId")"
return
endProcedure lmmEnd
lmmNext: procedure
parse arg lmmId opt
gmRc = adrIspRc("LMMLIST DATAID("lmmid")" ,
"OPTION(LIST) MEMBER(Mbr)" opt)
if gmRc = 0 then
return mbr
else if gmRc = 8 | gmRC = 4 then
return ''
else
call err 'lmmList rc' gmRc
endProcedure lmmNext
/**********************************************************************
read: read a file
valid call sequences:
readDsn read a whole dsn
readDDBegin, readNext*, readDDEnd read dd in chunks
readBegin, readNext*, readEnd read dsn in chunks
writeBegin, writeNext*, writeEnd write dsn in chunks
readNext liest 100 records in übergebenen stem,
returns false at eof
***********************************************************************/
readTest: procedure
parse arg dsn
say showTime() 'readTest' dsn
call readBegin 'ddEins', dsn
z = 0
do while readNext('ddEins', st.)
do y=1 to st.0
z=z+1
say z strip(st.y, 't')
end
end
call readEnd 'ddEins'
say showTime() 'readTest' z 'records in' dsn
return /* readTest */
readDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(readDsn) shr dsn('ggdsn')'
call adrTso 'execio * diskr readDsn (stem' ggSt' finis)'
call adrTso 'free dd(readDsn)'
return
endSubroutine readDsn
readDDBegin: procedure
return /* end readDDBegin */
readBegin: procedure
parse arg dd, dsn
call adrTso 'alloc dd('dd') shr dsn('dsn')'
return /* end readBegin */
readNext:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
if adrTsoRc('execio' ggCnt 'diskr' ggDD '(stem' ggSt')') = 0 then
return 1
else if rc = 2 then
return (value(ggSt'0') > 0)
else
call err 'execio' ggCnt 'diskr' ggDD 'rc' rc
return /* end readNext */
readDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskr' dd '(finis)'
return /* end readDDEnd */
readEnd: procedure
parse arg dd
call readDDEnd dd
call adrTso 'free dd('dd')'
return /* end readEnd */
writeDDBegin: procedure
return /* end writeDDBegin */
writeNext:
parse arg ggDD, ggSt
call adrTso 'execio' value(ggst'0') 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeNext
writeDDEnd: procedure
parse arg dd
call adrTso 'execio 0 diskw' dd '(finis)'
return /* end writeDDEnd */
writeDsn:
parse arg ggDsn, ggSt
call adrTso 'alloc dd(ggWrite) dsn('ggDsn')'
call writeDDBegin 'ggWrite'
call writeNext 'ggWrite', ggSt
call writeDDEnd 'ggWrite'
call adrTso 'free dd(ggWrite)'
return
endProcedure writeDsn
/**********************************************************************
writeApp: append lines to a file
ggDsn: dsn to append lines
ggStem stem containing line (with dot|)
ggNr number of lines, if empty <stem>.0
***********************************************************************/
writeApp:
parse arg ggDsn, ggStem, ggNr
if ggNr = '' then
ggNr = value(ggStem'0')
if pos('(', ggDsn) < 1 then do /* sequential ds, use disp=mod */
call adrTso 'alloc mod reuse dd(ddApp) dsn('ggDsn')'
end
else do /* pds: read and rewrite */
call adrTso 'alloc shr reuse dd(ddApp) dsn('ggDsn')'
if sysdsn(ggDsn) = 'OK' then do
call adrTso 'execio * diskr ddApp (stem ggL. finis)'
call adrTso 'execio' ggL.0 'diskw ddApp (stem ggL.)'
end
end
call adrTso 'execio' ggNr 'diskw ddApp (stem' ggStem 'finis)'
call adrTso 'free dd(ddApp)'
return
endProcedure writeApp
log: procedure
parse arg logLine
l.1 = date('s') time() logLine
call writeApp 'wk.out(ll)', l., 1
return
endProcedure log
/**********************************************************************
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
adrTso: fails if rc <> 0
adrTsoRc: returns rc without failing
***********************************************************************/
adrTsoRc:
parse arg tsoCmd
address tso tsoCmd
return rc /* end adrTsoRc */
adrTso:
parse arg tsoCmd
address tso tsoCmd
if rc <> 0 then
call err 'adrTso rc' rc 'for' tsoCmd
return /* end adrTso */
adrIspRc:
parse arg ispCmd
address ispexec ispCmd
return rc /* end adrIspRc */
adrIsp:
parse arg ispCmd
address ispexec ispCmd
if rc <> 0 then
call err 'adrIsp rc' rc 'for' ispCmd
return /* end adrIsp */
adrEdit:
parse arg editCmd, ret
address isrEdit editCmd
if rc <> 0 then
call err 'adr isrEdit rc' rc 'for' editCmd
return /* end adrEdit */
adrEditRc:
parse arg editCmd
address isrEdit editCmd
return rc /* end adrEditRc */
/**********************************************************************
messages, errorhandling help
***********************************************************************/
errA:
/* caller should define err as follows:
err: parse arg ggMsg; call errA ggMsg; exit 12; */
parse arg ggTxt
parse source . . ggS3 .
say 'fatal error in' ggS3':' ggTxt
exit setRc(12)
endSubroutine err
setRc: procedure
parse arg zIspfRc
/**********************************************************************
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
***********************************************************************/
if sysVar('sysISPF') = 'ACTIVE' then do
say 'exitRc setting zIspfRc='zIspfRc
address ispExec vput 'zIspfRc' shared
end
return zIspfRc
endProcedure setRc
errHelp: procedure
parse arg ggMsg
say 'fatal error:' ggMsg
call help
call err ggMsg
endProcedure errHelp
help: procedure
/**********************************************************************
display the first comment block of the source as help text
***********************************************************************/
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
endProcedure help
showtime: procedure
parse arg showmsg
return time() sysvar('syscpu') sysvar('syssrv') showmsg
/* copy adr end ****************************************************/